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

module Hedgehog.Classes.Functor (functorLaws) where

import Hedgehog
import Hedgehog.Classes.Common

-- | Tests the following 'Functor' laws:
--
-- [__Identity__]: @'fmap' 'id'@ ≡ @'id'@
-- [__Composition__]: @'fmap' f '.' 'fmap' g@ ≡ @'fmap' (f '.' g)@
-- [__Const__]: @'fmap' ('const' x)@ ≡ @x '<$'@
functorLaws ::
  ( Functor f
  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
  ) => (forall x. Gen x -> Gen (f x)) -> Laws
functorLaws :: (forall x. Gen x -> Gen (f x)) -> Laws
functorLaws forall x. Gen x -> Gen (f x)
gen = String -> [(String, Property)] -> Laws
Laws String
"Functor"
  [ (String
"Identity", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *).
(Functor f, forall x. Eq x => Eq (f x),
 forall x. Show x => Show (f x)) =>
(forall x. Gen x -> Gen (f x)) -> Property
functorIdentity forall x. Gen x -> Gen (f x)
gen)
  , (String
"Composition", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *).
(Functor f, forall x. Eq x => Eq (f x),
 forall x. Show x => Show (f x)) =>
(forall x. Gen x -> Gen (f x)) -> Property
functorComposition forall x. Gen x -> Gen (f x)
gen)
  , (String
"Const", (forall x. Gen x -> Gen (f x)) -> Property
forall (f :: * -> *).
(Functor f, forall x. Eq x => Eq (f x),
 forall x. Show x => Show (f x)) =>
(forall x. Gen x -> Gen (f x)) -> Property
functorConst forall x. Gen x -> Gen (f x)
gen)
  ]

functorIdentity ::
  ( Functor f
  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
  ) => (forall x. Gen x -> Gen (f x)) -> Property
functorIdentity :: (forall x. Gen x -> Gen (f x)) -> Property
functorIdentity 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 = (Integer -> Integer) -> f Integer -> f Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Integer
forall a. a -> a
id f Integer
a
  let rhs :: f Integer
rhs = f Integer -> f Integer
forall a. a -> a
id 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
"Identity", lawContextTcName :: String
lawContextTcName = String
"Functor"
        , lawContextLawBody :: String
lawContextLawBody = String
"fmap id" String -> String -> String
`congruency` String
"id"
        , 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
"fmap id a" String -> String -> String
`congruency` String
"id 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.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx f Integer
lhs f Integer
rhs Context
ctx

functorComposition ::
  ( Functor f
  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
  ) => (forall x. Gen x -> Gen (f x)) -> Property
functorComposition :: (forall x. Gen x -> Gen (f x)) -> Property
functorComposition 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 f :: (Integer, Integer) -> (Bool, Either Ordering Integer)
f = (Integer, Integer) -> (Bool, Either Ordering Integer)
func2; g :: Integer -> (Integer, Integer)
g = Integer -> (Integer, Integer)
func1 
  let lhs :: f (Bool, Either Ordering Integer)
lhs = ((Integer, Integer) -> (Bool, Either Ordering Integer))
-> f (Integer, Integer) -> f (Bool, Either Ordering Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer, Integer) -> (Bool, Either Ordering Integer)
f ((Integer -> (Integer, Integer))
-> f Integer -> f (Integer, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> (Integer, Integer)
g f Integer
a)
  let rhs :: f (Bool, Either Ordering Integer)
rhs = (Integer -> (Bool, Either Ordering Integer))
-> f Integer -> f (Bool, Either Ordering Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Integer, Integer) -> (Bool, Either Ordering Integer)
f ((Integer, Integer) -> (Bool, Either Ordering Integer))
-> (Integer -> (Integer, Integer))
-> Integer
-> (Bool, Either Ordering Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> (Integer, Integer)
g) 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
"Composition", lawContextTcName :: String
lawContextTcName = String
"Functor"
        , lawContextLawBody :: String
lawContextLawBody = String
"fmap f . fmap g" String -> String -> String
`congruency` String
"fmap (f . g)"
        , lawContextTcProp :: String
lawContextTcProp =
            let showA :: String
showA = f Integer -> String
forall a. Show a => a -> String
show f Integer
a
                showF :: String
showF = String
"\\(a,b) -> (odd a, if even a then Left (compare a b) else Right (b + 2)"
                showG :: String
showG = String
"\\i -> (div (i + 5) 3, i * i - 2 * i + 1)"
            in [String] -> String
lawWhere
              [ String
"fmap f . fmap g $ a" String -> String -> String
`congruency` String
"fmap (f . g) a, where"
              , String
"f = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showF
              , String
"g = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showG
              , String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showA
              ]
        , lawContextReduced :: String
lawContextReduced = f (Bool, Either Ordering Integer)
-> f (Bool, Either Ordering Integer) -> String
forall a. Show a => a -> a -> String
reduced f (Bool, Either Ordering Integer)
lhs f (Bool, Either Ordering Integer)
rhs
        }
  f (Bool, Either Ordering Integer)
-> f (Bool, Either Ordering Integer) -> Context -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx f (Bool, Either Ordering Integer)
lhs f (Bool, Either Ordering Integer)
rhs Context
ctx

functorConst ::
  ( Functor f
  , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
  ) => (forall x. Gen x -> Gen (f x)) -> Property
functorConst :: (forall x. Gen x -> Gen (f x)) -> Property
functorConst 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 x :: Char
x = Char
'X'
  let lhs :: f Char
lhs = (Integer -> Char) -> f Integer -> f Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> Integer -> Char
forall a b. a -> b -> a
const Char
x) f Integer
a
  let rhs :: f Char
rhs = Char
x Char -> f Integer -> f Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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
"Const", lawContextTcName :: String
lawContextTcName = String
"Functor"
        , lawContextLawBody :: String
lawContextLawBody = String
"fmap (const x)" String -> String -> String
`congruency` String
"x <$"
        , lawContextTcProp :: String
lawContextTcProp =
            let showA :: String
showA = f Integer -> String
forall a. Show a => a -> String
show f Integer
a
                showX :: String
showX = Char -> String
forall a. Show a => a -> String
show Char
x
            in [String] -> String
lawWhere
              [ String
"fmap (const x) a" String -> String -> String
`congruency` String
"x <$ a, where"
              , String
"x = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showX
              , String
"a = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showA
              ]
        , lawContextReduced :: String
lawContextReduced = f Char -> f Char -> String
forall a. Show a => a -> a -> String
reduced f Char
lhs f Char
rhs
        }
  f Char -> f Char -> Context -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack, Eq a, Show a) =>
a -> a -> Context -> m ()
heqCtx f Char
lhs f Char
rhs Context
ctx