{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE QuantifiedConstraints #-}
module Hedgehog.Classes.Generic (genericLaws) where
import Hedgehog
import Hedgehog.Classes.Common
import GHC.Generics (Generic(..))
genericLaws ::
( Generic a, Eq a, Show a
, Eq (Rep a x), Show (Rep a x)
)
=> Gen a
-> Gen (Rep a x)
-> Laws
genericLaws :: Gen a -> Gen (Rep a x) -> Laws
genericLaws Gen a
gena Gen (Rep a x)
genr = String -> [(String, Property)] -> Laws
Laws String
"Generic"
[ (String
"From-To inverse", Gen a -> Gen (Rep a x) -> Property
forall a x.
(Generic a, Eq (Rep a x), Show (Rep a x)) =>
Gen a -> Gen (Rep a x) -> Property
fromToInverse Gen a
gena Gen (Rep a x)
genr)
, (String
"To-From inverse", Gen a -> Gen (Rep a x) -> Property
forall a x.
(Generic a, Eq a, Show a) =>
Gen a -> Gen (Rep a x) -> Property
toFromInverse Gen a
gena Gen (Rep a x)
genr)
]
fromToInverse :: forall a x.
( Generic a
, Eq (Rep a x)
, Show (Rep a x)
) => Gen a -> Gen (Rep a x) -> Property
fromToInverse :: Gen a -> Gen (Rep a x) -> Property
fromToInverse Gen a
_gena Gen (Rep a x)
genr = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
Rep a x
r <- Gen (Rep a x) -> PropertyT IO (Rep a x)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen (Rep a x)
genr
let lhs :: Rep a x
lhs = Rep a x
r
let rhs :: Rep a x
rhs = a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (Rep a x -> a
forall a x. Generic a => Rep a x -> a
to Rep a x
r :: a)
let ctx :: Context
ctx = LawContext -> Context
contextualise (LawContext -> Context) -> LawContext -> Context
forall a b. (a -> b) -> a -> b
$ LawContext :: String -> String -> String -> String -> String -> LawContext
LawContext
{ lawContextLawName :: String
lawContextLawName = String
"From-To inverse", lawContextTcName :: String
lawContextTcName = String
"Generic"
, lawContextLawBody :: String
lawContextLawBody = String
"from . to" String -> String -> String
`congruency` String
"id"
, lawContextTcProp :: String
lawContextTcProp =
let showR :: String
showR = Rep a x -> String
forall a. Show a => a -> String
show Rep a x
r
in [String] -> String
lawWhere
[ String
"from . to $ r" String -> String -> String
`congruency` String
"id r, where"
, String
"r = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showR
]
, lawContextReduced :: String
lawContextReduced = Rep a x -> Rep a x -> String
forall a. Show a => a -> a -> String
reduced Rep a x
lhs Rep a x
forall x. Rep a x
rhs
}
Rep a x -> Rep a x -> Context -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx Rep a x
lhs Rep a x
forall x. Rep a x
rhs Context
ctx
toFromInverse :: forall a x.
( Generic a
, Eq a
, Show a
) => Gen a -> Gen (Rep a x) -> Property
toFromInverse :: Gen a -> Gen (Rep a x) -> Property
toFromInverse Gen a
gena Gen (Rep a x)
_genr = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
a
v <- Gen a -> PropertyT IO a
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gena
let lhs :: a
lhs = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
v)
let rhs :: a
rhs = a
v
let ctx :: Context
ctx = LawContext -> Context
contextualise (LawContext -> Context) -> LawContext -> Context
forall a b. (a -> b) -> a -> b
$ LawContext :: String -> String -> String -> String -> String -> LawContext
LawContext
{ lawContextLawName :: String
lawContextLawName = String
"To-From inverse", lawContextTcName :: String
lawContextTcName = String
"Generic"
, lawContextLawBody :: String
lawContextLawBody = String
"to . from" String -> String -> String
`congruency` String
"id"
, lawContextTcProp :: String
lawContextTcProp =
let showV :: String
showV = a -> String
forall a. Show a => a -> String
show a
v
in [String] -> String
lawWhere
[ String
"to . from $ v" String -> String -> String
`congruency` String
"id v, where"
, String
"v = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showV
]
, lawContextReduced :: String
lawContextReduced = a -> a -> String
forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
}
a -> a -> Context -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx