{-# LANGUAGE ScopedTypeVariables #-}

module Hedgehog.Classes.Semigroup
  ( semigroupLaws
  , commutativeSemigroupLaws
  , exponentialSemigroupLaws
  , idempotentSemigroupLaws
  , rectangularBandSemigroupLaws
  ) where

import Data.Semigroup (Semigroup(..))
import Hedgehog
import Hedgehog.Classes.Common
import Data.List.NonEmpty
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import qualified Data.Foldable as Foldable

-- | Tests the following 'Semigroup' laws:
--
-- [__Associativity__]: @a '<>' (b '<>' c)@ ≡ @(a '<>' b) '<>' c@
-- [__Concatenation__]: @'sconcat'@ ≡ @'Foldable.foldr1' ('<>')@
-- [__Times__]: @'stimes' n a@ ≡ @'foldr1' ('<>') ('replicate' n a)@
semigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws
semigroupLaws :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Laws
semigroupLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Semigroup"
  [ (String
"Associativity", forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupAssociative Gen a
gen)
  , (String
"Concatenation", forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupConcatenation Gen a
gen)
  , (String
"Times", forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupTimes Gen a
gen)
  ]

-- | Tests the following 'Semigroup' laws:
--
-- [__Commutativity__]: @a '<>' b@ ≡ @b '<>' a@
commutativeSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws
commutativeSemigroupLaws :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Laws
commutativeSemigroupLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Commutative Semigroup"
  [ (String
"Commutative", forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupCommutative Gen a
gen)
  ]

-- | Tests the following 'Semigroup' laws:
--
-- [__Exponentiality__]: @'stimes' n (a '<>' b)@ ≡ @'stimes' n a '<>' 'stimes' n b@
exponentialSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws
exponentialSemigroupLaws :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Laws
exponentialSemigroupLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Exponential Semigroup"
  [ (String
"Exponential", forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupExponential Gen a
gen)
  ]

-- | Tests the following 'Semigroup' laws:
--
-- [__Idempotency__]: @a '<>' a@ ≡ @a@
idempotentSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws
idempotentSemigroupLaws :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Laws
idempotentSemigroupLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Idempotent Semigroup"
  [ (String
"Idempotent", forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupIdempotent Gen a
gen)
  ]

-- | Tests the following 'Semigroup' laws:
--
-- [__Rectangular Bandedness__]: @a '<>' b '<>' a@ ≡ @a@
rectangularBandSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws
rectangularBandSemigroupLaws :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Laws
rectangularBandSemigroupLaws Gen a
gen = String -> [(String, Property)] -> Laws
Laws String
"Rectangular Band Semigroup"
  [ (String
"Rectangular Band", forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupRectangularBand Gen a
gen)
  ]

semigroupAssociative :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupAssociative :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupAssociative 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 = a
a forall a. Semigroup a => a -> a -> a
<> (a
b forall a. Semigroup a => a -> a -> a
<> a
c)
  let rhs :: a
rhs = (a
a forall a. Semigroup a => a -> a -> a
<> a
b) forall a. Semigroup a => a -> a -> a
<> 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
"Semigroup"
        , lawContextLawBody :: String
lawContextLawBody = String
"a <> (b <> c)" String -> String -> String
`congruency` String
"(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
"a <> (b <> c)" String -> String -> String
`congruency` String
"(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

semigroupCommutative :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupCommutative :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupCommutative 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 = a
a forall a. Semigroup a => a -> a -> a
<> a
b
  let rhs :: a
rhs = a
b forall a. Semigroup a => a -> a -> a
<> 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
"Semigroup"
        , lawContextLawBody :: String
lawContextLawBody = String
"a <> b" String -> String -> String
`congruency` String
"b <> a"
        , 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
"a <> b" String -> String -> String
`congruency` String
"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

semigroupConcatenation :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupConcatenation :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupConcatenation 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]
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 ne :: NonEmpty a
ne = a
a forall a. a -> [a] -> NonEmpty a
:| [a]
as
  let lhs :: a
lhs = forall a. Semigroup a => NonEmpty a -> a
sconcat NonEmpty a
ne
  let rhs :: a
rhs = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
Foldable.foldr1 forall a. Semigroup a => a -> a -> a
(<>) NonEmpty a
ne
  let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Concatenation", lawContextTcName :: String
lawContextTcName = String
"Semigroup"
        , lawContextLawBody :: String
lawContextLawBody = String
"sconcat" String -> String -> String
`congruency` String
"foldr1 (<>)"
        , lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
        , lawContextTcProp :: String
lawContextTcProp =
            let showNE :: String
showNE = forall a. Show a => a -> String
show NonEmpty a
ne;
            in [String] -> String
lawWhere
              [ String
"sconcat ne" String -> String -> String
`congruency` String
"foldr1 (<>) ne, where"
              , String
"ne = " forall a. [a] -> [a] -> [a]
++ String
showNE
              ]
        }
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx  

semigroupTimes :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupTimes :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupTimes 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
  Int
n <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (forall a. Integral a => a -> a -> Range a
Range.linear Int
2 Int
5))
  let lhs :: a
lhs = forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Int
n a
a
  let rhs :: a
rhs = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
Foldable.foldr1 forall a. Semigroup a => a -> a -> a
(<>) (forall a. Int -> a -> [a]
replicate Int
n a
a)
  let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Times", lawContextTcName :: String
lawContextTcName = String
"Semigroup"
        , lawContextLawBody :: String
lawContextLawBody = String
"stimes n a" String -> String -> String
`congruency` String
"foldr1 (<>) (replicate n a)"
        , lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
        , lawContextTcProp :: String
lawContextTcProp =
            let showN :: String
showN = forall a. Show a => a -> String
show Int
n; showA :: String
showA = forall a. Show a => a -> String
show a
a;
            in [String] -> String
lawWhere
              [ String
"stimes n a" String -> String -> String
`congruency` String
"foldr1 (<>) (replicate n a), where"
              , String
"a = " forall a. [a] -> [a] -> [a]
++ String
showA
              , String
"n = " forall a. [a] -> [a] -> [a]
++ String
showN
              ]
        }  
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx

semigroupExponential :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupExponential :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupExponential 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
  Int
n <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (forall a. Integral a => a -> a -> Range a
Range.linear Int
2 Int
5))
  let lhs :: a
lhs = forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Int
n (a
a forall a. Semigroup a => a -> a -> a
<> a
b)
  let rhs :: a
rhs = forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Int
n a
a forall a. Semigroup a => a -> a -> a
<> forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Int
n a
b
  let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Exponential", lawContextTcName :: String
lawContextTcName = String
"Semigroup"
        , lawContextLawBody :: String
lawContextLawBody = String
"stimes n (a <> b)" String -> String -> String
`congruency` String
"stimes n a <> stimes n b"
        , lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced a
lhs a
rhs
        , lawContextTcProp :: String
lawContextTcProp =
            let showN :: String
showN = forall a. Show a => a -> String
show Int
n; 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
"stimes n (a <> b)" String -> String -> String
`congruency` String
"stimes n a <> stimes n b, where"
              , String
"a = " forall a. [a] -> [a] -> [a]
++ String
showA
              , String
"b = " forall a. [a] -> [a] -> [a]
++ String
showB
              , String
"n = " forall a. [a] -> [a] -> [a]
++ String
showN
              ]
        }  
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx

semigroupIdempotent :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupIdempotent :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupIdempotent 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 = a
a forall a. Semigroup a => a -> a -> a
<> 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
"Idempotency", lawContextTcName :: String
lawContextTcName = String
"Semigroup"
        , lawContextLawBody :: String
lawContextLawBody = String
"a <> a" String -> String -> String
`congruency` String
"a"
        , 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;
            in [String] -> String
lawWhere
              [ String
"a <> a" String -> String -> String
`congruency` String
"a, where"
              , String
"a = " forall a. [a] -> [a] -> [a]
++ String
showA
              ]
        }
  forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx a
lhs a
rhs Context
ctx

semigroupRectangularBand :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupRectangularBand :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property
semigroupRectangularBand 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 = a
a forall a. Semigroup a => a -> a -> a
<> a
b forall a. Semigroup a => a -> a -> a
<> 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
"Rectangular Band", lawContextTcName :: String
lawContextTcName = String
"Semigroup"
        , lawContextLawBody :: String
lawContextLawBody = String
"a <> b <> a" String -> String -> String
`congruency` String
"a"
        , 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
"a <> b <> a" String -> String -> String
`congruency` String
"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