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

module Hedgehog.Classes.Traversable (traversableLaws) where

import Hedgehog
import Hedgehog.Classes.Common

import Data.Functor.Identity
import Data.Functor.Compose
import Data.Traversable (Traversable(..), foldMapDefault, fmapDefault)

-- | Tests the following 'Traversable' laws:
--
-- [__Naturality__]: @t '.' 'traverse' f@ ≡ @'traverse' (t '.' f), for every applicative transformation t@
-- [__Identity__]: @'traverse' 'Identity'@ ≡ @'Identity'@
-- [__Composition__]: @'traverse' ('Compose' '.' 'fmap' g '.' f)@ ≡ @'Compose' '.' 'fmap' ('traverse' g) '.' 'traverse' f@
-- [__SequenceA Naturality__]: @t '.' 'sequenceA'@ ≡ @'sequenceA' '.' 'fmap' t, for every applicative transformation t@
-- [__SequenceA Identity__]: @'sequenceA' '.' 'fmap' 'Identity'@ ≡ @'Identity'@
-- [__SequenceA Composition__]: @'sequenceA' '.' 'fmap' 'Compose'@ ≡ @'Compose' '.' 'fmap' 'sequenceA' '.' 'sequenceA'@
-- [__FoldMap__]: @'foldMap'@ ≡ @'foldMapDefault'@
-- [__Fmap__]: @'fmap'@ ≡ @'fmapDefault'@
traversableLaws ::
  ( Traversable f
  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
  ) => (forall x. Gen x -> Gen (f x)) -> Laws
traversableLaws :: forall (f :: * -> *).
(Traversable f, forall x. Eq x => Eq (f x),
 forall x. Show x => Show (f x)) =>
(forall x. Gen x -> Gen (f x)) -> Laws
traversableLaws forall x. Gen x -> Gen (f x)
gen = String -> [(String, Property)] -> Laws
Laws String
"Foldable"
  [ (String
"Naturality", forall (f :: * -> *). TraversableProp f
traversableNaturality forall x. Gen x -> Gen (f x)
gen)
  , (String
"Identity", forall (f :: * -> *). TraversableProp f
traversableIdentity forall x. Gen x -> Gen (f x)
gen)
  , (String
"Composition", forall (f :: * -> *). TraversableProp f
traversableComposition forall x. Gen x -> Gen (f x)
gen)
  , (String
"Sequence Naturality", forall (f :: * -> *). TraversableProp f
traversableSequenceNaturality forall x. Gen x -> Gen (f x)
gen)
  , (String
"Sequence Identity", forall (f :: * -> *). TraversableProp f
traversableSequenceIdentity forall x. Gen x -> Gen (f x)
gen)
  , (String
"Sequence Composition", forall (f :: * -> *). TraversableProp f
traversableSequenceComposition forall x. Gen x -> Gen (f x)
gen)
  , (String
"foldMap", forall (f :: * -> *). TraversableProp f
traversableFoldMap forall x. Gen x -> Gen (f x)
gen)
  , (String
"fmap", forall (f :: * -> *). TraversableProp f
traversableFmap forall x. Gen x -> Gen (f x)
gen)
  ]

type TraversableProp f =
  ( Traversable f
  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
  ) => (forall x. Gen x -> Gen (f x)) -> Property

traversableNaturality :: TraversableProp f
traversableNaturality :: forall (f :: * -> *). TraversableProp f
traversableNaturality forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  f Integer
a <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  (forall a.
Compose Triple (Writer (Set Integer)) a
-> Compose (Writer (Set Integer)) Triple a
apTrans (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Integer -> Compose Triple (Writer (Set Integer)) Integer
func4 f Integer
a)) 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 -> m ()
`heq1` (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a.
Compose Triple (Writer (Set Integer)) a
-> Compose (Writer (Set Integer)) Triple a
apTrans forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Compose Triple (Writer (Set Integer)) Integer
func4) f Integer
a)

traversableIdentity :: TraversableProp f
traversableIdentity :: forall (f :: * -> *). TraversableProp f
traversableIdentity forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  f Integer
t <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. a -> Identity a
Identity f Integer
t) 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 -> m ()
`heq1` (forall a. a -> Identity a
Identity f Integer
t)

traversableComposition :: TraversableProp f
traversableComposition :: forall (f :: * -> *). TraversableProp f
traversableComposition forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  f Integer
t <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger 
  let lhs :: Compose Triple Triple (f Integer)
lhs = (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Triple Integer
func5 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Triple Integer
func6) f Integer
t)
  let rhs :: Compose Triple Triple (f Integer)
rhs = (forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Integer -> Triple Integer
func5) (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Integer -> Triple Integer
func6 f Integer
t)))
  Compose Triple Triple (f Integer)
lhs 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 -> m ()
`heq1` Compose Triple Triple (f Integer)
rhs

traversableSequenceNaturality :: TraversableProp f
traversableSequenceNaturality :: forall (f :: * -> *). TraversableProp f
traversableSequenceNaturality forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  f (Compose Triple ((,) (Set 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. Gen x -> Gen (f x)
fgen (forall (f :: * -> *) (g :: * -> *) a.
Gen a
-> (forall x. Gen x -> Gen (f x))
-> (forall x. Gen x -> Gen (g x))
-> Gen (Compose f g a)
genCompose Gen Integer
genSmallInteger forall a. Gen a -> Gen (Triple a)
genTriple (forall a b. Gen a -> Gen b -> Gen (a, b)
genTuple Gen (Set Integer)
genSetInteger))
  let a :: f (Compose Triple (Writer (Set Integer)) Integer)
a = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Compose Triple ((,) (Set Integer)) Integer
-> Compose Triple (Writer (Set Integer)) Integer
toSpecialApplicative f (Compose Triple ((,) (Set Integer)) Integer)
x
  (forall a.
Compose Triple (Writer (Set Integer)) a
-> Compose (Writer (Set Integer)) Triple a
apTrans (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA f (Compose Triple (Writer (Set Integer)) Integer)
a)) 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 -> m ()
`heq1` (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a.
Compose Triple (Writer (Set Integer)) a
-> Compose (Writer (Set Integer)) Triple a
apTrans f (Compose Triple (Writer (Set Integer)) Integer)
a)) 

traversableSequenceIdentity :: TraversableProp f
traversableSequenceIdentity :: forall (f :: * -> *). TraversableProp f
traversableSequenceIdentity forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  f Integer
t <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Identity a
Identity f Integer
t)) 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 -> m ()
`heq1` (forall a. a -> Identity a
Identity f Integer
t)

traversableSequenceComposition :: TraversableProp f
traversableSequenceComposition :: forall (f :: * -> *). TraversableProp f
traversableSequenceComposition forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  let genTripleInteger :: Gen (Triple Integer)
genTripleInteger = forall a. Gen a -> Gen (Triple a)
genTriple Gen Integer
genSmallInteger
  f (Triple (Triple Integer))
t <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x. Gen x -> Gen (f x)
fgen (forall a. Gen a -> Gen (Triple a)
genTriple Gen (Triple Integer)
genTripleInteger)
  (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose f (Triple (Triple Integer))
t)) 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 -> m ()
`heq1` (forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA f (Triple (Triple Integer))
t)))

traversableFoldMap :: TraversableProp f
traversableFoldMap :: forall (f :: * -> *). TraversableProp f
traversableFoldMap forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  f Integer
t <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Integer -> Sum Integer
func3 f Integer
t 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 -> m ()
`heq1` forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault Integer -> Sum Integer
func3 f Integer
t  

traversableFmap :: TraversableProp f
traversableFmap :: forall (f :: * -> *). TraversableProp f
traversableFmap forall x. Gen x -> Gen (f x)
fgen = HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  f Integer
t <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ forall x. Gen x -> Gen (f x)
fgen Gen Integer
genSmallInteger
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Sum Integer
func3 f Integer
t 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 -> m ()
`heq1` forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault Integer -> Sum Integer
func3 f Integer
t