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