module Test.QuickCheck.Monadic where
import Test.QuickCheck.Gen
import Test.QuickCheck.Property
import Test.QuickCheck.Arbitrary
import Control.Monad
( liftM
)
import Control.Monad.ST
import System.IO.Unsafe
( unsafePerformIO
)
newtype PropertyM m a =
MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) }
instance Functor (PropertyM m) where
fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f))
instance Monad m => Monad (PropertyM m) where
return x = MkPropertyM (\k -> k x)
MkPropertyM m >>= f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k))
fail s = MkPropertyM (\k -> return (return (property result)))
where
result = failed result{ reason = s }
assert :: Monad m => Bool -> PropertyM m ()
assert b = MkPropertyM $ \k ->
if b
then k ()
else return (return (property False))
pre :: Monad m => Bool -> PropertyM m ()
pre b = MkPropertyM $ \k ->
if b
then k ()
else return (return (property ()))
run :: Monad m => m a -> PropertyM m a
run m = MkPropertyM (liftM (m >>=) . promote)
pick :: (Monad m, Show a) => Gen a -> PropertyM m a
pick gen = MkPropertyM $ \k ->
do a <- gen
mp <- k a
return (do p <- mp
return (forAll (return a) (const p)))
wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b
wp m k = run m >>= k
forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b
forAllM gen k = pick gen >>= k
monitor :: Monad m => (Property -> Property) -> PropertyM m ()
monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ()))
monadic :: Monad m => (m Property -> Property) -> PropertyM m a -> Property
monadic run (MkPropertyM m) =
do mp <- m (const (return (return (property True))))
run mp
monadicIO :: PropertyM IO a -> Property
monadicIO (MkPropertyM m) =
property $
unsafePerformIO `fmap`
m (const (return (return (property True))))
newtype IdM m s a = MkIdM { unIdM :: m s a }
data MonadS' m
= MkMonadS
{ ret :: forall a s . a -> m s a
, bin :: forall a b s . m s a -> (a -> m s b) -> m s b
}
class MonadS m where
return' :: a -> m s a
bind' :: m s a -> (a -> m s b) -> m s b
instance MonadS m => Monad (IdM m s) where
return = MkIdM . return'
MkIdM m >>= k = MkIdM (m `bind'` (unIdM . k))