{- |
  Properties for testing that instances of the 'Monad' class
  perform correctly.

  This testing requires an 'Eq' instance, which not all 'Monad's
  actually have. It also requires a 'Show' instance, which is also
  uncommon. The 'Label1' wrapper may be useful in dealing with the
  'Show' requirement.

  Tests are supplied both in regular \"unlabelled\" form, and also
  in a special \"labelled\" form, where function objects have
  'Label's attached to them. Because of this, the function used for
  each test can be recorded in the test log, which can be quite
  helpful.
-}

module Test.AC.Class.Monad where

import Test.AC.Test
import Test.AC.Label

-- * Unlabelled tests

-- | Check that @return x >>= f '==' f x@.
p_return_bind :: (Monad m, Eq (m y), Show x, Show (m x), Show (m y)) => x -> (x -> m y) -> Test
p_return_bind x f =
  title "return x >>= f == f x" $
  argument "x" x $
  temporary "return x" ((return x) `asTypeOf` (f x >> return x)) $
  (return x >>= f) ?= (f x)

-- | Check that @mx >>= return '==' mx@.
p_bind_return :: (Monad m, Eq (m x), Show (m x)) => m x -> Test
p_bind_return mx =
  title "mx >>= return == mx" $
  argument "mx" mx $
  (mx >>= return) ?= mx

{- |
  Check that '>>=' is associative.

  Approximately, @mx >>= (f >>= g) '==' (mx >>= f) >>= g@, but that
  doesn't type-check. To be exact,
  @mx >>= (\\ x -> f x >>= g) '==' (mx >>= f) >>= g@.
-}
p_bind_associative :: (Monad m, Eq (m z), Show (m x), Show (m y), Show (m z)) => m x -> (x -> m y) -> (y -> m z) -> Test
p_bind_associative mx f g =
  title "mx >>= (f >>= g) == (mx >>= f) >>= g" $
  argument "mx" mx $
  temporary "mx >>= f" (mx >>= f) $
  (mx >>= (\ x -> f x >>= g)) ?= ((mx >>= f) >>= g)

{- |
  Given a list of /distinct/ inputs, run all applicable 'Monad'
  tests on all combinations of inputs. (If the inputs are not
  distinct, some redundant tests will be performed.)

  The argument types have been constrainted a bit to keep the
  function's type signature reasonably simple.
-}
p_Monad :: (Monad m, Eq (m x), Show x, Show (m x)) => [x] -> [x -> m x] -> [m x] -> Test
p_Monad xs fs mxs =
  title "p_Monad" $
  argument "xs" xs $
  tests
  [
    title "p_return_bind"      $ tests [ p_return_bind       x f     |  x <-  xs, f  <- fs           ],
    title "p_bind_return"      $ tests [ p_bind_return      mx       | mx <- mxs                     ],
    title "p_bind_associative" $ tests [ p_bind_associative mx f1 f2 | mx <- mxs, f1 <- fs, f2 <- fs ]
  ]

-- | Check that @fmap f mx '==' mx >>= return . f@.
p_Functor_Monad :: (Functor m, Monad m, Eq (m y), Show (m x), Show (m y)) => m x -> (x -> y) -> Test
p_Functor_Monad mx f =
  title "fmap f mx == mx >>= return . f" $
  argument "mx" mx $
  (fmap f mx) ?= (mx >>= return . f)

-- * Labelled tests

-- | Check that @return x >>= f '==' f x@.
p_return_bind_L :: (Monad m, Eq (m y), Show x, Show (m x), Show (m y)) => x -> Label (x -> m y) -> Test
p_return_bind_L x (Label lf f) =
  title "return x >>= f == f x" $
  argument  "x"  x $
  argument_ "f" lf $
  temporary "return x" ((return x) `asTypeOf` (f x >> return x)) $
  (return x >>= f) ?= (f x)

{- |
  Check that '>>=' is associative.

  Approximately, @mx >>= (f >>= g) '==' (mx >>= f) >>= g@, but that
  doesn't type-check. To be exact,
  @mx >>= (\\ x -> f x >>= g) '==' (mx >>= f) >>= g@.
-}
p_bind_associative_L :: (Monad m, Eq (m z), Show (m x), Show (m y), Show (m z)) => m x -> Label (x -> m y) -> Label (y -> m z) -> Test
p_bind_associative_L mx (Label lf f) (Label lg g) =
  title "mx >>= (f >>= g) == (mx >>= f) >>= g" $
  argument  "mx" mx $
  argument_  "f" lf $
  argument_  "g" lg $
  temporary "mx >>= f" (mx >>= f) $
  (mx >>= (\ x -> f x >>= g)) ?= ((mx >>= f) >>= g)

{- |
  Given a list of /distinct/ inputs, run all applicable 'Monad'
  tests on all combinations of inputs. (If the inputs are not
  distinct, some redundant tests will be performed.)

  The argument types have been constrainted a bit to keep the
  function's type signature reasonably simple.
-}
p_Monad_L :: (Monad m, Eq (m x), Show x, Show (m x)) => [x] -> [Label (x -> m x)] -> [m x] -> Test
p_Monad_L xs fs mxs =
  title "p_Monad" $
  argument "xs" xs $
  tests
  [
    title "p_return_bind"      $ tests [ p_return_bind_L       x f     |  x <-  xs, f  <- fs           ],
    title "p_bind_return"      $ tests [ p_bind_return        mx       | mx <- mxs                     ],
    title "p_bind_associative" $ tests [ p_bind_associative_L mx f1 f2 | mx <- mxs, f1 <- fs, f2 <- fs ]
  ]

-- | Check that @fmap f mx '==' mx >>= return . f@.
p_Functor_Monad_L :: (Functor m, Monad m, Eq (m y), Show (m x), Show (m y)) => m x -> Label (x -> y) -> Test
p_Functor_Monad_L mx (Label lf f) =
  title "fmap f mx == mx >>= return . f" $
  argument  "mx" mx $
  argument_  "f" lf $
  (fmap f mx) ?= (mx >>= return . f)