From 720b857e2e0acf2edc4f5512f2b217a89449a89d Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Fri, 16 Sep 2022 21:34:15 +0300
Subject: [PATCH] Issue 967: Use unsafeDupablePerformIO in unsafePackLenLiteral

---
 aeson.cabal                           |  1 +
 changelog.md                          |  2 ++
 src/Data/Aeson/Internal/ByteString.hs |  5 ++--
 tests/Regression/Issue967.hs          | 38 +++++++++++++++++++++++++++
 tests/UnitTests.hs                    |  2 ++
 5 files changed, 46 insertions(+), 2 deletions(-)
 create mode 100644 tests/Regression/Issue967.hs

diff --git a/aeson.cabal b/aeson.cabal
index 20a1a1705..508c01f42 100644
--- a/aeson.cabal
+++ b/aeson.cabal
@@ -175,6 +175,7 @@ test-suite aeson-tests
     PropertyRTFunctors
     PropertyTH
     PropUtils
+    Regression.Issue967
     SerializationFormatSpec
     Types
     UnitTests
diff --git a/changelog.md b/changelog.md
index 41b3aef22..2b65fbfd0 100644
--- a/changelog.md
+++ b/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
 
diff --git a/src/Data/Aeson/Internal/ByteString.hs b/src/Data/Aeson/Internal/ByteString.hs
index 4a59e33ff..f6bdb1dfc 100644
--- a/src/Data/Aeson/Internal/ByteString.hs
+++ b/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
diff --git a/tests/Regression/Issue967.hs b/tests/Regression/Issue967.hs
new file mode 100644
index 000000000..e9d400d70
--- /dev/null
+++ b/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
diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs
index f47afdf20..d36ba56b9 100644
--- a/tests/UnitTests.hs
+++ b/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
   ]