{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Test.Validity.Functor
( functorSpecOnValid
, functorSpec
, functorSpecOnArbitrary
, functorSpecOnGens
) where
import Data.Data
import Data.GenValidity
import Test.Hspec
import Test.QuickCheck
import Test.Validity.Functions
import Test.Validity.Utils
{-# ANN module "HLint: ignore Functor law" #-}
fmapTypeStr ::
forall (f :: * -> *). (Typeable f)
=> String
fmapTypeStr =
unwords
[ "fmap"
, "::"
, "(a"
, "->"
, "b)"
, "->"
, nameOf @f
, "a"
, "->"
, nameOf @f
, "b"
]
flTypeStr ::
forall (f :: * -> *). (Typeable f)
=> String
flTypeStr =
unwords ["(<$)", "::", "a", "->", nameOf @f, "b", "->", nameOf @f, "a"]
functorSpecOnValid ::
forall (f :: * -> *).
(Eq (f Int), Show (f Int), Functor f, Typeable f, GenValid (f Int))
=> Spec
functorSpecOnValid = functorSpecWithInts @f genValid
functorSpec ::
forall (f :: * -> *).
(Eq (f Int), Show (f Int), Functor f, Typeable f, GenUnchecked (f Int))
=> Spec
functorSpec = functorSpecWithInts @f genUnchecked
functorSpecOnArbitrary ::
forall (f :: * -> *).
(Eq (f Int), Show (f Int), Functor f, Typeable f, Arbitrary (f Int))
=> Spec
functorSpecOnArbitrary = functorSpecWithInts @f arbitrary
functorSpecWithInts ::
forall (f :: * -> *). (Eq (f Int), Show (f Int), Functor f, Typeable f)
=> Gen (f Int)
-> Spec
functorSpecWithInts gen =
functorSpecOnGens
@f
@Int
genUnchecked
"int"
gen
(unwords [nameOf @f, "of ints"])
((+) <$> genUnchecked)
"increments"
((*) <$> genUnchecked)
"scalings"
functorSpecOnGens ::
forall (f :: * -> *) (a :: *) (b :: *) (c :: *).
( Show a
, Show (f a)
, Show (f c)
, Eq (f a)
, Eq (f c)
, Functor f
, Typeable f
, Typeable a
, Typeable b
, Typeable c
)
=> Gen a
-> String
-> Gen (f a)
-> String
-> Gen (b -> c)
-> String
-> Gen (a -> b)
-> String
-> Spec
functorSpecOnGens gena genaname gen genname genf genfname geng gengname =
parallel $
describe ("Functor " ++ nameOf @f) $ do
describe (fmapTypeStr @f) $ do
it
(unwords
[ "satisfies the first Fuctor law: 'fmap id == id' for"
, genDescr @(f a) genname
]) $
equivalentOnGen (fmap @f id) (id @(f a)) gen shrinkNothing
it
(unwords
[ "satisfieds the second Functor law: 'fmap (f . g) == fmap f . fmap g' for"
, genDescr @(f a) genname
, "'s"
, "given to"
, genDescr @(b -> c) genfname
, "and"
, genDescr @(a -> b) gengname
]) $
forAll (Anon <$> genf) $ \(Anon f) ->
forAll (Anon <$> geng) $ \(Anon g) ->
equivalentOnGen
(fmap (f . g))
(fmap f . fmap g)
gen
shrinkNothing
describe (flTypeStr @f) $
it
(unwords
[ "is equivalent to its default implementation for"
, genDescr @a genaname
, "and"
, genDescr @(f a) genname
]) $
forAll gena $ \a ->
equivalentOnGen (a <$) (fmap $ const a) gen shrinkNothing