{-# 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 = ([Thing] -> Q [Dec]) -> APITool
forall a. (a -> Q [Dec]) -> Tool a
simpleTool (([Thing] -> Q [Dec]) -> APITool)
-> ([Thing] -> Q [Dec]) -> APITool
forall a b. (a -> b) -> a -> b
$ \ [Thing]
api -> Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD Name
nm [t| [(String, Property)] |] ([Thing] -> ExpQ
props [Thing]
api)
  where
    props :: [Thing] -> ExpQ
props [Thing]
api = [ExpQ] -> ExpQ
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 <- [Thing]
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 (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 = ([Thing] -> Q [Dec]) -> APITool
forall a. (a -> Q [Dec]) -> Tool a
simpleTool (([Thing] -> Q [Dec]) -> APITool)
-> ([Thing] -> Q [Dec]) -> APITool
forall a b. (a -> b) -> a -> b
$ \ [Thing]
api -> Name -> TypeQ -> ExpQ -> Q [Dec]
simpleSigD Name
nm [t| [(String, Property)] |] ([Thing] -> ExpQ
props [Thing]
api)
  where
    props :: [Thing] -> ExpQ
props [Thing]
api = [ExpQ] -> ExpQ
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 <- [Thing]
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 (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 :: 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' :: 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 :: 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 :: 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 :: [Thing] -> TypeName -> a -> Result
prop_cborToJSON [Thing]
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 { reason :: String
QCProperty.reason = String
"Post-processed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v1
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nDirect JSON:    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v2 }
  where
    v1 :: Value
v1 = [Thing] -> TypeName -> ByteString -> Value
deserialiseJSONWithSchema [Thing]
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 :: [Thing] -> TypeName -> a -> Result
prop_jsonToCBOR [Thing]
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 { reason :: String
QCProperty.reason = String
"Failed with JSON:      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nGeneric serialisation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
e1
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nDirect serialisation:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
e2 }
  where
    v :: Value
v  = a -> Value
forall a. ToJSON a => a -> Value
JS.toJSON a
x
    e1 :: ByteString
e1 = [Thing] -> TypeName -> Value -> ByteString
serialiseJSONWithSchema [Thing]
api TypeName
tn Value
v
    e2 :: ByteString
e2 = a -> ByteString
forall a. Serialise a => a -> ByteString
serialise a
x