{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE BangPatterns #-}
module Data.API.Tools.JSONTests
(
jsonTestsTool
, cborTestsTool
, cborToJSONTestsTool
, jsonToCBORTestsTool
, jsonGenericValueTestsTool
, cborGenericValueTestsTool
, prop_decodesTo
, prop_decodesTo'
, prop_resultsMatchRoundtrip
, prop_cborRoundtrip
, prop_cborToJSON
, prop_jsonToCBOR
) where
import Data.API.JSON
import Data.API.JSONToCBOR
import Data.API.Tools.Combinators
import Data.API.Tools.Datatypes
import Data.API.TH
import Data.API.Types
import Data.API.Value
import qualified Data.Aeson as JS
import Codec.Serialise
import Data.Binary.Serialise.CBOR.JSON ()
import Language.Haskell.TH
import Test.QuickCheck
import Test.QuickCheck.Property as QCProperty
import Prelude
jsonTestsTool :: Name -> APITool
jsonTestsTool :: Name -> APITool
jsonTestsTool = Name -> Name -> APITool
testsTool 'prop_resultsMatchRoundtrip
cborTestsTool :: Name -> APITool
cborTestsTool :: Name -> APITool
cborTestsTool = Name -> Name -> APITool
testsTool 'prop_cborRoundtrip
testsTool :: Name -> Name -> APITool
testsTool :: Name -> Name -> APITool
testsTool Name
prop_nm Name
nm = forall a. (a -> Q [Dec]) -> Tool a
simpleTool forall a b. (a -> b) -> a -> b
$ \ API
api -> Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD Name
nm [t| [(String, Property)] |] (API -> ExpQ
props API
api)
where
props :: API -> ExpQ
props API
api = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name -> APINode -> ExpQ
generateProp Name
prop_nm) [ APINode
an | ThNode APINode
an <- API
api ]
generateProp :: Name -> APINode -> ExpQ
generateProp :: Name -> APINode -> ExpQ
generateProp Name
prop_nm APINode
an = [e| ($ty, property ($(varE prop_nm) :: $(nodeT an) -> Bool)) |]
where
ty :: ExpQ
ty = TypeName -> ExpQ
typeNameE forall a b. (a -> b) -> a -> b
$ APINode -> TypeName
anName APINode
an
cborToJSONTestsTool :: Name -> Name -> APITool
cborToJSONTestsTool :: Name -> Name -> APITool
cborToJSONTestsTool = Name -> Name -> Name -> APITool
schemaTestsTool 'prop_cborToJSON
jsonToCBORTestsTool :: Name -> Name -> APITool
jsonToCBORTestsTool :: Name -> Name -> APITool
jsonToCBORTestsTool = Name -> Name -> Name -> APITool
schemaTestsTool 'prop_jsonToCBOR
jsonGenericValueTestsTool :: Name -> Name -> APITool
jsonGenericValueTestsTool :: Name -> Name -> APITool
jsonGenericValueTestsTool = Name -> Name -> Name -> APITool
schemaTestsTool 'prop_jsonGeneric
cborGenericValueTestsTool :: Name -> Name -> APITool
cborGenericValueTestsTool :: Name -> Name -> APITool
cborGenericValueTestsTool = Name -> Name -> Name -> APITool
schemaTestsTool 'prop_cborGeneric
schemaTestsTool :: Name -> Name -> Name -> APITool
schemaTestsTool :: Name -> Name -> Name -> APITool
schemaTestsTool Name
prop_nm Name
api_nm Name
nm = forall a. (a -> Q [Dec]) -> Tool a
simpleTool forall a b. (a -> b) -> a -> b
$ \ API
api -> Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD Name
nm [t| [(String, Property)] |] (API -> ExpQ
props API
api)
where
props :: API -> ExpQ
props API
api = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map APINode -> ExpQ
genProp [ APINode
an | ThNode APINode
an <- API
api ]
genProp :: APINode -> ExpQ
genProp APINode
an = [e| ($ty, property ($(varE prop_nm) $(varE api_nm) tn :: $(nodeT an) -> QCProperty.Result)) |]
where
tn :: TypeName
tn = APINode -> TypeName
anName APINode
an
ty :: ExpQ
ty = TypeName -> ExpQ
typeNameE forall a b. (a -> b) -> a -> b
$ APINode -> TypeName
anName APINode
an
prop_decodesTo :: forall a . (Eq a, FromJSONWithErrs a)
=> JS.Value -> a -> Bool
prop_decodesTo :: forall a. (Eq a, FromJSONWithErrs a) => Value -> a -> Bool
prop_decodesTo Value
v a
x = case forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs Value
v :: Either [(JSONError, Position)] a of
Right a
y | a
x forall a. Eq a => a -> a -> Bool
== a
y -> Bool
True
Either [(JSONError, Position)] a
_ -> Bool
False
prop_decodesTo' :: forall a . (Eq a, FromJSONWithErrs a)
=> ParseFlags -> JS.Value -> a -> Bool
prop_decodesTo' :: forall a.
(Eq a, FromJSONWithErrs a) =>
ParseFlags -> Value -> a -> Bool
prop_decodesTo' ParseFlags
pf Value
v a
x = case forall a.
FromJSONWithErrs a =>
ParseFlags -> Value -> Either [(JSONError, Position)] a
fromJSONWithErrs' ParseFlags
pf Value
v :: Either [(JSONError, Position)] a of
Right a
y | a
x forall a. Eq a => a -> a -> Bool
== a
y -> Bool
True
Either [(JSONError, Position)] a
_ -> Bool
False
prop_resultsMatchRoundtrip :: forall a . (Eq a, JS.ToJSON a, FromJSONWithErrs a )
=> a -> Bool
prop_resultsMatchRoundtrip :: forall a. (Eq a, ToJSON a, FromJSONWithErrs a) => a -> Bool
prop_resultsMatchRoundtrip a
x = forall a. (Eq a, FromJSONWithErrs a) => Value -> a -> Bool
prop_decodesTo (forall a. ToJSON a => a -> Value
JS.toJSON a
x) a
x
prop_cborRoundtrip :: forall a . (Eq a, Serialise a)
=> a -> Bool
prop_cborRoundtrip :: forall a. (Eq a, Serialise a) => a -> Bool
prop_cborRoundtrip a
x = forall a. Serialise a => ByteString -> a
deserialise (forall a. Serialise a => a -> ByteString
serialise a
x) forall a. Eq a => a -> a -> Bool
== a
x
prop_cborToJSON :: forall a . (Eq a, Serialise a, JS.ToJSON a)
=> API -> TypeName -> a -> QCProperty.Result
prop_cborToJSON :: forall a.
(Eq a, Serialise a, ToJSON a) =>
API -> TypeName -> a -> Result
prop_cborToJSON API
api TypeName
tn a
x
| Value
v1 forall a. Eq a => a -> a -> Bool
== Value
v2 = Result
succeeded
| Bool
otherwise = Result
failed { reason :: String
QCProperty.reason = String
"Post-processed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
v1
forall a. [a] -> [a] -> [a]
++ String
"\nDirect JSON: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
v2 }
where
v1 :: Value
v1 = API -> TypeName -> ByteString -> Value
deserialiseJSONWithSchema API
api TypeName
tn (forall a. Serialise a => a -> ByteString
serialise a
x)
v2 :: Value
v2 = forall a. ToJSON a => a -> Value
JS.toJSON a
x
prop_jsonToCBOR :: forall a . (Eq a, Serialise a, JS.ToJSON a)
=> API -> TypeName -> a -> QCProperty.Result
prop_jsonToCBOR :: forall a.
(Eq a, Serialise a, ToJSON a) =>
API -> TypeName -> a -> Result
prop_jsonToCBOR API
api TypeName
tn a
x
| ByteString
e1 forall a. Eq a => a -> a -> Bool
== ByteString
e2 = Result
succeeded
| Bool
otherwise = Result
failed { reason :: String
QCProperty.reason = String
"Failed with JSON: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
v
forall a. [a] -> [a] -> [a]
++ String
"\nGeneric serialisation: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
e1
forall a. [a] -> [a] -> [a]
++ String
"\nDirect serialisation: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
e2 }
where
v :: Value
v = forall a. ToJSON a => a -> Value
JS.toJSON a
x
e1 :: ByteString
e1 = API -> TypeName -> Value -> ByteString
serialiseJSONWithSchema API
api TypeName
tn Value
v
e2 :: ByteString
e2 = forall a. Serialise a => a -> ByteString
serialise a
x