{-# 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(..))

-- | Tests the following 'Bifoldable' laws:
--
-- [__Identity__]: @'bifold'@ ≡ @'bifoldMap' 'id' 'id'@
-- [__FoldMap__]: @'bifoldMap' f g@ ≡ @'bifoldr' ('mappend' '.' f) ('mappend' '.' g) 'mempty'@
-- [__Foldr__]: @'bifoldr' f g z t@ ≡ @'appEndo' ('bifoldMap' ('Endo' '.' f) ('Endo' '.' g) t) z@
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)
  ]

-- | Tests the following 'Bifoldable' / 'Bifunctor' laws:
--
-- [__Composition__]: @'bifoldMap' f g@ ≡ @'bifold' '.' 'bimap' f g@
-- [__FoldMap__]: @'bifoldMap' f g '.' 'bimap' h i@ ≡ @'bifoldMap' (f '.' h) (g '.' i)@
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