{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

#if HAVE_QUANTIFIED_CONSTRAINTS
{-# LANGUAGE QuantifiedConstraints #-}
#endif

{-# OPTIONS_GHC -Wall #-}

module Test.QuickCheck.Classes.MonadZip
  (
#if HAVE_UNARY_LAWS
    monadZipLaws
#endif
  ) where

import Control.Applicative
import Control.Arrow (Arrow(..))
import Control.Monad.Zip (MonadZip(mzip))
import Test.QuickCheck hiding ((.&.))
import Control.Monad (liftM)
#if HAVE_UNARY_LAWS
import Test.QuickCheck.Arbitrary (Arbitrary1(..))
import Data.Functor.Classes (Eq1,Show1)
#endif
import Test.QuickCheck.Property (Property)

import Test.QuickCheck.Classes.Internal

#if HAVE_UNARY_LAWS

-- | Tests the following monadic zipping properties:
--
-- [/Naturality/]
--   @'liftM' (f '***' g) ('mzip' ma mb) = 'mzip' ('liftM' f ma) ('liftM' g mb)@
--
-- In the laws above, the infix function @'***'@ refers to a typeclass
-- method of 'Arrow'.
monadZipLaws ::
#if HAVE_QUANTIFIED_CONSTRAINTS
  (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))
#else
  (MonadZip f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f)
#endif
  => proxy f -> Laws
monadZipLaws :: proxy f -> Laws
monadZipLaws proxy f
p = String -> [(String, Property)] -> Laws
Laws String
"MonadZip"
  [ (String
"Naturality", proxy f -> Property
forall (proxy :: (* -> *) -> *) (f :: * -> *).
(MonadZip f, forall a. Eq a => Eq (f a),
 forall a. Show a => Show (f a),
 forall a. Arbitrary a => Arbitrary (f a)) =>
proxy f -> Property
monadZipNaturality proxy f
p)
  ]

monadZipNaturality :: forall proxy f.
#if HAVE_QUANTIFIED_CONSTRAINTS
  (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a))
#else
  (MonadZip f, Functor f, Eq1 f, Show1 f, Arbitrary1 f)
#endif
  => proxy f -> Property
monadZipNaturality :: proxy f -> Property
monadZipNaturality proxy f
_ = (LinearEquation
 -> LinearEquation -> Apply f Integer -> Apply f Integer -> Bool)
-> Property
forall prop. Testable prop => prop -> Property
property ((LinearEquation
  -> LinearEquation -> Apply f Integer -> Apply f Integer -> Bool)
 -> Property)
-> (LinearEquation
    -> LinearEquation -> Apply f Integer -> Apply f Integer -> Bool)
-> Property
forall a b. (a -> b) -> a -> b
$ \(LinearEquation
f' :: LinearEquation) (LinearEquation
g' :: LinearEquation) (Apply (f Integer
ma :: f Integer)) (Apply (f Integer
mb :: f Integer)) ->
  let f :: Integer -> Integer
f = LinearEquation -> Integer -> Integer
runLinearEquation LinearEquation
f'
      g :: Integer -> Integer
g = LinearEquation -> Integer -> Integer
runLinearEquation LinearEquation
g'
   in f (Integer, Integer) -> f (Integer, Integer) -> Bool
forall (f :: * -> *) a.
(forall x. Eq x => Eq (f x), Eq a) =>
f a -> f a -> Bool
eq1 (((Integer, Integer) -> (Integer, Integer))
-> f (Integer, Integer) -> f (Integer, Integer)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Integer -> Integer
f (Integer -> Integer)
-> (Integer -> Integer) -> (Integer, Integer) -> (Integer, Integer)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Integer -> Integer
g) (f Integer -> f Integer -> f (Integer, Integer)
forall (m :: * -> *) a b. MonadZip m => m a -> m b -> m (a, b)
mzip f Integer
ma f Integer
mb)) (f Integer -> f Integer -> f (Integer, Integer)
forall (m :: * -> *) a b. MonadZip m => m a -> m b -> m (a, b)
mzip ((Integer -> Integer) -> f Integer -> f Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Integer -> Integer
f f Integer
ma) ((Integer -> Integer) -> f Integer -> f Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Integer -> Integer
g f Integer
mb))

#endif