libraries/base/tests/Concurrent/Chan001.hs

   1 import Test.QuickCheck
   2 import System.IO.Unsafe
   3 import Control.Concurrent.Chan
   4 import Control.Concurrent
   5 import Control.Monad
   6
   7 data Action = NewChan | ReadChan | WriteChan Int | IsEmptyChan | ReturnInt Int
   8             | ReturnBool Bool
   9   deriving (Eq,Show)
  10
  11
  12 main = do
  13   t <- myThreadId
  14   forkIO (threadDelay 1000000 >> killThread t)
  15         -- just in case we deadlock
  16   testChan
  17
  18 testChan :: IO ()
  19 testChan = do
  20   quickCheck prop_NewIs_NewRet
  21   quickCheck prop_NewWriteIs_NewRet
  22   quickCheck prop_NewWriteRead_NewRet
  23
  24
  25 prop_NewIs_NewRet =
  26   [NewChan,IsEmptyChan] =^ [NewChan,ReturnBool True]
  27
  28 prop_NewWriteIs_NewRet n =
  29   [NewChan,WriteChan n,IsEmptyChan] =^ [NewChan,WriteChan n,ReturnBool False]
  30
  31 prop_NewWriteRead_NewRet n =
  32   [NewChan,WriteChan n,ReadChan] =^ [NewChan,ReturnInt n]
  33
  34
  35 perform :: [Action] -> IO ([Bool],[Int])
  36 perform [] = return ([],[])
  37
  38 perform (a:as) =
  39   case a of
  40     ReturnInt v  -> liftM (\(b,l) -> (b,v:l)) (perform as)
  41     ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform as)
  42     NewChan      -> newChan >>= \chan -> perform' chan as
  43     _            -> error $ "Please use NewChan as first action"
  44
  45
  46 perform' :: Chan Int -> [Action] -> IO ([Bool],[Int])
  47 perform' _ [] = return ([],[])
  48
  49 perform' chan (a:as) =
  50   case a of
  51     ReturnInt v  -> liftM (\(b,l) -> (b,v:l)) (perform' chan as)
  52     ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform' chan as)
  53     ReadChan     -> liftM2 (\v (b,l) -> (b,v:l)) (readChan chan)
  54                                 (perform' chan as)
  55     WriteChan n  -> writeChan chan n >> perform' chan as
  56     IsEmptyChan  -> liftM2 (\v (b,l) -> (v:b,l)) (isEmptyChan chan)
  57                                 (perform' chan as)
  58     _                -> error $ "If you want to use " ++ show a
  59                                 ++ " please use the =^ operator"
  60
  61
  62 actions :: Gen [Action]
  63 actions =
  64   liftM (NewChan:) (actions' 0)
  65
  66
  67 actions' :: Int -> Gen [Action]
  68 actions' contents =
  69   oneof ([return [],
  70           liftM (IsEmptyChan:) (actions' contents),
  71           liftM2 (:) (liftM WriteChan arbitrary) (actions' (contents+1))]
  72           ++
  73           if contents==0
  74              then []
  75              else [liftM (ReadChan:) (actions' (contents-1))])
  76
  77
  78 (=^) :: [Action] -> [Action] -> Property
  79 c =^ c' =
  80   forAll (actions' (delta 0 c))
  81          (\suff -> observe c suff == observe c' suff)
  82   where observe x suff = unsafePerformIO (perform (x++suff))
  83
  84
  85 (^=^) :: [Action] -> [Action] -> Property
  86 c ^=^ c' =
  87   forAll actions
  88          (\pref -> forAll (actions' (delta 0 (pref++c)))
  89                           (\suff -> observe c pref suff ==
  90                                       observe c' pref suff))
  91   where observe x pref suff = unsafePerformIO (perform (pref++x++suff))
  92
  93
  94 delta :: Int -> [Action] -> Int
  95 delta i [] = i
  96
  97 delta i (ReturnInt _:as) = delta i as
  98
  99 delta i (ReturnBool _:as) = delta i as
 100
 101 delta _ (NewChan:as) = delta 0 as
 102
 103 delta i (WriteChan _:as) = delta (i+1) as
 104
 105 delta i (ReadChan:as) = delta (if i==0
 106                                   then error "read on empty Chan"
 107                                   else i-1) as
 108
 109 delta i (IsEmptyChan:as) = delta i as