{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE QuasiQuotes          #-}
{-# LANGUAGE BangPatterns #-}

-- Here we use Template Haskell to generate a test suite for the Aeson wrappers
-- from the DSL description of same.

module Data.API.Tools.JSONTests
    ( -- * Tools
      jsonTestsTool
    , cborTestsTool
    , cborToJSONTestsTool
    , jsonToCBORTestsTool
    , jsonGenericValueTestsTool
    , cborGenericValueTestsTool

      -- * Properties
    , 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


-- | Tool to generate a list of JSON round-trip tests of type
-- @[('String', 'Property')]@ with the given name.  This depends on
-- 'jsonTool' and 'quickCheckTool'.
jsonTestsTool :: Name -> APITool
jsonTestsTool :: Name -> APITool
jsonTestsTool = Name -> Name -> APITool
testsTool 'prop_resultsMatchRoundtrip

-- | Tool to generate a list of CBOR round-trip tests of type
-- @[('String', 'Property')]@ with the given name.  This depends on
-- 'cborTool' and 'quickCheckTool'.
cborTestsTool :: Name -> APITool
cborTestsTool :: Name -> APITool
cborTestsTool = Name -> Name -> APITool
testsTool 'prop_cborRoundtrip

-- | Tool to generate a list of tests of type @[('String', 'Property')]@
-- based on instantiating the first argument at type @A -> Bool@ for each
-- type @A@ in the API.  The second argument is the name of the declaration
-- that should be produced.
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 ]

-- | For an APINode, generate a (String, Property) pair giving the
-- type name and an appropriate instance of the property
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


-- | Tool to generate a list of CBOR-to-JSON conversion tests of type
-- @[('String', 'Property')]@.  The first name must be the 'API' being
-- tested, and the second should be the name of the declaration to be
-- produced.  This depends on 'cborTool', 'jsonTool' and 'quickCheckTool'.
cborToJSONTestsTool :: Name -> Name -> APITool
cborToJSONTestsTool :: Name -> Name -> APITool
cborToJSONTestsTool = Name -> Name -> Name -> APITool
schemaTestsTool 'prop_cborToJSON

-- | Tool to generate a list of JSON-to-CBOR conversion tests of type
-- @[('String', 'Property')]@.  The first name must be the 'API' being
-- tested, and the second should be the name of the declaration to be
-- produced.  This depends on 'cborTool', 'jsonTool' and 'quickCheckTool'.
jsonToCBORTestsTool :: Name -> Name -> APITool
jsonToCBORTestsTool :: Name -> Name -> APITool
jsonToCBORTestsTool = Name -> Name -> Name -> APITool
schemaTestsTool 'prop_jsonToCBOR

-- | Tool to generate a list of tests that the 'JS.Value' generic
-- representation agrees with the type-specific JSON representation.
jsonGenericValueTestsTool :: Name -> Name -> APITool
jsonGenericValueTestsTool :: Name -> Name -> APITool
jsonGenericValueTestsTool = Name -> Name -> Name -> APITool
schemaTestsTool 'prop_jsonGeneric

-- | Tool to generate a list of tests that the 'Value' generic
-- representation agrees with the type-specific CBOR representation.
cborGenericValueTestsTool :: Name -> Name -> APITool
cborGenericValueTestsTool :: Name -> Name -> APITool
cborGenericValueTestsTool = Name -> Name -> Name -> APITool
schemaTestsTool 'prop_cborGeneric

-- | Tool to generate a list of tests of properties that take the API
-- and the type name as arguments, and return a 'QCProperty.Result'.
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


-- | QuickCheck property that a 'Value' decodes to an expected Haskell
-- value, using 'fromJSONWithErrs'
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

-- | QuickCheck property that a 'Value' decodes to an expected Haskell
-- value, using 'fromJSONWithErrs'' with the given 'ParseFlags'
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

-- | QuickCheck property that Haskell values can be encoded with
-- 'toJSON' and decoded with 'fromJSONWithErrs' to get the original
-- value
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

-- | QuickCheck property that CBOR decoding is a left inverse for encoding
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

-- | QuickCheck property that 'toJSON' agrees with encoding to CBOR
-- directly and then decoding using the schema-aware generic decoder.
-- From this and 'prop_resultsMatchRoundtrip' it follows that
--
-- > fromJSONWithErrs . deserialiseJSONWithSchema . serialise == id
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

-- | QuickCheck property that direct encoding to CBOR agrees with
-- conversion to JSON followed by the schema-aware generic encoder.
-- From this and 'prop_cborRoundtrip' it follows that
--
-- > deserialise . serialiseJSONWithSchema . toJSON == id
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