{-# LANGUAGE CPP #-}
#ifndef NO_SAFE_HASKELL
#if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0))
{-# LANGUAGE Trustworthy #-}
#else
{-# LANGUAGE Safe #-}
#endif
#endif
#ifndef NO_ST_MONAD
{-# LANGUAGE Rank2Types #-}
#endif
{-|
Module   : Test.QuickCheck.Monadic

Allows testing of monadic values. Will generally follow this form:

@
prop_monadic a b = 'monadicIO' $ do
  a\' \<- 'run' (f a)
  b\' \<- 'run' (f b)
  -- ...
  'assert' someBoolean
@

Example using the @FACTOR(1)@ command-line utility:

@
import System.Process
import Test.QuickCheck
import Test.QuickCheck.Monadic

-- $ factor 16
-- 16: 2 2 2 2
factor :: Integer -> IO [Integer]
factor n = parse \`fmap\` 'System.Process.readProcess' \"factor\" [show n] \"\" where

  parse :: String -> [Integer]
  parse = map read . tail . words

prop_factor :: Positive Integer -> Property
prop_factor ('Test.QuickCheck.Modifiers.Positive' n) = 'monadicIO' $ do
  factors \<- 'run' (factor n)

  'assert' (product factors == n)
@

>>> quickCheck prop_factor
+++ OK, passed 100 tests.

See the paper \"<http://www.cse.chalmers.se/~rjmh/Papers/QuickCheckST.ps Testing Monadic Code with QuickCheck>\".
-}
module Test.QuickCheck.Monadic (
  -- * Property monad
    PropertyM(..)

  -- * Monadic specification combinators
  , run
  , assert
  , pre
  , wp
  , pick
  , forAllM
  , monitor
  , stop

  -- * Run functions
  , monadic
  , monadic'
  , monadicIO
#ifndef NO_ST_MONAD
  , monadicST
  , runSTGen
#endif
  ) where

--------------------------------------------------------------------------
-- imports

import Test.QuickCheck.Gen
import Test.QuickCheck.Gen.Unsafe
import Test.QuickCheck.Property

import Control.Monad(liftM, liftM2)

import Control.Monad.ST
import Control.Applicative

#ifndef NO_TRANSFORMERS
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
#endif

#ifndef NO_MONADFAIL
import qualified Control.Monad.Fail as Fail
#endif

--------------------------------------------------------------------------
-- type PropertyM

-- | The property monad is really a monad transformer that can contain
-- monadic computations in the monad @m@ it is parameterized by:
--
--   * @m@ - the @m@-computations that may be performed within @PropertyM@
--
-- Elements of @PropertyM m a@ may mix property operations and @m@-computations.
newtype PropertyM m a =
  MkPropertyM { PropertyM m a -> (a -> Gen (m Property)) -> Gen (m Property)
unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) }

bind :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
MkPropertyM (a -> Gen (m Property)) -> Gen (m Property)
m bind :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
`bind` a -> PropertyM m b
f = ((b -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m b
forall (m :: * -> *) a.
((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
MkPropertyM (\b -> Gen (m Property)
k -> (a -> Gen (m Property)) -> Gen (m Property)
m (\a
a -> PropertyM m b -> (b -> Gen (m Property)) -> Gen (m Property)
forall (m :: * -> *) a.
PropertyM m a -> (a -> Gen (m Property)) -> Gen (m Property)
unPropertyM (a -> PropertyM m b
f a
a) b -> Gen (m Property)
k))

fail_ :: Monad m => String -> PropertyM m a
fail_ :: String -> PropertyM m a
fail_ String
s = Result -> PropertyM m a
forall prop (m :: * -> *) a.
(Testable prop, Monad m) =>
prop -> PropertyM m a
stop (Result
failed { reason :: String
reason = String
s })

instance Functor (PropertyM m) where
  fmap :: (a -> b) -> PropertyM m a -> PropertyM m b
fmap a -> b
f (MkPropertyM (a -> Gen (m Property)) -> Gen (m Property)
m) = ((b -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m b
forall (m :: * -> *) a.
((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
MkPropertyM (\b -> Gen (m Property)
k -> (a -> Gen (m Property)) -> Gen (m Property)
m (b -> Gen (m Property)
k (b -> Gen (m Property)) -> (a -> b) -> a -> Gen (m Property)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Applicative (PropertyM m) where
  pure :: a -> PropertyM m a
pure a
x = ((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
forall (m :: * -> *) a.
((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
MkPropertyM (\a -> Gen (m Property)
k -> a -> Gen (m Property)
k a
x)
  PropertyM m (a -> b)
mf <*> :: PropertyM m (a -> b) -> PropertyM m a -> PropertyM m b
<*> PropertyM m a
mx =
    PropertyM m (a -> b)
mf PropertyM m (a -> b)
-> ((a -> b) -> PropertyM m b) -> PropertyM m b
forall (m :: * -> *) a b.
PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
`bind` \a -> b
f -> PropertyM m a
mx PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
forall (m :: * -> *) a b.
PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
`bind` \a
x -> b -> PropertyM m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
x)

instance Monad m => Monad (PropertyM m) where
  return :: a -> PropertyM m a
return = a -> PropertyM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >>= :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
(>>=) = PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
forall (m :: * -> *) a b.
PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
bind
#if !MIN_VERSION_base(4,13,0)
  fail = fail_
#endif

#ifndef NO_MONADFAIL
instance Monad m => Fail.MonadFail (PropertyM m) where
  fail :: String -> PropertyM m a
fail = String -> PropertyM m a
forall (m :: * -> *) a. Monad m => String -> PropertyM m a
fail_
#endif

#ifndef NO_TRANSFORMERS
instance MonadTrans PropertyM where
  lift :: m a -> PropertyM m a
lift = m a -> PropertyM m a
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run

instance MonadIO m => MonadIO (PropertyM m) where
  liftIO :: IO a -> PropertyM m a
liftIO = m a -> PropertyM m a
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run (m a -> PropertyM m a) -> (IO a -> m a) -> IO a -> PropertyM m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
#endif

stop :: (Testable prop, Monad m) => prop -> PropertyM m a
stop :: prop -> PropertyM m a
stop prop
p = ((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
forall (m :: * -> *) a.
((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
MkPropertyM (\a -> Gen (m Property)
_k -> m Property -> Gen (m Property)
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property
forall (m :: * -> *) a. Monad m => a -> m a
return (prop -> Property
forall prop. Testable prop => prop -> Property
property prop
p)))

-- should think about strictness/exceptions here
-- assert :: Testable prop => prop -> PropertyM m ()
-- | Allows embedding non-monadic properties into monadic ones.
assert :: Monad m => Bool -> PropertyM m ()
assert :: Bool -> PropertyM m ()
assert Bool
True  = () -> PropertyM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
assert Bool
False = String -> PropertyM m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Assertion failed"

-- should think about strictness/exceptions here
-- | Tests preconditions. Unlike 'assert' this does not cause the
-- property to fail, rather it discards them just like using the
-- implication combinator 'Test.QuickCheck.Property.==>'.
--
-- This allows representing the <https://en.wikipedia.org/wiki/Hoare_logic Hoare triple>
--
-- > {p} x ← e{q}
--
-- as
--
-- @
-- pre p
-- x \<- run e
-- assert q
-- @
--
pre :: Monad m => Bool -> PropertyM m ()
pre :: Bool -> PropertyM m ()
pre Bool
True  = () -> PropertyM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
pre Bool
False = Result -> PropertyM m ()
forall prop (m :: * -> *) a.
(Testable prop, Monad m) =>
prop -> PropertyM m a
stop Result
rejected

-- should be called lift?
-- | The lifting operation of the property monad. Allows embedding
-- monadic\/'IO'-actions in properties:
--
-- @
-- log :: Int -> IO ()
--
-- prop_foo n = monadicIO $ do
--   run (log n)
--   -- ...
-- @
run :: Monad m => m a -> PropertyM m a
run :: m a -> PropertyM m a
run m a
m = ((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
forall (m :: * -> *) a.
((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
MkPropertyM (((a -> m Property) -> m Property)
-> Gen (a -> m Property) -> Gen (m Property)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (m a
m m a -> (a -> m Property) -> m Property
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=) (Gen (a -> m Property) -> Gen (m Property))
-> ((a -> Gen (m Property)) -> Gen (a -> m Property))
-> (a -> Gen (m Property))
-> Gen (m Property)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Gen (m Property)) -> Gen (a -> m Property)
forall (m :: * -> *) a. Monad m => m (Gen a) -> Gen (m a)
promote)

-- | Quantification in a monadic property, fits better with
-- /do-notation/ than 'forAllM'.
-- __Note__: values generated by 'pick' do not shrink.
pick :: (Monad m, Show a) => Gen a -> PropertyM m a
pick :: Gen a -> PropertyM m a
pick Gen a
gen = ((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
forall (m :: * -> *) a.
((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
MkPropertyM (((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a)
-> ((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
forall a b. (a -> b) -> a -> b
$ \a -> Gen (m Property)
k ->
  do a
a <- Gen a
gen
     m Property
mp <- a -> Gen (m Property)
k a
a
     m Property -> Gen (m Property)
forall (m :: * -> *) a. Monad m => a -> m a
return (do Property
p <- m Property
mp
                Property -> m Property
forall (m :: * -> *) a. Monad m => a -> m a
return (Gen a -> (a -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a) (Property -> a -> Property
forall a b. a -> b -> a
const Property
p)))

-- | The <https://en.wikipedia.org/wiki/Predicate_transformer_semantics#Weakest_preconditions weakest precondition>
--
-- > wp(x ← e, p)
--
-- can be expressed as in code as @wp e (\\x -> p)@.
wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b
wp :: m a -> (a -> PropertyM m b) -> PropertyM m b
wp m a
m a -> PropertyM m b
k = m a -> PropertyM m a
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
run m a
m PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> PropertyM m b
k

-- | Quantification in monadic properties to 'pick', with a notation similar to
-- 'forAll'. __Note__: values generated by 'forAllM' do not shrink.

forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b
forAllM :: Gen a -> (a -> PropertyM m b) -> PropertyM m b
forAllM Gen a
gen a -> PropertyM m b
k = Gen a -> PropertyM m a
forall (m :: * -> *) a. (Monad m, Show a) => Gen a -> PropertyM m a
pick Gen a
gen PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> PropertyM m b
k

-- | Allows making observations about the test data:
--
-- @
-- monitor ('collect' e)
-- @
--
-- collects the distribution of value of @e@.
--
-- @
-- monitor ('counterexample' "Failure!")
-- @
--
-- Adds @"Failure!"@ to the counterexamples.
monitor :: Monad m => (Property -> Property) -> PropertyM m ()
monitor :: (Property -> Property) -> PropertyM m ()
monitor Property -> Property
f = ((() -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m ()
forall (m :: * -> *) a.
((a -> Gen (m Property)) -> Gen (m Property)) -> PropertyM m a
MkPropertyM (\() -> Gen (m Property)
k -> (Property -> Property
f (Property -> Property) -> m Property -> m Property
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`) (m Property -> m Property) -> Gen (m Property) -> Gen (m Property)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (() -> Gen (m Property)
k ()))

-- run functions

monadic :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property
monadic :: (m Property -> Property) -> PropertyM m a -> Property
monadic m Property -> Property
runner PropertyM m a
m = Gen Property -> Property
forall prop. Testable prop => prop -> Property
property ((m Property -> Property) -> Gen (m Property) -> Gen Property
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m Property -> Property
runner (PropertyM m a -> Gen (m Property)
forall a (m :: * -> *).
(Testable a, Monad m) =>
PropertyM m a -> Gen (m Property)
monadic' PropertyM m a
m))

monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property)
monadic' :: PropertyM m a -> Gen (m Property)
monadic' (MkPropertyM (a -> Gen (m Property)) -> Gen (m Property)
m) = (a -> Gen (m Property)) -> Gen (m Property)
m (\a
prop -> m Property -> Gen (m Property)
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Property
forall prop. Testable prop => prop -> Property
property a
prop)))

-- | Runs the property monad for 'IO'-computations.
--
-- @
-- prop_cat msg = monadicIO $ do
--   (exitCode, stdout, _) \<- run ('System.Process.readProcessWithExitCode' "cat" [] msg)
--
--   pre ('System.Exit.ExitSuccess' == exitCode)
--
--   assert (stdout == msg)
-- @
--
-- >>> quickCheck prop_cat
-- +++ OK, passed 100 tests.
--
monadicIO :: Testable a => PropertyM IO a -> Property
monadicIO :: PropertyM IO a -> Property
monadicIO = (IO Property -> Property) -> PropertyM IO a -> Property
forall a (m :: * -> *).
(Testable a, Monad m) =>
(m Property -> Property) -> PropertyM m a -> Property
monadic IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty

#ifndef NO_ST_MONAD
-- | Runs the property monad for 'ST'-computations.
--
-- @
-- -- Your mutable sorting algorithm here
-- sortST :: Ord a => [a] -> 'Control.Monad.ST.ST' s (MVector s a)
-- sortST = 'Data.Vector.thaw' . 'Data.Vector.fromList' . 'Data.List.sort'
--
-- prop_sortST xs = monadicST $ do
--   sorted  \<- run ('Data.Vector.freeze' =<< sortST xs)
--   assert ('Data.Vector.toList' sorted == sort xs)
-- @
--
-- >>> quickCheck prop_sortST
-- +++ OK, passed 100 tests.
--
monadicST :: Testable a => (forall s. PropertyM (ST s) a) -> Property
monadicST :: (forall s. PropertyM (ST s) a) -> Property
monadicST forall s. PropertyM (ST s) a
m = Gen Property -> Property
forall prop. Testable prop => prop -> Property
property ((forall s. Gen (ST s Property)) -> Gen Property
forall a. (forall s. Gen (ST s a)) -> Gen a
runSTGen (PropertyM (ST s) a -> Gen (ST s Property)
forall a (m :: * -> *).
(Testable a, Monad m) =>
PropertyM m a -> Gen (m Property)
monadic' PropertyM (ST s) a
forall s. PropertyM (ST s) a
m))

runSTGen :: (forall s. Gen (ST s a)) -> Gen a
runSTGen :: (forall s. Gen (ST s a)) -> Gen a
runSTGen forall s. Gen (ST s a)
f = do
  Capture forall a. Gen a -> a
eval <- Gen Capture
capture
  a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ((forall s. ST s a) -> a
forall a. (forall s. ST s a) -> a
runST (Gen (ST s a) -> ST s a
forall a. Gen a -> a
eval Gen (ST s a)
forall s. Gen (ST s a)
f))
#endif

--------------------------------------------------------------------------
-- the end.