{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE QuantifiedConstraints #-}
module Hedgehog.Classes.Bifoldable (bifoldableLaws, bifoldableFunctorLaws) where
import Hedgehog
import Hedgehog.Classes.Common
import Data.Bifoldable (Bifoldable(..))
import Data.Bifunctor (Bifunctor(..))
import Data.Monoid (Endo(..), Sum(..), Product(..))
bifoldableLaws :: forall f.
( Bifoldable f
, forall x y. (Eq x, Eq y) => Eq (f x y)
, forall x y. (Show x, Show y) => Show (f x y)
) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws
bifoldableLaws :: forall (f :: * -> * -> *).
(Bifoldable f, forall x y. (Eq x, Eq y) => Eq (f x y),
forall x y. (Show x, Show y) => Show (f x y)) =>
(forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws
bifoldableLaws forall x y. Gen x -> Gen y -> Gen (f x y)
gen = String -> [(String, Property)] -> Laws
Laws String
"Bifoldable"
[ (String
"Identity", forall (f :: * -> * -> *). BifoldableProp f
bifoldableIdentity forall x y. Gen x -> Gen y -> Gen (f x y)
gen)
, (String
"FoldMap", forall (f :: * -> * -> *). BifoldableProp f
bifoldableFoldMap forall x y. Gen x -> Gen y -> Gen (f x y)
gen)
, (String
"Foldr", forall (f :: * -> * -> *). BifoldableProp f
bifoldableFoldr forall x y. Gen x -> Gen y -> Gen (f x y)
gen)
]
bifoldableFunctorLaws :: forall f.
( Bifoldable f, Bifunctor f
, forall x y. (Eq x, Eq y) => Eq (f x y)
, forall x y. (Show x, Show y) => Show (f x y)
) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws
bifoldableFunctorLaws :: forall (f :: * -> * -> *).
(Bifoldable f, Bifunctor f, forall x y. (Eq x, Eq y) => Eq (f x y),
forall x y. (Show x, Show y) => Show (f x y)) =>
(forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws
bifoldableFunctorLaws forall x y. Gen x -> Gen y -> Gen (f x y)
gen = String -> [(String, Property)] -> Laws
Laws String
"Bifoldable/Bifunctor"
[ (String
"Composition", forall (f :: * -> * -> *). BifoldableFunctorProp f
bifoldableFunctorComposition forall x y. Gen x -> Gen y -> Gen (f x y)
gen)
, (String
"FoldMap", forall (f :: * -> * -> *). BifoldableFunctorProp f
bifoldableFunctorFoldMap forall x y. Gen x -> Gen y -> Gen (f x y)
gen)
]
type BifoldableProp f =
( Bifoldable f
, forall x y. (Eq x, Eq y) => Eq (f x y)
, forall x y. (Show x, Show y) => Show (f x y)
) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property
bifoldableIdentity :: forall f. BifoldableProp f
bifoldableIdentity :: forall (f :: * -> * -> *). BifoldableProp f
bifoldableIdentity forall x y. Gen x -> Gen y -> Gen (f x y)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
f (Sum Integer) (Sum Integer)
x <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x y. Gen x -> Gen y -> Gen (f x y)
fgen Gen (Sum Integer)
genSmallSum Gen (Sum Integer)
genSmallSum
let lhs :: Sum Integer
lhs = forall (p :: * -> * -> *) m. (Bifoldable p, Monoid m) => p m m -> m
bifold f (Sum Integer) (Sum Integer)
x
let rhs :: Sum Integer
rhs = forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap forall a. a -> a
id forall a. a -> a
id f (Sum Integer) (Sum Integer)
x
let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
{ lawContextLawName :: String
lawContextLawName = String
"Identity", lawContextLawBody :: String
lawContextLawBody = String
"bifold" String -> String -> String
`congruency` String
"bifoldMap id id"
, lawContextTcName :: String
lawContextTcName = String
"Bifoldable", lawContextTcProp :: String
lawContextTcProp =
let showX :: String
showX = forall a. Show a => a -> String
show f (Sum Integer) (Sum Integer)
x;
in [String] -> String
lawWhere
[ String
"bimap id id x" String -> String -> String
`congruency` String
"x, where"
, String
"x = " forall a. [a] -> [a] -> [a]
++ String
showX
]
, lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced Sum Integer
lhs Sum Integer
rhs
}
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx Sum Integer
lhs Sum Integer
rhs Context
ctx
bifoldableFoldMap :: forall f. BifoldableProp f
bifoldableFoldMap :: forall (f :: * -> * -> *). BifoldableProp f
bifoldableFoldMap forall x y. Gen x -> Gen y -> Gen (f x y)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
f Integer Integer
x <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x y. Gen x -> Gen y -> Gen (f x y)
fgen Gen Integer
genSmallInteger Gen Integer
genSmallInteger
QuadraticEquation
f' <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen QuadraticEquation
genQuadraticEquation
QuadraticEquation
g' <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen QuadraticEquation
genQuadraticEquation
let f :: Integer -> Sum Integer
f = forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuadraticEquation -> Integer -> Integer
runQuadraticEquation QuadraticEquation
f'
let g :: Integer -> Sum Integer
g = forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuadraticEquation -> Integer -> Integer
runQuadraticEquation QuadraticEquation
g'
let lhs :: Sum Integer
lhs = (forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap Integer -> Sum Integer
f Integer -> Sum Integer
g f Integer Integer
x)
let rhs :: Sum Integer
rhs = (forall (p :: * -> * -> *) a c b.
Bifoldable p =>
(a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldr (forall a. Monoid a => a -> a -> a
mappend forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Sum Integer
f) (forall a. Monoid a => a -> a -> a
mappend forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Sum Integer
g) forall a. Monoid a => a
mempty f Integer Integer
x)
let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
{ lawContextLawName :: String
lawContextLawName = String
"FoldMap", lawContextLawBody :: String
lawContextLawBody = String
"bifoldMap f g" String -> String -> String
`congruency` String
"bifoldr (mappend . f) (mappend . g) mempty"
, lawContextTcName :: String
lawContextTcName = String
"Bifoldable", lawContextTcProp :: String
lawContextTcProp =
let showX :: String
showX = forall a. Show a => a -> String
show f Integer Integer
x;
showF :: String
showF = forall a. Show a => a -> String
show QuadraticEquation
f';
showG :: String
showG = forall a. Show a => a -> String
show QuadraticEquation
g';
in [String] -> String
lawWhere
[ String
"bifoldMap f g x" String -> String -> String
`congruency` String
"bifoldr (mappend . f) (mappend . g) mempty x, where"
, String
"f = " forall a. [a] -> [a] -> [a]
++ String
showF
, String
"g = " forall a. [a] -> [a] -> [a]
++ String
showG
, String
"x = " forall a. [a] -> [a] -> [a]
++ String
showX
]
, lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced Sum Integer
lhs Sum Integer
rhs
}
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx Sum Integer
lhs Sum Integer
rhs Context
ctx
bifoldableFoldr :: forall f. BifoldableProp f
bifoldableFoldr :: forall (f :: * -> * -> *). BifoldableProp f
bifoldableFoldr forall x y. Gen x -> Gen y -> Gen (f x y)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
f Integer Integer
x <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x y. Gen x -> Gen y -> Gen (f x y)
fgen Gen Integer
genSmallInteger Gen Integer
genSmallInteger
LinearEquationTwo
f' <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen LinearEquationTwo
genLinearEquationTwo
LinearEquationTwo
g' <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll Gen LinearEquationTwo
genLinearEquationTwo
let f :: Integer -> Integer -> Integer
f = LinearEquationTwo -> Integer -> Integer -> Integer
runLinearEquationTwo LinearEquationTwo
f'
let g :: Integer -> Integer -> Integer
g = LinearEquationTwo -> Integer -> Integer -> Integer
runLinearEquationTwo LinearEquationTwo
g'
let z0 :: Integer
z0 = Integer
0
let lhs :: Integer
lhs = (forall (p :: * -> * -> *) a c b.
Bifoldable p =>
(a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldr Integer -> Integer -> Integer
f Integer -> Integer -> Integer
g Integer
z0 f Integer Integer
x)
let rhs :: Integer
rhs = (forall a. Endo a -> a -> a
appEndo (forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap (forall a. (a -> a) -> Endo a
Endo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Integer
f) (forall a. (a -> a) -> Endo a
Endo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Integer
g) f Integer Integer
x) Integer
z0)
let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
{ lawContextLawName :: String
lawContextLawName = String
"Foldr", lawContextLawBody :: String
lawContextLawBody = String
"bifoldr f g z t" String -> String -> String
`congruency` String
"appEndo (bifoldMap (Endo . f) (Endo . g) t) z"
, lawContextTcName :: String
lawContextTcName = String
"Bifoldable", lawContextTcProp :: String
lawContextTcProp =
let showX :: String
showX = forall a. Show a => a -> String
show f Integer Integer
x; showF :: String
showF = forall a. Show a => a -> String
show LinearEquationTwo
f'; showG :: String
showG = forall a. Show a => a -> String
show LinearEquationTwo
g'; showZ :: String
showZ = forall a. Show a => a -> String
show Integer
z0;
in [String] -> String
lawWhere
[ String
"bifoldr f g z t" String -> String -> String
`congruency` String
"appEndo (bifoldMap (Endo . f) (Endo . g) t z, where"
, String
"f = " forall a. [a] -> [a] -> [a]
++ String
showF
, String
"g = " forall a. [a] -> [a] -> [a]
++ String
showG
, String
"t = " forall a. [a] -> [a] -> [a]
++ String
showX
, String
"z = " forall a. [a] -> [a] -> [a]
++ String
showZ
]
, lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced Integer
lhs Integer
rhs
}
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx Integer
lhs Integer
rhs Context
ctx
type BifoldableFunctorProp f =
( Bifoldable f, Bifunctor f
, forall x y. (Eq x, Eq y) => Eq (f x y)
, forall x y. (Show x, Show y) => Show (f x y)
) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property
bifoldableFunctorComposition :: forall f. BifoldableFunctorProp f
bifoldableFunctorComposition :: forall (f :: * -> * -> *). BifoldableFunctorProp f
bifoldableFunctorComposition forall x y. Gen x -> Gen y -> Gen (f x y)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
f (Sum Integer) (Sum Integer)
x <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x y. Gen x -> Gen y -> Gen (f x y)
fgen Gen (Sum Integer)
genSmallSum Gen (Sum Integer)
genSmallSum
let f :: a -> Product a
f = forall a. a -> Product a
Product; g :: Sum Integer -> Product (Sum Integer)
g = forall a. a -> Product a
Product forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Sum Integer
1)
let lhs :: Product (Sum Integer)
lhs = forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap forall a. a -> Product a
f Sum Integer -> Product (Sum Integer)
g f (Sum Integer) (Sum Integer)
x
let rhs :: Product (Sum Integer)
rhs = forall (p :: * -> * -> *) m. (Bifoldable p, Monoid m) => p m m -> m
bifold (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. a -> Product a
f Sum Integer -> Product (Sum Integer)
g f (Sum Integer) (Sum Integer)
x)
let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
{ lawContextLawName :: String
lawContextLawName = String
"Composition", lawContextLawBody :: String
lawContextLawBody = String
"bifoldMap f g" String -> String -> String
`congruency` String
"bifold . bimap f g"
, lawContextTcName :: String
lawContextTcName = String
"Bifoldable/Bifunctor", lawContextTcProp :: String
lawContextTcProp =
let showX :: String
showX = forall a. Show a => a -> String
show f (Sum Integer) (Sum Integer)
x;
in [String] -> String
lawWhere
[ String
"bifoldMap f g x" String -> String -> String
`congruency` String
"bifold . bimap f g $ x"
, String
"f = \\x -> Product x"
, String
"g = \\x -> Product (x + 1)"
, String
"x = " forall a. [a] -> [a] -> [a]
++ String
showX
]
, lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced Product (Sum Integer)
lhs Product (Sum Integer)
rhs
}
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx Product (Sum Integer)
lhs Product (Sum Integer)
rhs Context
ctx
bifoldableFunctorFoldMap :: forall f. BifoldableFunctorProp f
bifoldableFunctorFoldMap :: forall (f :: * -> * -> *). BifoldableFunctorProp f
bifoldableFunctorFoldMap forall x y. Gen x -> Gen y -> Gen (f x y)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
f (Sum Integer) (Sum Integer)
x <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x y. Gen x -> Gen y -> Gen (f x y)
fgen Gen (Sum Integer)
genSmallSum Gen (Sum Integer)
genSmallSum
let h :: Sum a -> a
h (Sum a
s) = a
s forall a. Num a => a -> a -> a
* a
s forall a. Num a => a -> a -> a
+ a
3; showH :: String
showH = String
"\\(Sum s) -> s * s + 3"
let i :: Sum a -> a
i (Sum a
s) = a
s forall a. Num a => a -> a -> a
+ a
s forall a. Num a => a -> a -> a
- a
7; showI :: String
showI = String
"\\(Sum s) -> s + s - 7"
let f :: a -> Sum a
f = forall a. a -> Sum a
Sum; showF :: String
showF = String
"\\x -> Sum x"; g :: Integer -> Sum Integer
g = forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Integer
1); showG :: String
showG = String
"\\x -> Sum (x + 1)"
let lhs :: Sum Integer
lhs = forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap forall a. a -> Sum a
f Integer -> Sum Integer
g (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall {a}. Num a => Sum a -> a
h forall {a}. Num a => Sum a -> a
i f (Sum Integer) (Sum Integer)
x)
let rhs :: Sum Integer
rhs = forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap (forall a. a -> Sum a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Num a => Sum a -> a
h) (Integer -> Sum Integer
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Num a => Sum a -> a
i) f (Sum Integer) (Sum Integer)
x
let ctx :: Context
ctx = LawContext -> Context
contextualise forall a b. (a -> b) -> a -> b
$ LawContext
{ lawContextLawName :: String
lawContextLawName = String
"FoldMap", lawContextLawBody :: String
lawContextLawBody = String
"bifoldMap f g . bimap h i" String -> String -> String
`congruency` String
"bifoldMap (f . h) (g . i)"
, lawContextTcName :: String
lawContextTcName = String
"Bifoldable/Bifunctor", lawContextTcProp :: String
lawContextTcProp =
let showX :: String
showX = forall a. Show a => a -> String
show f (Sum Integer) (Sum Integer)
x;
in [String] -> String
lawWhere
[ String
"bifoldMap f g . bimap h i $ x" String -> String -> String
`congruency` String
"bifoldMap (f . h) (g . i) $ x, where"
, String
"f = " forall a. [a] -> [a] -> [a]
++ String
showF
, String
"g = " forall a. [a] -> [a] -> [a]
++ String
showG
, String
"h = " forall a. [a] -> [a] -> [a]
++ String
showH
, String
"i = " forall a. [a] -> [a] -> [a]
++ String
showI
, String
"x = " forall a. [a] -> [a] -> [a]
++ String
showX
]
, lawContextReduced :: String
lawContextReduced = forall a. Show a => a -> a -> String
reduced Sum Integer
lhs Sum Integer
rhs
}
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx Sum Integer
lhs Sum Integer
rhs Context
ctx