{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes            #-}

module Hedgehog.Classes.Alternative (alternativeLaws) where

import Control.Applicative (Alternative(..))

import Hedgehog
import Hedgehog.Classes.Common

-- | Tests the following 'Alternative' laws:
-- 
-- [__Left Identity__]: @'empty' '<|>' a@ ≡ @a@
-- [__Right Identity__]: @a '<|>' 'empty'@ ≡ @a@
-- [__Associativity__]: @a '<|>' (b '<|>' c)@ ≡ @(a '<|>' b) '<|>' c@
alternativeLaws ::
  ( Alternative f
  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
  ) => (forall x. Gen x -> Gen (f x)) -> Laws
alternativeLaws :: (forall x. Gen x -> Gen (f x)) -> Laws
alternativeLaws forall x. Gen x -> Gen (f x)
gen = String -> [(String, Property)] -> Laws
Laws String
"Alternative"
  [ (String
"Left Identity", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). AlternativeProp f
alternativeLeftIdentity forall x. Gen x -> Gen (f x)
gen)
  , (String
"Right Identity", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). AlternativeProp f
alternativeRightIdentity forall x. Gen x -> Gen (f x)
gen)
  , (String
"Associativity", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). AlternativeProp f
alternativeAssociativity forall x. Gen x -> Gen (f x)
gen)
  ]

type AlternativeProp f =
  ( Alternative f
  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
  ) => (forall x. Gen x -> Gen (f x)) -> Property

alternativeLeftIdentity :: forall f. AlternativeProp f
alternativeLeftIdentity :: (forall x. Gen x -> Gen (f x)) -> Property
alternativeLeftIdentity forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  f Integer
a <- Gen (f Integer) -> PropertyT IO (f Integer)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (f Integer) -> PropertyT IO (f Integer))
-> Gen (f Integer) -> PropertyT IO (f Integer)
forall a b. (a -> b) -> a -> b
$ Gen Integer -> Gen (f Integer)
forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  let lhs :: f Integer
lhs = f Integer
forall (f :: * -> *) a. Alternative f => f a
empty f Integer -> f Integer -> f Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f Integer
a
  let rhs :: f Integer
rhs = f Integer
a
  let ctx :: Context
ctx = LawContext -> Context
contextualise (LawContext -> Context) -> LawContext -> Context
forall a b. (a -> b) -> a -> b
$ LawContext :: String -> String -> String -> String -> String -> LawContext
LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Left Identity", lawContextLawBody :: String
lawContextLawBody = String
"empty <|> a" String -> String -> String
`congruency` String
"a"
        , lawContextTcName :: String
lawContextTcName = String
"Alternative", lawContextTcProp :: String
lawContextTcProp =
            let showA :: String
showA = f Integer -> String
forall a. Show a => a -> String
show f Integer
a;
            in [String] -> String
lawWhere
              [ String
"empty <|> a" String -> String -> String
`congruency` String
"a, where"
              , String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showA
              ]
        , lawContextReduced :: String
lawContextReduced = f Integer -> f Integer -> String
forall a. Show a => a -> a -> String
reduced f Integer
lhs f Integer
rhs
        }
  f Integer -> f Integer -> Context -> PropertyT IO ()
forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Eq a, Show a,
 forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) =>
f a -> f a -> Context -> m ()
heqCtx1 f Integer
lhs f Integer
rhs Context
ctx

alternativeRightIdentity :: forall f. AlternativeProp f
alternativeRightIdentity :: (forall x. Gen x -> Gen (f x)) -> Property
alternativeRightIdentity forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  f Integer
a <- Gen (f Integer) -> PropertyT IO (f Integer)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (f Integer) -> PropertyT IO (f Integer))
-> Gen (f Integer) -> PropertyT IO (f Integer)
forall a b. (a -> b) -> a -> b
$ Gen Integer -> Gen (f Integer)
forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  let lhs :: f Integer
lhs = f Integer
a f Integer -> f Integer -> f Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f Integer
forall (f :: * -> *) a. Alternative f => f a
empty
  let rhs :: f Integer
rhs = f Integer
a
  let ctx :: Context
ctx = LawContext -> Context
contextualise (LawContext -> Context) -> LawContext -> Context
forall a b. (a -> b) -> a -> b
$ LawContext :: String -> String -> String -> String -> String -> LawContext
LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Right Identity", lawContextLawBody :: String
lawContextLawBody = String
"a <|> empty" String -> String -> String
`congruency` String
"a"
        , lawContextTcName :: String
lawContextTcName = String
"Alternative", lawContextTcProp :: String
lawContextTcProp =
            let showA :: String
showA = f Integer -> String
forall a. Show a => a -> String
show f Integer
a;
            in [String] -> String
lawWhere
              [ String
"a <|> empty" String -> String -> String
`congruency` String
"a, where"
              , String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showA
              ]
        , lawContextReduced :: String
lawContextReduced = f Integer -> f Integer -> String
forall a. Show a => a -> a -> String
reduced f Integer
lhs f Integer
rhs
        }
  f Integer -> f Integer -> Context -> PropertyT IO ()
forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Eq a, Show a,
 forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) =>
f a -> f a -> Context -> m ()
heqCtx1 f Integer
lhs f Integer
rhs Context
ctx  

alternativeAssociativity :: forall f. AlternativeProp f
alternativeAssociativity :: (forall x. Gen x -> Gen (f x)) -> Property
alternativeAssociativity forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  f Integer
a <- Gen (f Integer) -> PropertyT IO (f Integer)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (f Integer) -> PropertyT IO (f Integer))
-> Gen (f Integer) -> PropertyT IO (f Integer)
forall a b. (a -> b) -> a -> b
$ Gen Integer -> Gen (f Integer)
forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  f Integer
b <- Gen (f Integer) -> PropertyT IO (f Integer)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (f Integer) -> PropertyT IO (f Integer))
-> Gen (f Integer) -> PropertyT IO (f Integer)
forall a b. (a -> b) -> a -> b
$ Gen Integer -> Gen (f Integer)
forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  f Integer
c <- Gen (f Integer) -> PropertyT IO (f Integer)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (f Integer) -> PropertyT IO (f Integer))
-> Gen (f Integer) -> PropertyT IO (f Integer)
forall a b. (a -> b) -> a -> b
$ Gen Integer -> Gen (f Integer)
forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  let lhs :: f Integer
lhs = (f Integer
a f Integer -> f Integer -> f Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (f Integer
b f Integer -> f Integer -> f Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f Integer
c))
  let rhs :: f Integer
rhs = ((f Integer
a f Integer -> f Integer -> f Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f Integer
b) f Integer -> f Integer -> f Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f Integer
c)
  let ctx :: Context
ctx = LawContext -> Context
contextualise (LawContext -> Context) -> LawContext -> Context
forall a b. (a -> b) -> a -> b
$ LawContext :: String -> String -> String -> String -> String -> LawContext
LawContext
        { lawContextLawName :: String
lawContextLawName = String
"Associativity", lawContextLawBody :: String
lawContextLawBody = String
"a <|> (b <|> c)" String -> String -> String
`congruency` String
"(a <|> b) <|> c"
        , lawContextTcName :: String
lawContextTcName = String
"Alternative", lawContextTcProp :: String
lawContextTcProp =
            let showA :: String
showA = f Integer -> String
forall a. Show a => a -> String
show f Integer
a; showB :: String
showB = f Integer -> String
forall a. Show a => a -> String
show f Integer
b; showC :: String
showC = f Integer -> String
forall a. Show a => a -> String
show f Integer
c;
            in [String] -> String
lawWhere
                 [ String
"a <|> (b <|> c)" String -> String -> String
`congruency` String
"(a <|> b) <|> c), where"
                 , String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showA
                 , String
"b = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showB
                 , String
"c = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showC
                 ]
        , lawContextReduced :: String
lawContextReduced = f Integer -> f Integer -> String
forall a. Show a => a -> a -> String
reduced f Integer
lhs f Integer
rhs
        }
  f Integer -> f Integer -> Context -> PropertyT IO ()
forall (m :: * -> *) a (f :: * -> *).
(MonadTest m, HasCallStack, Eq a, Show a,
 forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)) =>
f a -> f a -> Context -> m ()
heqCtx1 f Integer
lhs f Integer
rhs Context
ctx