1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module UnitTests.FromJSONKey (fromJSONKeyTests) where
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, Assertion, assertFailure)
import Data.Text (Text)
import Data.Tagged (Tagged)
import Control.Applicative (Const)
import Data.Aeson
newtype MyText = MyText Text
deriving (FromJSONKey)
newtype MyText' = MyText' Text
instance FromJSONKey MyText' where
fromJSONKey = fmap MyText' fromJSONKey
fromJSONKeyList = error "not used"
fromJSONKeyTests :: TestTree
fromJSONKeyTests = testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions
fromJSONKeyAssertions :: [Assertion]
fromJSONKeyAssertions =
[ assertIsCoerce "Text" (fromJSONKey :: FromJSONKeyFunction Text)
, assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text))
, assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText)
, assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText')
, assertIsCoerce "Const Text" (fromJSONKey :: FromJSONKeyFunction (Const Text ()))
]
where
assertIsCoerce :: String -> FromJSONKeyFunction a -> Assertion
assertIsCoerce _ FromJSONKeyCoerce = pure ()
assertIsCoerce n _ = assertFailure n
assertIsCoerce' :: String -> FromJSONKeyFunction a -> Assertion
assertIsCoerce' _ FromJSONKeyCoerce = pure ()
assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ())
-- | Pick the first when RULES are enabled, e.g. optimisations are on
pickWithRules
:: a -- ^ Pick this when RULES are on
-> a -- ^ use this otherwise
-> a
pickWithRules _ = id
{-# NOINLINE pickWithRules #-}
{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-}
|
