1{-# LANGUAGE NoImplicitPrelude #-}
2
3module PropertyTH ( templateHaskellTests ) where
4
5import Prelude.Compat
6
7import Data.Semigroup (Option(..))
8import Encoders
9import Instances ()
10import Test.Tasty (TestTree, testGroup)
11import Test.Tasty.QuickCheck (testProperty)
12import Test.QuickCheck ( (===) )
13import Types
14import PropUtils
15
16
17templateHaskellTests :: TestTree
18templateHaskellTests =
19    testGroup "template-haskell" [
20      testGroup "toJSON" [
21        testGroup "Nullary" [
22            testProperty "string" (isString . thNullaryToJSONString)
23          , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
24          , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)
25          , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
26
27          , testGroup "roundTrip" [
28              testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
29            , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
30            , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)
31            , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
32            ]
33        ]
34      , testGroup "EitherTextInt" [
35          testProperty "UntaggedValue" (isUntaggedValueETI . thEitherTextIntToJSONUntaggedValue)
36        , testProperty "roundtrip" (toParseJSON thEitherTextIntParseJSONUntaggedValue thEitherTextIntToJSONUntaggedValue)
37        ]
38      , testGroup "SomeType" [
39          testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)
40        , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)
41        , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thSomeTypeToJSONObjectWithSingleField)
42        , testGroup "roundTrip" [
43            testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)
44          , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)
45          , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)
46
47          , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray)
48          , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject)
49          , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)
50
51          ]
52        ]
53      , testGroup "Approx" [
54          testProperty "string"                (isString                . thApproxToJSONUnwrap)
55        , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
56        , testGroup "roundTrip" [
57            testProperty "string"                (toParseJSON thApproxParseJSONUnwrap  thApproxToJSONUnwrap)
58          , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
59          ]
60        ]
61      , testGroup "GADT" [
62          testProperty "string"                (isString                . thGADTToJSONUnwrap)
63        , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)
64        , testGroup "roundTrip" [
65            testProperty "string"                (toParseJSON thGADTParseJSONUnwrap  thGADTToJSONUnwrap)
66          , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
67          ]
68        ]
69      , testGroup "OneConstructor" [
70          testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)
71        , testProperty "Tagged"  (isTaggedObject . thOneConstructorToJSONTagged)
72        , testGroup "roundTrip" [
73            testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)
74          , testProperty "Tagged"  (toParseJSON thOneConstructorParseJSONTagged  thOneConstructorToJSONTagged)
75          ]
76        ]
77      , testGroup "OptionField" [
78          testProperty "like Maybe" $
79          \x -> thOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)
80        , testProperty "roundTrip" (toParseJSON thOptionFieldParseJSON thOptionFieldToJSON)
81        ]
82      ]
83    , testGroup "toEncoding" [
84        testProperty "NullaryString" $
85        thNullaryToJSONString `sameAs` thNullaryToEncodingString
86      , testProperty "Nullary2ElemArray" $
87        thNullaryToJSON2ElemArray `sameAs` thNullaryToEncoding2ElemArray
88      , testProperty "NullaryTaggedObject" $
89        thNullaryToJSONTaggedObject `sameAs` thNullaryToEncodingTaggedObject
90      , testProperty "NullaryObjectWithSingleField" $
91        thNullaryToJSONObjectWithSingleField `sameAs`
92        thNullaryToEncodingObjectWithSingleField
93      , testProperty "ApproxUnwrap" $
94        thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap
95      , testProperty "ApproxDefault" $
96        thApproxToJSONDefault `sameAs` thApproxToEncodingDefault
97
98      , testProperty "EitherTextInt UntaggedValue" $
99        thEitherTextIntToJSONUntaggedValue `sameAs` thEitherTextIntToEncodingUntaggedValue
100
101      , testProperty "SomeType2ElemArray" $
102        thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray
103      , testProperty "SomeType2ElemArray unary" $
104        thSomeTypeLiftToJSON2ElemArray `sameAs1` thSomeTypeLiftToEncoding2ElemArray
105      , testProperty "SomeType2ElemArray unary agree" $
106        thSomeTypeToEncoding2ElemArray `sameAs1Agree` thSomeTypeLiftToEncoding2ElemArray
107
108      , testProperty "SomeTypeTaggedObject" $
109        thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject
110      , testProperty "SomeTypeTaggedObject unary" $
111        thSomeTypeLiftToJSONTaggedObject `sameAs1` thSomeTypeLiftToEncodingTaggedObject
112      , testProperty "SomeTypeTaggedObject unary agree" $
113        thSomeTypeToEncodingTaggedObject `sameAs1Agree` thSomeTypeLiftToEncodingTaggedObject
114
115      , testProperty "SomeTypeObjectWithSingleField" $
116        thSomeTypeToJSONObjectWithSingleField `sameAs` thSomeTypeToEncodingObjectWithSingleField
117      , testProperty "SomeTypeObjectWithSingleField unary" $
118        thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField
119      , testProperty "SomeTypeObjectWithSingleField unary agree" $
120        thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField
121
122      , testProperty "OneConstructorDefault" $
123        thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault
124      , testProperty "OneConstructorTagged" $
125        thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged
126
127      , testProperty "OptionField" $
128        thOptionFieldToJSON `sameAs` thOptionFieldToEncoding
129      ]
130    ]
131