{-# 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 = (API -> Q [Dec]) -> APITool
forall a. (a -> Q [Dec]) -> Tool a
simpleTool ((API -> Q [Dec]) -> APITool) -> (API -> Q [Dec]) -> APITool
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 = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (APINode -> ExpQ) -> [APINode] -> [ExpQ]
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| ($ExpQ
ty, property ($(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
prop_nm) :: $(APINode -> TypeQ
nodeT APINode
an) -> Bool)) |]
  where
    ty :: ExpQ
ty = TypeName -> ExpQ
typeNameE (TypeName -> ExpQ) -> TypeName -> ExpQ
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 = (API -> Q [Dec]) -> APITool
forall a. (a -> Q [Dec]) -> Tool a
simpleTool ((API -> Q [Dec]) -> APITool) -> (API -> Q [Dec]) -> APITool
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 = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (APINode -> ExpQ) -> [APINode] -> [ExpQ]
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| ($ExpQ
ty, property ($(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
prop_nm) $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
api_nm) tn :: $(APINode -> TypeQ
nodeT APINode
an) -> QCProperty.Result)) |]
      where
        tn :: TypeName
tn = APINode -> TypeName
anName APINode
an
        ty :: ExpQ
ty = TypeName -> ExpQ
typeNameE (TypeName -> ExpQ) -> TypeName -> ExpQ
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 Value -> Either [(JSONError, Position)] a
forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs Value
v :: Either [(JSONError, Position)] a of
                       Right a
y | a
x a -> a -> Bool
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 ParseFlags -> Value -> Either [(JSONError, Position)] a
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 a -> a -> Bool
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 = Value -> a -> Bool
forall a. (Eq a, FromJSONWithErrs a) => Value -> a -> Bool
prop_decodesTo (a -> Value
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 = ByteString -> a
forall a. Serialise a => ByteString -> a
deserialise (a -> ByteString
forall a. Serialise a => a -> ByteString
serialise a
x) a -> a -> Bool
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 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
v2  = Result
succeeded
  | Bool
otherwise = Result
failed { QCProperty.reason = "Post-processed: " ++ show v1
                                        ++ "\nDirect JSON:    " ++ show v2 }
  where
    v1 :: Value
v1 = API -> TypeName -> ByteString -> Value
deserialiseJSONWithSchema API
api TypeName
tn (a -> ByteString
forall a. Serialise a => a -> ByteString
serialise a
x)
    v2 :: Value
v2 = a -> Value
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
e2  = Result
succeeded
  | Bool
otherwise = Result
failed { QCProperty.reason = "Failed with JSON:      " ++ show v
                                        ++ "\nGeneric serialisation: " ++ show e1
                                        ++ "\nDirect serialisation:  " ++ show e2 }
  where
    v :: Value
v  = a -> Value
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 = a -> ByteString
forall a. Serialise a => a -> ByteString
serialise a
x