git.iko.soy/typeable/aeson
on 0.11.2.0-r2 help sign in
typeable/aeson/tests/Properties.hs
234 lines 11 kB history raw
1{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
3module Properties where
5import Control.Applicative (Const)
6import Data.Aeson (eitherDecode)
7import Data.Aeson.Encode (encode)
8import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)
9import Data.Aeson.Parser (value)
10import Data.Aeson.Types
11import Data.ByteString.Builder (toLazyByteString)
12import Data.Int (Int8)
13import Data.List.NonEmpty (NonEmpty)
14import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime,
15 ZonedTime)
16import Data.Proxy (Proxy)
17import Data.Tagged (Tagged)
18import Data.Version (Version)
19import Encoders
20import Instances ()
21import Numeric.Natural (Natural)
22import Test.Framework (Test, testGroup)
23import Test.Framework.Providers.QuickCheck2 (testProperty)
24import Test.QuickCheck (Arbitrary(..), Property, (===), (.&&.), counterexample)
25import Types
26import qualified Data.Attoparsec.Lazy as L
27import qualified Data.ByteString.Lazy.Char8 as L
28import qualified Data.HashMap.Strict as H
29import qualified Data.Map as Map
30import qualified Data.Text as T
31import qualified Data.Vector as V
33encodeDouble :: Double -> Double -> Property
34encodeDouble num denom
35 | isInfinite d || isNaN d = encode d === "null"
36 | otherwise = (read . L.unpack . encode) d === d
37 where d = num / denom
39encodeInteger :: Integer -> Property
40encodeInteger i = encode i === L.pack (show i)
42toParseJSON :: (Arbitrary a, Eq a, Show a) =>
43 (Value -> Parser a) -> (a -> Value) -> a -> Property
44toParseJSON parsejson tojson x =
45 case iparse parsejson . tojson $ x of
46 IError path msg -> failure "parse" (formatError path msg) x
47 ISuccess x' -> x === x'
49roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>
50 (a -> a -> Property) -> a -> a -> Property
51roundTripEnc eq _ i =
52 case fmap ifromJSON . L.parse value . encode $ i of
53 L.Done _ (ISuccess v) -> v `eq` i
54 L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i
55 L.Fail _ _ err -> failure "parse" err i
57roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>
58 (a -> a -> Property) -> a -> a -> Property
59roundTripNoEnc eq _ i =
60 case ifromJSON . toJSON $ i of
61 (ISuccess v) -> v `eq` i
62 (IError path err) -> failure "fromJSON" (formatError path err) i
64roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property
65roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y
67infix 4 ==~
68(==~) :: (ApproxEq a, Show a) => a -> a -> Property
69x ==~ y =
70 counterexample (show x ++ " /= " ++ show y) (x =~ y)
72roundTripApproxEq :: (ApproxEq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property
73roundTripApproxEq x y = roundTripEnc (==~) x y .&&. roundTripNoEnc (==~) x y
75toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property
76toFromJSON x = case ifromJSON (toJSON x) of
77 IError path err -> failure "fromJSON" (formatError path err) x
78 ISuccess x' -> x === x'
80modifyFailureProp :: String -> String -> Bool
81modifyFailureProp orig added =
82 result == Error (added ++ orig)
83 where
84 parser = const $ modifyFailure (added ++) $ fail orig
85 result :: Result ()
86 result = parse parser ()
88-- | Perform a structural comparison of the results of two encoding
89-- methods. Compares decoded values to account for HashMap-driven
90-- variation in JSON object key ordering.
91sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property
92sameAs toVal toEnc v =
93 eitherDecode (toLazyByteString (fromEncoding (toEnc v))) === Right (toVal v)
95type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()
96type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
98--------------------------------------------------------------------------------
99-- Value properties
100--------------------------------------------------------------------------------
102isString :: Value -> Bool
103isString (String _) = True
104isString _ = False
106is2ElemArray :: Value -> Bool
107is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)
108is2ElemArray _ = False
110isTaggedObjectValue :: Value -> Bool
111isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&
112 "contents" `H.member` obj
113isTaggedObjectValue _ = False
115isTaggedObject :: Value -> Bool
116isTaggedObject (Object obj) = "tag" `H.member` obj
117isTaggedObject _ = False
119isObjectWithSingleField :: Value -> Bool
120isObjectWithSingleField (Object obj) = H.size obj == 1
121isObjectWithSingleField _ = False
123--------------------------------------------------------------------------------
125tests :: Test
126tests = testGroup "properties" [
127 testGroup "encode" [
128 testProperty "encodeDouble" encodeDouble
129 , testProperty "encodeInteger" encodeInteger
130 ]
131 , testGroup "roundTrip" [
132 testProperty "Bool" $ roundTripEq True
133 , testProperty "Double" $ roundTripEq (1 :: Approx Double)
134 , testProperty "Int" $ roundTripEq (1 :: Int)
135 , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)
136 , testProperty "Integer" $ roundTripEq (1 :: Integer)
137 , testProperty "String" $ roundTripEq ("" :: String)
138 , testProperty "Text" $ roundTripEq T.empty
139 , testProperty "Foo" $ roundTripEq (undefined :: Foo)
140 , testProperty "Day" $ roundTripEq (undefined :: Day)
141 , testProperty "DotNetTime" $ roundTripApproxEq (undefined :: DotNetTime)
142 , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime)
143 , testProperty "TimeOfDay" $ roundTripEq (undefined :: TimeOfDay)
144 , testProperty "UTCTime" $ roundTripEq (undefined :: UTCTime)
145 , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)
146 , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)
147 , testProperty "Version" $ roundTripEq (undefined :: Version)
148 , testProperty "Natural" $ roundTripEq (undefined :: Natural)
149 , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)
150 , testProperty "Tagged" $ roundTripEq (undefined :: Tagged Int Char)
151 , testProperty "Const" $ roundTripEq (undefined :: Const Int Char)
152 , testGroup "ghcGenerics" [
153 testProperty "OneConstructor" $ roundTripEq OneConstructor
154 , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)
155 , testProperty "Product6" $ roundTripEq (undefined :: P6)
156 , testProperty "Sum4" $ roundTripEq (undefined :: S4)
157 ]
158 ]
159 , testGroup "toFromJSON" [
160 testProperty "Integer" (toFromJSON :: Integer -> Property)
161 , testProperty "Double" (toFromJSON :: Double -> Property)
162 , testProperty "Maybe Integer" (toFromJSON :: Maybe Integer -> Property)
163 , testProperty "Either Integer Double" (toFromJSON :: Either Integer Double -> Property)
164 , testProperty "Either Integer Integer" (toFromJSON :: Either Integer Integer -> Property)
165 ]
166 , testGroup "failure messages" [
167 testProperty "modify failure" modifyFailureProp
168 ]
169 , testGroup "template-haskell" [
170 testGroup "toJSON" [
171 testGroup "Nullary" [
172 testProperty "string" (isString . thNullaryToJSONString)
173 , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)
174 , testProperty "TaggedObject" (isTaggedObjectValue . thNullaryToJSONTaggedObject)
175 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)
177 , testGroup "roundTrip" [
178 testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)
179 , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)
180 , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)
181 , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)
182 ]
183 ]
184 , testGroup "SomeType" [
185 testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)
186 , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)
187 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thSomeTypeToJSONObjectWithSingleField)
188 , testGroup "roundTrip" [
189 testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)
190 , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)
191 , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)
192 ]
193 , testGroup "Approx" [
194 testProperty "string" (isString . thApproxToJSONUnwrap)
195 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)
196 , testGroup "roundTrip" [
197 testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)
198 , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)
199 ]
200 ]
201 , testGroup "GADT" [
202 testProperty "string" (isString . thGADTToJSONUnwrap)
203 , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)
204 , testGroup "roundTrip" [
205 testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)
206 , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)
207 ]
208 ]
209 ]
210 ]
211 , testGroup "toEncoding" [
212 testProperty "NullaryString" $
213 thNullaryToJSONString `sameAs` thNullaryToEncodingString
214 , testProperty "Nullary2ElemArray" $
215 thNullaryToJSON2ElemArray `sameAs` thNullaryToEncoding2ElemArray
216 , testProperty "NullaryTaggedObject" $
217 thNullaryToJSONTaggedObject `sameAs` thNullaryToEncodingTaggedObject
218 , testProperty "NullaryObjectWithSingleField" $
219 thNullaryToJSONObjectWithSingleField `sameAs`
220 thNullaryToEncodingObjectWithSingleField
221 , testProperty "ApproxUnwrap" $
222 thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap
223 , testProperty "ApproxDefault" $
224 thApproxToJSONDefault `sameAs` thApproxToEncodingDefault
225 , testProperty "SomeType2ElemArray" $
226 thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray
227 , testProperty "SomeTypeTaggedObject" $
228 thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject
229 , testProperty "SomeTypeObjectWithSingleField" $
230 thSomeTypeToJSONObjectWithSingleField `sameAs`
231 thSomeTypeToEncodingObjectWithSingleField
232 ]
233 ]
234 ]