{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Test.Validity.Monoid
( monoidSpecOnValid
, monoidSpec
, monoidSpecOnArbitrary
, monoidSpecOnGen
) where
import Data.Data
import Data.GenValidity
import Test.Hspec
import Test.QuickCheck
import Test.Validity.Functions
import Test.Validity.Operations
import Test.Validity.Utils
memptyTypeStr ::
forall a. Typeable a
=> String
memptyTypeStr = unwords ["mempty", "::", nameOf @a]
mappendTypeStr ::
forall a. Typeable a
=> String
mappendTypeStr = unwords ["mappend", "::", an, "->", an, "->", an]
where
an = nameOf @a
mconcatTypeStr ::
forall a. Typeable a
=> String
mconcatTypeStr = unwords ["mconcat", "::", "[" ++ an ++ "]", "->", an]
where
an = nameOf @a
monoidSpecOnValid ::
forall a. (Show a, Eq a, Monoid a, Typeable a, GenValid a)
=> Spec
monoidSpecOnValid = monoidSpecOnGen @a genValid "valid" shrinkValid
monoidSpec ::
forall a. (Show a, Eq a, Monoid a, Typeable a, GenUnchecked a)
=> Spec
monoidSpec = monoidSpecOnGen @a genUnchecked "unchecked" shrinkUnchecked
monoidSpecOnArbitrary ::
forall a. (Show a, Eq a, Monoid a, Typeable a, Arbitrary a)
=> Spec
monoidSpecOnArbitrary = monoidSpecOnGen @a arbitrary "arbitrary" shrink
monoidSpecOnGen ::
forall a. (Show a, Eq a, Monoid a, Typeable a)
=> Gen a
-> String
-> (a -> [a])
-> Spec
monoidSpecOnGen gen genname s =
parallel $ do
let name = nameOf @a
memptystr = memptyTypeStr @a
mappendstr = mappendTypeStr @a
mconcatstr = mconcatTypeStr @a
gen3 = (,,) <$> gen <*> gen <*> gen
s3 (a, b, c) = (,,) <$> s a <*> s b <*> s c
genl = genListOf gen
sl = shrinkList s
describe ("Monoid " ++ name) $ do
let mem = mempty @a
mapp = mappend @a
mcon = mconcat @a
describe memptystr $
it
(unwords
[ "is the identity for"
, mappendstr
, "for"
, genDescr @a genname
]) $
identityOnGen mapp mem gen s
describe mappendstr $
it
(unwords
[ "is an associative operation for"
, genDescr @(a, a, a) genname
]) $
associativeOnGens mapp gen3 s3
describe mconcatstr $
it
(unwords
[ "is equivalent to its default implementation for"
, genDescr @[a] genname
]) $
equivalentOnGen mcon (foldr mapp mem) genl sl