{-# LANGUAGE FlexibleContexts #-}
module Test.SmallCheck.Laws.Functor
  (
  -- * Functor laws
    identity
  , composition
  , compositionSum
  ) where

import Data.Functor.Identity (Identity)
import Test.SmallCheck (Property, over)
import Test.SmallCheck.Series (Serial, Series)
import Test.SmallCheck.Series.Utils (zipLogic3)

-- | Check the /identity/ law hold for the given 'Functor' 'Series':
--
-- @
-- 'fmap' 'id' ≡ 'id'
-- @
identity
  :: (Eq (f a), Monad m, Show (f a), Functor f)
  => Series m (f a) -> Property m
identity s = over s $ \x -> fmap id x == x

-- | Check the /composition/ law hold for the given 'Functor' 'Series':
--
-- @
-- 'fmap' (f . g) ≡ 'fmap' f . 'fmap' g
-- @
--
-- Exhaustive generation for the @f@ and @g@ 'Series'. Be aware of
-- combinatorial explosion.
composition
  :: ( Monad m, Functor f, Show a, Show b, Show c
     , Show (f a), Eq (f c)
     , Serial Identity a, Serial Identity b
     )
  => Series m (f a) -> Series m (b -> c) -> Series m (a -> b) -> Property m
composition xs fs gs =
    over xs $ \x ->
        over fs $ \f ->
            over gs $ \g ->
    fmap (f . g) x == (fmap f . fmap g) x

-- | Check the /composition/ law hold for the given 'Functor' 'Series':
--
-- @
-- 'fmap' (f . g) ≡ 'fmap' f . 'fmap' g
-- @
--
-- This uses 'zipLogic' for the generation of the @f@ and @g@ 'Series'.
compositionSum
  :: ( Monad m, Functor f, Show a, Show b, Show c
     , Show (f a), Eq (f c)
     , Serial Identity a, Serial Identity b
     )
  => Series m (f a) -> Series m (b -> c) -> Series m (a -> b) -> Property m
compositionSum xs fs gs = over (zipLogic3 xs fs gs) $ \(x,f,g) ->
    fmap (f . g) x == (fmap f . fmap g) x