@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-}
1+{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, GeneralizedNewtypeDeriving #-}
22#if __GLASGOW_HASKELL__ >= 708
33{-# LANGUAGE DataKinds #-}
44#endif
@@ -7,9 +7,12 @@
77
88module UnitTests (ioTests, tests) where
99
10+import Prelude ()
11+import Prelude.Compat
12+
1013import Control.Applicative (Const(..))
1114import Control.Monad (forM)
12−import Data.Aeson (decode, eitherDecode, encode, genericToJSON, genericToEncoding, object, FromJSON(..), withObject, (.=), (.:), (.:?), (.:!))
15+import Data.Aeson (FromJSONKeyFunction(..), FromJSONKey(..), decode, eitherDecode, encode, genericToJSON, genericToEncoding, object, FromJSON(..), withObject, (.=), (.:), (.:?), (.:!))
1316import Data.Aeson.Encode (encodeToTextBuilder)
1417import Data.Aeson.Internal (JSONPathElement(..), formatError)
1518import Data.Aeson.TH (deriveJSON)
@@ -21,6 +24,7 @@ import Data.Maybe (fromMaybe)
2124import Data.Proxy (Proxy(..))
2225import Data.Sequence (Seq)
2326import Data.Tagged (Tagged(..))
27+import Data.Text (Text)
2428import Data.Time (UTCTime)
2529import Data.Time.Format (parseTime)
2630import Data.Time.Locale.Compat (defaultTimeLocale)
@@ -69,6 +73,7 @@ tests = testGroup "unit" [
6973 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws
7074 , testGroup "Issue #351" $ fmap (testCase "-") issue351
7175 , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors
76+ , testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions
7277 ]
7378
7479roundTripCamel :: String -> Assertion
@@ -290,6 +295,48 @@ hashableLaws = [
290295 a = object ["223" .= False, "807882556" .= True]
291296 b = object ["807882556" .= True, "223" .= False]
292297
298+-------------------------------------------------------------------------------
299+-- ToJSONKey
300+-------------------------------------------------------------------------------
301+
302+newtype MyText = MyText Text
303+ deriving (FromJSONKey)
304+
305+newtype MyText' = MyText' Text
306+
307+instance FromJSONKey MyText' where
308+ fromJSONKey = fmap MyText' fromJSONKey
309+ fromJSONKeyList = error "not used"
310+
311+fromJSONKeyAssertions :: [Assertion]
312+fromJSONKeyAssertions =
313+ [ assertIsCoerce "Text" (fromJSONKey :: FromJSONKeyFunction Text)
314+ , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text))
315+ , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText)
316+
317+-- Why this doesn't work on older GHC?
318+#if __GLASGOW_HASKELL__ >= 710
319+ , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText')
320+#endif
321+ ]
322+ where
323+ assertIsCoerce _ (FromJSONKeyCoerce _) = pure ()
324+ assertIsCoerce n _ = assertFailure n
325+
326+#if __GLASGOW_HASKELL__ >= 710
327+ assertIsCoerce' _ (FromJSONKeyCoerce _) = pure ()
328+ assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ())
329+
330+-- | Pick the first when RULES are enabled, e.g. optimisations are on
331+pickWithRules
332+ :: a -- ^ Pick this when RULES are on
333+ -> a -- ^ use this otherwise
334+ -> a
335+pickWithRules _ = id
336+{-# NOINLINE pickWithRules #-}
337+{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-}
338+#endif
339+
293340------------------------------------------------------------------------------
294341-- Regressions
295342------------------------------------------------------------------------------