{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Test.Validity.Monad
( monadSpecOnValid
, monadSpec
, monadSpecOnArbitrary
, monadSpecOnGens
) where
import Data.Data
import Control.Monad (ap)
import Data.GenValidity
import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Random (mkQCGen)
import Test.Hspec
import Test.QuickCheck
import Test.Validity.Functions
import Test.Validity.Utils
{-# ANN module "HLint: ignore Use fmap" #-}
{-# ANN module "HLint: ignore Use <$>" #-}
{-# ANN module "HLint: ignore Use >=>" #-}
{-# ANN module "HLint: ignore Use id" #-}
{-# ANN module "HLint: ignore Monad law, left identity" #-}
{-# ANN module "HLint: ignore Monad law, right identity" #-}
{-# ANN module "HLint: ignore Avoid lambda" #-}
{-# ANN module "HLint: ignore Reduce duplication" #-}
returnTypeStr ::
forall (m :: * -> *). (Typeable m)
=> String
returnTypeStr = unwords ["return", "::", "a", "->", nameOf @m, "a"]
bindTypeStr ::
forall (m :: * -> *). (Typeable m)
=> String
bindTypeStr =
unwords
[ "(>>=)"
, "::"
, nameOf @m
, "a"
, "->"
, "(b"
, "->"
, nameOf @m
, "a)"
, "->"
, nameOf @m
, "b"
]
monadSpecOnValid ::
forall (f :: * -> *).
(Eq (f Int), Show (f Int), Monad f, Typeable f, GenValid (f Int))
=> Spec
monadSpecOnValid = monadSpecWithInts @f genValid
monadSpec ::
forall (f :: * -> *).
(Eq (f Int), Show (f Int), Monad f, Typeable f, GenUnchecked (f Int))
=> Spec
monadSpec = monadSpecWithInts @f genUnchecked
monadSpecOnArbitrary ::
forall (f :: * -> *).
(Eq (f Int), Show (f Int), Monad f, Typeable f, Arbitrary (f Int))
=> Spec
monadSpecOnArbitrary = monadSpecWithInts @f arbitrary
monadSpecWithInts ::
forall (f :: * -> *). (Eq (f Int), Show (f Int), Monad f, Typeable f)
=> Gen (f Int)
-> Spec
monadSpecWithInts gen =
monadSpecOnGens
@f
@Int
genUnchecked
"int"
gen
(unwords [nameOf @f, "of ints"])
gen
(unwords [nameOf @f, "of ints"])
((+) <$> genUnchecked)
"increments"
(do a <- genUnchecked
let qcgen = mkQCGen a
let func = unGen gen qcgen
pure $ \b -> func b)
"perturbations using the int"
(do a <- genUnchecked
let qcgen = mkQCGen a
let func = unGen gen qcgen
pure $ \b -> func (2 * b))
"perturbations using the double the int"
(pure <$> ((+) <$> genUnchecked))
(unwords [nameOf @f, "of additions"])
monadSpecOnGens ::
forall (f :: * -> *) (a :: *) (b :: *) (c :: *).
( Show a
, Eq a
, Show (f a)
, Show (f b)
, Show (f c)
, Eq (f a)
, Eq (f b)
, Eq (f c)
, Monad f
, Typeable f
, Typeable a
, Typeable b
, Typeable c
)
=> Gen a
-> String
-> Gen (f a)
-> String
-> Gen (f b)
-> String
-> Gen (a -> b)
-> String
-> Gen (a -> f b)
-> String
-> Gen (b -> f c)
-> String
-> Gen (f (a -> b))
-> String
-> Spec
monadSpecOnGens gena genaname gen genname genb genbname geng gengname genbf genbfname gencf gencfname genfab genfabname =
parallel $
describe ("Monad " ++ nameOf @f) $ do
describe (unwords [returnTypeStr @f, "and", bindTypeStr @f]) $ do
it
(unwords
[ "satisfy the first Monad law: 'return a >>= k = k a' for"
, genDescr @a genaname
, "and"
, genDescr @(a -> f b) genbfname
]) $
equivalentOnGens2
(\a (Anon k) -> return a >>= k)
(\a (Anon k) -> k a)
((,) <$> gena <*> (Anon <$> genbf))
shrinkNothing
it
(unwords
[ "satisfy the second Monad law: 'm >>= return = m' for"
, genDescr @(f a) genname
]) $
equivalentOnGen (\m -> m >>= return) (\m -> m) gen shrinkNothing
describe (bindTypeStr @f) $
it
(unwords
[ "satisfies the third Monad law: 'm >>= (x -> k x >>= h) = (m >>= k) >>= h' for"
, genDescr @(f a) genname
, genDescr @(a -> f b) genbfname
, "and"
, genDescr @(b -> f c) gencfname
]) $
equivalentOnGens3
(\m (Anon k) (Anon h) -> m >>= (\x -> k x >>= h))
(\m (Anon k) (Anon h) -> (m >>= k) >>= h)
((,,) <$> gen <*> (Anon <$> genbf) <*> (Anon <$> gencf))
shrinkNothing
describe (unwords ["relation with Applicative", nameOf @f]) $ do
it
(unwords
["satisfies 'pure = return' for", genDescr @(f a) genname]) $
equivalentOnGen (pure @f) (return @f) gena shrinkNothing
it
(unwords
[ "satisfies '(<*>) = ap' for"
, genDescr @(f (a -> b)) genfabname
, "and"
, genDescr @(f a) genname
]) $
equivalentOnGens2
(\(Anon a) b -> a <*> b)
(\(Anon a) b -> ap a b)
((,) <$> (Anon <$> genfab) <*> gen)
shrinkNothing
it
(unwords
[ "satisfies '(>>) = (*>)' for"
, genDescr @(f a) genname
, "and"
, genDescr @(f b) genbname
]) $
equivalentOnGens2 (>>) (*>) ((,) <$> gen <*> genb) shrinkNothing
describe (unwords ["relation with Functor", nameOf @f]) $
it
(unwords
[ "satisfies 'fmap f xs = xs >>= return . f' for"
, genDescr @(a -> b) gengname
, "and"
, genDescr @(f a) genname
]) $
equivalentOnGens2
(\(Anon f) xs -> fmap f xs)
(\(Anon f) xs -> xs >>= (return . f))
((,) <$> (Anon <$> geng) <*> gen)
shrinkNothing