diff options
| author | David Terei <davidterei@gmail.com> | 2011-07-20 11:09:03 -0700 |
|---|---|---|
| committer | David Terei <davidterei@gmail.com> | 2011-07-20 11:26:35 -0700 |
| commit | 16514f272fb42af6e9c7674a9bd6c9dce369231f (patch) | |
| tree | e4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/lib/Concurrent/MVar001.hs | |
| parent | ebd422aed41048476aa61dd4c520d43becd78682 (diff) | |
| download | haskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz | |
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/lib/Concurrent/MVar001.hs')
| -rw-r--r-- | testsuite/tests/lib/Concurrent/MVar001.hs | 148 |
1 files changed, 148 insertions, 0 deletions
diff --git a/testsuite/tests/lib/Concurrent/MVar001.hs b/testsuite/tests/lib/Concurrent/MVar001.hs new file mode 100644 index 0000000000..f787470c51 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/MVar001.hs @@ -0,0 +1,148 @@ +import Debug.QuickCheck
+import System.IO.Unsafe
+import Control.Concurrent.MVar
+import Control.Concurrent
+import Control.Monad
+
+
+data Action = NewEmptyMVar | NewMVar Int | TakeMVar | ReadMVar | PutMVar Int
+ | SwapMVar Int | IsEmptyMVar | ReturnInt Int | ReturnBool Bool
+ deriving (Eq,Show)
+
+main = do
+ t <- myThreadId
+ forkIO (threadDelay 1000000 >> killThread t)
+ -- just in case we deadlock
+ testMVar
+
+testMVar :: IO ()
+testMVar = do
+ quickCheck prop_NewEIs_NewERet
+ quickCheck prop_NewIs_NewRet
+ quickCheck prop_NewTake_NewRet
+ quickCheck prop_NewEPutTake_NewERet
+ quickCheck prop_NewRead_NewRet
+ quickCheck prop_NewSwap_New
+
+
+prop_NewEIs_NewERet =
+ [NewEmptyMVar,IsEmptyMVar] =^ [NewEmptyMVar,ReturnBool True]
+
+prop_NewIs_NewRet n =
+ [NewMVar n,IsEmptyMVar] =^ [NewMVar n,ReturnBool False]
+
+prop_NewTake_NewRet n =
+ [NewMVar n,TakeMVar] =^ [NewEmptyMVar,ReturnInt n]
+
+prop_NewEPutTake_NewERet n =
+ [NewEmptyMVar,PutMVar n,TakeMVar] =^
+ [NewEmptyMVar,ReturnInt n]
+
+prop_NewRead_NewRet n =
+ [NewMVar n,ReadMVar] =^ [NewMVar n,ReturnInt n]
+
+prop_NewSwap_New m n =
+ [NewMVar m,SwapMVar n] =^ [NewMVar n]
+
+
+perform :: [Action] -> IO ([Bool],[Int])
+perform [] = return ([],[])
+
+perform (a:as) =
+ case a of
+ ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform as)
+ ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform as)
+ NewEmptyMVar -> newEmptyMVar >>= \mv -> perform' mv as
+ NewMVar n -> newMVar n >>= \mv -> perform' mv as
+ _ -> error $ "Please use NewMVar or NewEmptyMVar as first "
+ ++ "action"
+
+
+perform' :: MVar Int -> [Action] -> IO ([Bool],[Int])
+perform' _ [] = return ([],[])
+
+perform' mv (a:as) =
+ case a of
+ ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform' mv as)
+ ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform' mv as)
+ TakeMVar -> liftM2 (\v (b,l) -> (b,v:l)) (takeMVar mv)
+ (perform' mv as)
+ ReadMVar -> liftM2 (\v (b,l) -> (b,v:l)) (readMVar mv)
+ (perform' mv as)
+ PutMVar n -> putMVar mv n >> perform' mv as
+ SwapMVar n -> swapMVar mv n >> perform' mv as
+ IsEmptyMVar -> liftM2 (\v (b,l) -> (v:b,l)) (isEmptyMVar mv)
+ (perform' mv as)
+ _ -> error $ "If you want to use " ++ show a
+ ++ " please use the =^ operator"
+
+
+actions :: Gen [Action]
+actions = do
+ oneof [liftM (NewEmptyMVar:) (actions' True),
+ liftM2 (:) (liftM NewMVar arbitrary) (actions' False)]
+
+
+actions' :: Bool -> Gen [Action]
+actions' empty =
+ oneof ([return [],
+ liftM (IsEmptyMVar:) (actions' empty)] ++
+ if empty
+ then [liftM2 (:) (liftM PutMVar arbitrary) (actions' False)]
+ else []
+ ++
+ if empty
+ then []
+ else [liftM (TakeMVar:) (actions' True)]
+ ++
+ if empty
+ then []
+ else [liftM (ReadMVar:) (actions' False)]
+ ++
+ if empty
+ then []
+ else [liftM2 (:) (liftM SwapMVar arbitrary) (actions' False)] )
+
+
+(=^) :: [Action] -> [Action] -> Property
+c =^ c' =
+ forAll (actions' (delta True c))
+ (\suff -> observe c suff == observe c' suff)
+ where observe x suff = unsafePerformIO (perform (x++suff))
+
+
+(^=^) :: [Action] -> [Action] -> Property
+c ^=^ c' =
+ forAll actions
+ (\pref -> forAll (actions' (delta True (pref++c)))
+ (\suff -> observe c pref suff ==
+ observe c' pref suff))
+ where observe x pref suff = unsafePerformIO (perform (pref++x++suff))
+
+
+delta :: Bool -> [Action] -> Bool
+delta b [] = b
+
+delta b (ReturnInt _:as) = delta b as
+
+delta b (ReturnBool _:as) = delta b as
+
+delta _ (NewEmptyMVar:as) = delta True as
+
+delta _ (NewMVar _:as) = delta False as
+
+delta b (TakeMVar:as) = delta (if b
+ then error "take on empty MVar"
+ else True) as
+
+delta b (ReadMVar:as) = delta (if b
+ then error "read on empty MVar"
+ else False) as
+
+delta _ (PutMVar _:as) = delta False as
+
+delta b (SwapMVar _:as) = delta (if b
+ then error "swap on empty MVar"
+ else False) as
+
+delta b (IsEmptyMVar:as) = delta b as
|