1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
{-# LANGUAGE Rank2Types #-}
-- | Allows testing of monadic values.
module Test.QuickCheck.Monadic where
--------------------------------------------------------------------------
-- imports
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
)
-- instance of monad transformer?
--------------------------------------------------------------------------
-- type PropertyM
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 }
-- should think about strictness/exceptions here
--assert :: Testable prop => prop -> PropertyM m ()
assert :: Monad m => Bool -> PropertyM m ()
assert b = MkPropertyM $ \k ->
if b
then k ()
else return (return (property False))
{-
let Prop p = property a in Monadic $ \k ->
do r <- p
case ok r of
Just True -> do m <- k ()
return (do p' <- m
return (r &&& p'))
_ -> return (return (property r))
-}
-- should think about strictness/exceptions here
pre :: Monad m => Bool -> PropertyM m ()
pre b = MkPropertyM $ \k ->
if b
then k ()
else return (return (property ()))
-- should be called lift?
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 ()))
-- run functions
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 :: Monad m => (m Property -> IO Property) -> PropertyM m a -> IO Property
monadicIO run (MkPropertyM m) =
do mp <- m (const (return (return (property True))))
run mp
-}
-- Can't make this work in any other way... :-(
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
}
--grab () = MkMonadS return (>>=)
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))
{-
monadicS :: MonadS m => ((forall s . m s Property) -> Property) -> (forall s . PropertyM (m s) a) -> Property
monadicS run mp = MkGen $ \r n ->
let MkGen g' = run (let MkPropertyM f = mp'
MkGen g = f (const (return (return (property True))))
in unIdM (g r n))
in g' undefined undefined
where
mp' = MkPropertyM (\k -> fmap MkIdM (unPropertyM mp (\a -> fmap unIdM (k a))))
-}
{-
-- does not compile with GHC 6.6
imperative :: (forall s. PropertyM (ST s) a) -> Property
imperative m = MkGen $ \r n ->
let MkPropertyM f = m
MkGen g = f (const (return (return (property True))))
MkGen q = runST (g r n)
in q undefined undefined
-}
--------------------------------------------------------------------------
-- the end.
|
