git.iko.soy/typeable/aeson
on 1.4.4.0 help sign in
typeable/aeson/tests/PropUtils.hs
208 lines 7.1 kB history raw
1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes #-}
5module PropUtils (module PropUtils) where
7import Prelude.Compat
9import Data.Aeson (eitherDecode, encode)
10import Data.Aeson.Encoding (encodingToLazyByteString)
11import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)
12import qualified Data.Aeson.Internal as I
13import Data.Aeson.Parser (value)
14import Data.Aeson.Types
15import Data.HashMap.Strict (HashMap)
16import Data.Hashable (Hashable)
17import Data.Int (Int8)
18import Data.Map (Map)
19import Data.Time (ZonedTime)
20import Encoders
21import Instances ()
22import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample)
23import Types
24import qualified Data.Attoparsec.Lazy as L
25import qualified Data.ByteString.Lazy.Char8 as L
26import qualified Data.HashMap.Strict as H
27import qualified Data.Map as Map
28import qualified Data.Text as T
29import qualified Data.Vector as V
32encodeDouble :: Double -> Double -> Property
33encodeDouble num denom
34 | isInfinite d || isNaN d = encode d === "null"
35 | otherwise = (read . L.unpack . encode) d === d
36 where d = num / denom
38encodeInteger :: Integer -> Property
39encodeInteger i = encode i === L.pack (show i)
41toParseJSON :: (Eq a, Show a) =>
42 (Value -> Parser a) -> (a -> Value) -> a -> Property
43toParseJSON parsejson tojson x =
44 case iparse parsejson . tojson $ x of
45 IError path msg -> failure "parse" (formatError path msg) x
46 ISuccess x' -> x === x'
48toParseJSON1
49 :: (Eq (f Int), Show (f Int))
50 => (forall a. LiftParseJSON f a)
51 -> (forall a. LiftToJSON f a)
52 -> f Int
53 -> Property
54toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson
55 where
56 parsejson = parsejson1 parseJSON (listParser parseJSON)
57 tojson = tojson1 toJSON (listValue toJSON)
59roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>
60 (a -> a -> Property) -> a -> a -> Property
61roundTripEnc eq _ i =
62 case fmap ifromJSON . L.parse value . encode $ i of
63 L.Done _ (ISuccess v) -> v `eq` i
64 L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i
65 L.Fail _ _ err -> failure "parse" err i
67roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>
68 (a -> a -> Property) -> a -> a -> Property
69roundTripNoEnc eq _ i =
70 case ifromJSON . toJSON $ i of
71 (ISuccess v) -> v `eq` i
72 (IError path err) -> failure "fromJSON" (formatError path err) i
74roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property
75roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y
77-- We test keys by encoding HashMap and Map with it
78roundTripKey
79 :: (Ord a, Hashable a, FromJSONKey a, ToJSONKey a, Show a)
80 => a -> HashMap a Int -> Map a Int -> Property
81roundTripKey _ h m = roundTripEq h h .&&. roundTripEq m m
83infix 4 ==~
84(==~) :: (ApproxEq a, Show a) => a -> a -> Property
85x ==~ y =
86 counterexample (show x ++ " /= " ++ show y) (x =~ y)
88toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property
89toFromJSON x = case ifromJSON (toJSON x) of
90 IError path err -> failure "fromJSON" (formatError path err) x
91 ISuccess x' -> x === x'
93modifyFailureProp :: String -> String -> Bool
94modifyFailureProp orig added =
95 result == Error (added ++ orig)
96 where
97 parser = const $ modifyFailure (added ++) $ fail orig
98 result :: Result ()
99 result = parse parser ()
101parserThrowErrorProp :: String -> Property
102parserThrowErrorProp msg =
103 result === Error msg
104 where
105 parser = const $ parserThrowError [] msg
106 result :: Result ()
107 result = parse parser ()
109-- | Tests (also) that we catch the JSONPath and it has elements in the right order.
110parserCatchErrorProp :: [String] -> String -> Property
111parserCatchErrorProp path msg =
112 result === Success ([I.Key "outer", I.Key "inner"] ++ jsonPath, msg)
113 where
114 parser = parserCatchError outer (curry pure)
116 outer = inner I.<?> I.Key "outer"
117 inner = parserThrowError jsonPath msg I.<?> I.Key "inner"
119 result :: Result (I.JSONPath, String)
120 result = parse (const parser) ()
122 jsonPath = map (I.Key . T.pack) path
124-- | Perform a structural comparison of the results of two encoding
125-- methods. Compares decoded values to account for HashMap-driven
126-- variation in JSON object key ordering.
127sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property
128sameAs toVal toEnc v =
129 counterexample (show s) $
130 eitherDecode s === Right (toVal v)
131 where
132 s = encodingToLazyByteString (toEnc v)
134sameAs1
135 :: (forall a. LiftToJSON f a)
136 -> (forall a. LiftToEncoding f a)
137 -> f Int
138 -> Property
139sameAs1 toVal1 toEnc1 v = lhs === rhs
140 where
141 rhs = Right $ toVal1 toJSON (listValue toJSON) v
142 lhs = eitherDecode . encodingToLazyByteString $
143 toEnc1 toEncoding (listEncoding toEncoding) v
145sameAs1Agree
146 :: ToJSON a
147 => (f a -> Encoding)
148 -> (forall b. LiftToEncoding f b)
149 -> f a
150 -> Property
151sameAs1Agree toEnc toEnc1 v = rhs === lhs
152 where
153 rhs = encodingToLazyByteString $ toEnc v
154 lhs = encodingToLazyByteString $ toEnc1 toEncoding (listEncoding toEncoding) v
156type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()
157type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)
159--------------------------------------------------------------------------------
160-- Value properties
161--------------------------------------------------------------------------------
163-- | Add the formatted @Value@ to the printed counterexample when the property
164-- fails.
165checkValue :: Testable a => (Value -> a) -> Value -> Property
166checkValue prop v = counterexample (L.unpack (encode v)) (prop v)
168isString :: Value -> Bool
169isString (String _) = True
170isString _ = False
172is2ElemArray :: Value -> Bool
173is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)
174is2ElemArray _ = False
176isTaggedObjectValue :: Value -> Bool
177isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&
178 "contents" `H.member` obj
179isTaggedObjectValue _ = False
181isNullaryTaggedObject :: Value -> Bool
182isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj
184isTaggedObject :: Value -> Property
185isTaggedObject = checkValue isTaggedObject'
187isTaggedObject' :: Value -> Bool
188isTaggedObject' (Object obj) = "tag" `H.member` obj
189isTaggedObject' _ = False
191isObjectWithSingleField :: Value -> Bool
192isObjectWithSingleField (Object obj) = H.size obj == 1
193isObjectWithSingleField _ = False
195-- | is untaggedValue of EitherTextInt
196isUntaggedValueETI :: Value -> Bool
197isUntaggedValueETI (String s)
198 | s == "nonenullary" = True
199isUntaggedValueETI (Bool _) = True
200isUntaggedValueETI (Number _) = True
201isUntaggedValueETI (Array a) = length a == 2
202isUntaggedValueETI _ = False
204isEmptyArray :: Value -> Property
205isEmptyArray = checkValue isEmptyArray'
207isEmptyArray' :: Value -> Bool
208isEmptyArray' = (Array mempty ==)