{-# LANGUAGE ScopedTypeVariables #-}

module Hedgehog.Classes.Monoid (monoidLaws, commutativeMonoidLaws) where

import Hedgehog
import Hedgehog.Classes.Common

-- | Tests the following 'Monoid' laws:
--
-- [__Left Identity__]: @'mappend' 'mempty'@ ≡ @'id'@
-- [__Right Identity__]: @'flip' 'mappend' 'mempty'@ ≡ @'id'@
-- [__Associativity__]: @'mappend' a ('mappend' b c)@ ≡ @'mappend' ('mappend' a b) c@
-- [__Concatenation__]: @'mconcat'@ ≡ @'foldr' 'mappend' 'mempty'@
monoidLaws :: (Eq a, Monoid a, Show a) => Gen a -> Laws
monoidLaws :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Laws
monoidLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Monoid"
  [ (String
"Left Identity", forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidLeftIdentity Gen a
gen)
  , (String
"Right Identity", forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidRightIdentity Gen a
gen)
  , (String
"Associativity", forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidAssociative Gen a
gen)
  , (String
"Concatenation", forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidConcatenation Gen a
gen)
  ]

-- | Tests the following 'Monoid' laws:
--
-- [__Commutativity__]: @'mappend' a b@ ≡ @'mappend' b a@
commutativeMonoidLaws :: (Eq a, Monoid a, Show a) => Gen a -> Laws
commutativeMonoidLaws :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Laws
commutativeMonoidLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Commutative Monoid"
  [ (String
"Commutativity", forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidCommutative Gen a
gen)
  ]

monoidConcatenation :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidConcatenation :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidConcatenation Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  [a]
as <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall a. Gen a -> Gen [a]
genSmallList Gen a
gen
  let lhs :: a
lhs = forall a. Monoid a => [a] -> a
mconcat [a]
as
  let rhs :: a
rhs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Monoid a => a -> a -> a
mappend forall a. Monoid a => a
mempty [a]
as
  let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Concatenation", lawContextTcName :: String
lawContextTcName = String
"Monoid"
        , lawContextLawBody :: String
lawContextLawBody = String
"mconcat" String -> String -> String
`congruency` String
"foldr mappend mempty"
        , lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
        , lawContextTcProp :: String
lawContextTcProp =
            let showAS :: String
showAS = forall a. Show a => a -> String
show [a]
as; showMempty :: String
showMempty = forall a. Show a => a -> String
show (forall a. Monoid a => a
mempty :: a);
            in [String] -> String
lawWhere
              [ String
"mconcat as" String -> String -> String
`congruency` String
"foldr mappend mempty as, where"
              , String
"as = " forall a. [a] -> [a] -> [a]
++ String
showAS
              , String
"mempty = " forall a. [a] -> [a] -> [a]
++ String
showMempty
              ]
        }  
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx

monoidAssociative :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidAssociative :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidAssociative Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  a
a <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  a
b <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  a
c <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  let lhs :: a
lhs = forall a. Monoid a => a -> a -> a
mappend a
a (forall a. Monoid a => a -> a -> a
mappend a
b a
c)
  let rhs :: a
rhs = forall a. Monoid a => a -> a -> a
mappend (forall a. Monoid a => a -> a -> a
mappend a
a a
b) a
c
  let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Associativity", lawContextTcName :: String
lawContextTcName = String
"Monoid"
        , lawContextLawBody :: String
lawContextLawBody = String
"mappend a (mappend b c)" String -> String -> String
`congruency` String
"mappend (mappend a b) c"
        , lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
        , lawContextTcProp :: String
lawContextTcProp =
            let showA :: String
showA = forall a. Show a => a -> String
show a
a; showB :: String
showB = forall a. Show a => a -> String
show a
b; showC :: String
showC = forall a. Show a => a -> String
show a
c;
            in [String] -> String
lawWhere
              [ String
"mappend a (mappend b c)" String -> String -> String
`congruency` String
"mappend (mappend a b) c, where"
              , String
"a = " forall a. [a] -> [a] -> [a]
++ String
showA
              , String
"b = " forall a. [a] -> [a] -> [a]
++ String
showB
              , String
"c = " forall a. [a] -> [a] -> [a]
++ String
showC
              ]
        }
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx

monoidLeftIdentity :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidLeftIdentity :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidLeftIdentity Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  a
a <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  let lhs :: a
lhs = forall a. Monoid a => a -> a -> a
mappend forall a. Monoid a => a
mempty a
a
  let rhs :: a
rhs = a
a
  let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Left Identity", lawContextTcName :: String
lawContextTcName = String
"Monoid"
        , lawContextLawBody :: String
lawContextLawBody = String
"mappend mempty" String -> String -> String
`congruency` String
"id"
        , lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
        , lawContextTcProp :: String
lawContextTcProp =
            let showA :: String
showA = forall a. Show a => a -> String
show a
a; showMempty :: String
showMempty = forall a. Show a => a -> String
show (forall a. Monoid a => a
mempty :: a);
            in [String] -> String
lawWhere
              [ String
"mappend mempty a" String -> String -> String
`congruency` String
"a, where"
              , String
"a = " forall a. [a] -> [a] -> [a]
++ String
showA
              , String
"mempty = " forall a. [a] -> [a] -> [a]
++ String
showMempty
              ]
        }
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx

monoidRightIdentity :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidRightIdentity :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidRightIdentity Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  a
a <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  let lhs :: a
lhs = forall a. Monoid a => a -> a -> a
mappend a
a forall a. Monoid a => a
mempty
  let rhs :: a
rhs = a
a 
  let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Right Identity", lawContextTcName :: String
lawContextTcName = String
"Monoid"
        , lawContextLawBody :: String
lawContextLawBody = String
"flip mappend mempty" String -> String -> String
`congruency` String
"id"
        , lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
        , lawContextTcProp :: String
lawContextTcProp =
            let showA :: String
showA = forall a. Show a => a -> String
show a
a; showMempty :: String
showMempty = forall a. Show a => a -> String
show (forall a. Monoid a => a
mempty :: a);
            in [String] -> String
lawWhere
              [ String
"mappend a mempty" String -> String -> String
`congruency` String
"a, where"
              , String
"a = " forall a. [a] -> [a] -> [a]
++ String
showA
              , String
"mempty = " forall a. [a] -> [a] -> [a]
++ String
showMempty
              ]
        }
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx 

monoidCommutative :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidCommutative :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property
monoidCommutative Gen a
gen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  a
a <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  a
b <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen a
gen
  let lhs :: a
lhs = forall a. Monoid a => a -> a -> a
mappend a
a a
b
  let rhs :: a
rhs = forall a. Monoid a => a -> a -> a
mappend a
b a
a
  let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Commutativity", lawContextTcName :: String
lawContextTcName = String
"Monoid (Commutative)"
        , lawContextLawBody :: String
lawContextLawBody = String
"mappend" String -> String -> String
`congruency` String
"flip mappend"
        , lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
        , lawContextTcProp :: String
lawContextTcProp =
            let showA :: String
showA = forall a. Show a => a -> String
show a
a; showB :: String
showB = forall a. Show a => a -> String
show a
b;
            in [String] -> String
lawWhere
              [ String
"mappend a b" String -> String -> String
`congruency` String
"mappend b a, where"
              , String
"a = " forall a. [a] -> [a] -> [a]
++ String
showA
              , String
"b = " forall a. [a] -> [a] -> [a]
++ String
showB
              ]
        }
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx