{-# 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 x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). TraversableProp f
traversableNaturality Gen x -> Gen (f x)
forall x. Gen x -> Gen (f x)
gen)
  , (String
"Identity", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). TraversableProp f
traversableIdentity Gen x -> Gen (f x)
forall x. Gen x -> Gen (f x)
gen)
  , (String
"Composition", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). TraversableProp f
traversableComposition Gen x -> Gen (f x)
forall x. Gen x -> Gen (f x)
gen)
  , (String
"Sequence Naturality", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). TraversableProp f
traversableSequenceNaturality Gen x -> Gen (f x)
forall x. Gen x -> Gen (f x)
gen)
  , (String
"Sequence Identity", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). TraversableProp f
traversableSequenceIdentity Gen x -> Gen (f x)
forall x. Gen x -> Gen (f x)
gen)
  , (String
"Sequence Composition", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). TraversableProp f
traversableSequenceComposition Gen x -> Gen (f x)
forall x. Gen x -> Gen (f x)
gen)
  , (String
"foldMap", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). TraversableProp f
traversableFoldMap Gen x -> Gen (f x)
forall x. Gen x -> Gen (f x)
gen)
  , (String
"fmap", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *). TraversableProp f
traversableFmap Gen x -> Gen (f x)
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
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  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
  (apTrans (traverse func4 a)) `heq1` (traverse (apTrans . func4) a)

traversableIdentity :: TraversableProp f
traversableIdentity :: forall (f :: * -> *). TraversableProp f
traversableIdentity 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
  t <- 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
  (traverse Identity t) `heq1` (Identity t)

traversableComposition :: TraversableProp f
traversableComposition :: forall (f :: * -> *). TraversableProp f
traversableComposition 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
  t <- 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 = ((Integer -> Compose Triple Triple Integer)
-> f Integer -> Compose Triple Triple (f Integer)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse (Triple (Triple Integer) -> Compose Triple Triple Integer
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Triple (Triple Integer) -> Compose Triple Triple Integer)
-> (Integer -> Triple (Triple Integer))
-> Integer
-> Compose Triple Triple Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Triple Integer)
-> Triple Integer -> Triple (Triple Integer)
forall a b. (a -> b) -> Triple a -> Triple b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Triple Integer
func5 (Triple Integer -> Triple (Triple Integer))
-> (Integer -> Triple Integer)
-> Integer
-> Triple (Triple Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Triple Integer
func6) f Integer
t)
  let rhs = (Triple (Triple (f Integer)) -> Compose Triple Triple (f Integer)
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((f Integer -> Triple (f Integer))
-> Triple (f Integer) -> Triple (Triple (f Integer))
forall a b. (a -> b) -> Triple a -> Triple b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Integer -> Triple Integer) -> f Integer -> Triple (f Integer)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse Integer -> Triple Integer
func5) ((Integer -> Triple Integer) -> f Integer -> Triple (f Integer)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse Integer -> Triple Integer
func6 f Integer
t)))
  lhs `heq1` rhs

traversableSequenceNaturality :: TraversableProp f
traversableSequenceNaturality :: forall (f :: * -> *). TraversableProp f
traversableSequenceNaturality 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
  x <- Gen (f (Compose Triple ((,) (Set Integer)) Integer))
-> PropertyT IO (f (Compose Triple ((,) (Set Integer)) Integer))
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (f (Compose Triple ((,) (Set Integer)) Integer))
 -> PropertyT IO (f (Compose Triple ((,) (Set Integer)) Integer)))
-> Gen (f (Compose Triple ((,) (Set Integer)) Integer))
-> PropertyT IO (f (Compose Triple ((,) (Set Integer)) Integer))
forall a b. (a -> b) -> a -> b
$ Gen (Compose Triple ((,) (Set Integer)) Integer)
-> Gen (f (Compose Triple ((,) (Set Integer)) Integer))
forall x. Gen x -> Gen (f x)
fgen (Gen Integer
-> (forall x. Gen x -> Gen (Triple x))
-> (forall x. Gen x -> Gen (Set Integer, x))
-> Gen (Compose Triple ((,) (Set Integer)) Integer)
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 Gen x -> Gen (Triple x)
forall x. Gen x -> Gen (Triple x)
genTriple (Gen (Set Integer)
-> GenT Identity x -> GenT Identity (Set Integer, x)
forall a b. Gen a -> Gen b -> Gen (a, b)
genTuple Gen (Set Integer)
genSetInteger))
  let a = (Compose Triple ((,) (Set Integer)) Integer
 -> Compose Triple (Writer (Set Integer)) Integer)
-> f (Compose Triple ((,) (Set Integer)) Integer)
-> f (Compose Triple (Writer (Set Integer)) Integer)
forall a b. (a -> b) -> f a -> f b
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
  (apTrans (sequenceA a)) `heq1` (sequenceA (fmap apTrans a)) 

traversableSequenceIdentity :: TraversableProp f
traversableSequenceIdentity :: forall (f :: * -> *). TraversableProp f
traversableSequenceIdentity 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
  t <- 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
  (sequenceA (fmap Identity t)) `heq1` (Identity t)

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

traversableFoldMap :: TraversableProp f
traversableFoldMap :: forall (f :: * -> *). TraversableProp f
traversableFoldMap 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
  t <- 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
  foldMap func3 t `heq1` foldMapDefault func3 t  

traversableFmap :: TraversableProp f
traversableFmap :: forall (f :: * -> *). TraversableProp f
traversableFmap 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
  t <- 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
  fmap func3 t `heq1` fmapDefault func3 t