Issue 967: Use unsafeDupablePerformIO in unsafePackLenLiteral

aeson.cabal

@@ -175,6 +175,7 @@ test-suite aeson-tests
     PropertyRTFunctors
     PropertyTH
     PropUtils
+    Regression.Issue967
     SerializationFormatSpec
     Types
     UnitTests

changelog.md

@@ -3,6 +3,8 @@ For the latest version of this document, please see [https://github.com/haskell/
 ### 2.1.1.0
 
 - Add `Data.Aeson.KeyMap.!?` (flipped) alias to `Data.Aeson.KeyMap.lookup`.
+- Use `unsafeDupablePerformIO` instead of incorrect `accursedUnutterablePerformIO` in creation of keys in TH serialisation.
+  This fixes a bug in TH deriving, e.g. when `Strict` pragma was enabled.
 
 ### 2.1.0.0
 

src/Data/Aeson/Internal/ByteString.hs

@@ -13,8 +13,8 @@ import Data.Word (Word8)
 import Foreign.ForeignPtr (ForeignPtr)
 import Data.ByteString.Short (ShortByteString, fromShort)
 import GHC.Exts (Addr#, Ptr (Ptr))
-import Data.ByteString.Internal (accursedUnutterablePerformIO)
 import Data.ByteString.Short.Internal (createFromPtr)
+import System.IO.Unsafe (unsafeDupablePerformIO)
 
 import qualified Data.ByteString as BS
 import qualified Language.Haskell.TH.Lib as TH
@@ -82,6 +82,7 @@ liftSBS sbs = withBS bs $ \_ len -> [| unsafePackLenLiteral |]
       bs = fromShort sbs
 #endif
 
+-- this is copied verbatim from @bytestring@, but only in recent versions.
 unsafePackLenLiteral :: Int -> Addr# -> ShortByteString
 unsafePackLenLiteral len addr# =
-    accursedUnutterablePerformIO $ createFromPtr (Ptr addr#) len
+    unsafeDupablePerformIO $ createFromPtr (Ptr addr#) len

tests/Regression/Issue967.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE Strict #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- {-# OPTIONS_GHC -ddump-splices #-}
+-- {-# OPTIONS_GHC -ddump-simpl -ddump-to-file #-}
+module Regression.Issue967 (issue967) where
+
+import Test.Tasty (TestTree)
+import Test.Tasty.HUnit (testCase, assertEqual)
+
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LTE
+
+import Data.Aeson
+import Data.Aeson.TH
+
+data DataA = DataA
+  { val1 :: Int,
+    val2 :: Int
+  }
+  deriving (Eq, Show)
+
+-------------------------------------------------------------------------------
+-- Instances
+-------------------------------------------------------------------------------
+
+$(deriveJSON defaultOptions ''DataA)
+
+-------------------------------------------------------------------------------
+-- Test
+-------------------------------------------------------------------------------
+
+issue967 :: TestTree
+issue967 = testCase "issue967" $ do
+  let ev = DataA 1 2
+      encoding = encode ev
+      parsedEv = decode encoding :: Maybe DataA
+
+  assertEqual (LT.unpack $ LTE.decodeUtf8 encoding) (Just ev) parsedEv

tests/UnitTests.hs

@@ -81,6 +81,7 @@ import qualified Data.Vector as Vector
 import qualified ErrorMessages
 import qualified SerializationFormatSpec
 import qualified Data.Map as Map -- Lazy!
+import Regression.Issue967
 
 roundTripCamel :: String -> Assertion
 roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
@@ -894,4 +895,5 @@ tests = testGroup "unit" [
       assertEqual "" (object ["foo" .= True]) [aesonQQ| {"foo": true } |]
     ]
   , monadFixTests
+  , issue967
   ]