diff options
Diffstat (limited to 'testsuite/tests/lib/Concurrent')
| -rw-r--r-- | testsuite/tests/lib/Concurrent/4876.hs | 19 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/4876.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/Chan001.hs | 109 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/Chan001.stdout | 3 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/MVar001.hs | 148 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/MVar001.stdout | 6 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/Makefile | 3 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/QSem001.hs | 93 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/QSem001.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/QSemN001.hs | 96 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/QSemN001.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/SampleVar001.hs | 132 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/SampleVar001.stdout | 6 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/ThreadDelay001.hs | 26 | ||||
| -rw-r--r-- | testsuite/tests/lib/Concurrent/all.T | 10 |
15 files changed, 656 insertions, 0 deletions
diff --git a/testsuite/tests/lib/Concurrent/4876.hs b/testsuite/tests/lib/Concurrent/4876.hs new file mode 100644 index 0000000000..68c2a871b8 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/4876.hs @@ -0,0 +1,19 @@ +import System.Random +import Control.Concurrent.SampleVar +import Control.Concurrent +import Control.Monad + +produce, consume :: SampleVar Int -> IO () +produce svar = do + b <- isEmptySampleVar svar + if b then writeSampleVar svar 3 else return () + +consume svar = readSampleVar svar >>= print + +main = do + svar <- newEmptySampleVar + m <- newEmptyMVar + forkIO $ consume svar >> putMVar m () + threadDelay 100000 -- 100 ms + produce svar + takeMVar m -- deadlocked before the fix in #4876 diff --git a/testsuite/tests/lib/Concurrent/4876.stdout b/testsuite/tests/lib/Concurrent/4876.stdout new file mode 100644 index 0000000000..00750edc07 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/4876.stdout @@ -0,0 +1 @@ +3 diff --git a/testsuite/tests/lib/Concurrent/Chan001.hs b/testsuite/tests/lib/Concurrent/Chan001.hs new file mode 100644 index 0000000000..e4b668ac48 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/Chan001.hs @@ -0,0 +1,109 @@ +import Debug.QuickCheck
+import System.IO.Unsafe
+import Control.Concurrent.Chan
+import Control.Concurrent
+import Control.Monad
+
+data Action = NewChan | ReadChan | WriteChan Int | IsEmptyChan | ReturnInt Int
+ | ReturnBool Bool
+ deriving (Eq,Show)
+
+
+main = do
+ t <- myThreadId
+ forkIO (threadDelay 1000000 >> killThread t)
+ -- just in case we deadlock
+ testChan
+
+testChan :: IO ()
+testChan = do
+ quickCheck prop_NewIs_NewRet
+ quickCheck prop_NewWriteIs_NewRet
+ quickCheck prop_NewWriteRead_NewRet
+
+
+prop_NewIs_NewRet =
+ [NewChan,IsEmptyChan] =^ [NewChan,ReturnBool True]
+
+prop_NewWriteIs_NewRet n =
+ [NewChan,WriteChan n,IsEmptyChan] =^ [NewChan,WriteChan n,ReturnBool False]
+
+prop_NewWriteRead_NewRet n =
+ [NewChan,WriteChan n,ReadChan] =^ [NewChan,ReturnInt 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)
+ NewChan -> newChan >>= \chan -> perform' chan as
+ _ -> error $ "Please use NewChan as first action"
+
+
+perform' :: Chan Int -> [Action] -> IO ([Bool],[Int])
+perform' _ [] = return ([],[])
+
+perform' chan (a:as) =
+ case a of
+ ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform' chan as)
+ ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform' chan as)
+ ReadChan -> liftM2 (\v (b,l) -> (b,v:l)) (readChan chan)
+ (perform' chan as)
+ WriteChan n -> writeChan chan n >> perform' chan as
+ IsEmptyChan -> liftM2 (\v (b,l) -> (v:b,l)) (isEmptyChan chan)
+ (perform' chan as)
+ _ -> error $ "If you want to use " ++ show a
+ ++ " please use the =^ operator"
+
+
+actions :: Gen [Action]
+actions =
+ liftM (NewChan:) (actions' 0)
+
+
+actions' :: Int -> Gen [Action]
+actions' contents =
+ oneof ([return [],
+ liftM (IsEmptyChan:) (actions' contents),
+ liftM2 (:) (liftM WriteChan arbitrary) (actions' (contents+1))]
+ ++
+ if contents==0
+ then []
+ else [liftM (ReadChan:) (actions' (contents-1))])
+
+
+(=^) :: [Action] -> [Action] -> Property
+c =^ c' =
+ forAll (actions' (delta 0 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 0 (pref++c)))
+ (\suff -> observe c pref suff ==
+ observe c' pref suff))
+ where observe x pref suff = unsafePerformIO (perform (pref++x++suff))
+
+
+delta :: Int -> [Action] -> Int
+delta i [] = i
+
+delta i (ReturnInt _:as) = delta i as
+
+delta i (ReturnBool _:as) = delta i as
+
+delta _ (NewChan:as) = delta 0 as
+
+delta i (WriteChan _:as) = delta (i+1) as
+
+delta i (ReadChan:as) = delta (if i==0
+ then error "read on empty Chan"
+ else i-1) as
+
+delta i (IsEmptyChan:as) = delta i as
diff --git a/testsuite/tests/lib/Concurrent/Chan001.stdout b/testsuite/tests/lib/Concurrent/Chan001.stdout new file mode 100644 index 0000000000..53bfa8a381 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/Chan001.stdout @@ -0,0 +1,3 @@ +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. 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
diff --git a/testsuite/tests/lib/Concurrent/MVar001.stdout b/testsuite/tests/lib/Concurrent/MVar001.stdout new file mode 100644 index 0000000000..65be56c733 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/MVar001.stdout @@ -0,0 +1,6 @@ +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. diff --git a/testsuite/tests/lib/Concurrent/Makefile b/testsuite/tests/lib/Concurrent/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/lib/Concurrent/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/lib/Concurrent/QSem001.hs b/testsuite/tests/lib/Concurrent/QSem001.hs new file mode 100644 index 0000000000..1f255997e7 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/QSem001.hs @@ -0,0 +1,93 @@ +import Debug.QuickCheck
+import System.IO.Unsafe
+import Control.Concurrent.QSem
+import Control.Concurrent
+import Control.Monad
+
+
+main = do
+ t <- myThreadId
+ forkIO (threadDelay 1000000 >> killThread t)
+ -- just in case we deadlock
+ testQSem
+
+data Action = NewQSem Int | SignalQSem | WaitQSem
+ deriving (Eq,Show)
+
+
+testQSem :: IO ()
+testQSem = do
+ quietCheck prop_SignalWait
+ quietCheck prop_WaitSignal
+
+quietCheck = check defaultConfig{configEvery = \n args -> ""}
+
+prop_SignalWait n =
+ n>=0 ==> [NewQSem n,SignalQSem,WaitQSem] =^ [NewQSem n]
+
+prop_WaitSignal n =
+ n>=1 ==> [NewQSem n,WaitQSem,SignalQSem] =^ [NewQSem n]
+
+
+perform :: [Action] -> IO ()
+perform [] = return ()
+
+perform (a:as) =
+ case a of
+ NewQSem n -> newQSem n >>= \qs -> perform' qs as
+ _ -> error $ "Please use NewQSem as first action" ++ show a
+
+
+perform' :: QSem -> [Action] -> IO ()
+perform' _ [] = return ()
+
+perform' qs (a:as) =
+ case a of
+ SignalQSem -> signalQSem qs >> perform' qs as
+ WaitQSem -> waitQSem qs >> perform' qs as
+ _ -> error $ "If you want to use " ++ show a
+ ++ " please use the =^ operator"
+
+
+actions :: Gen [Action]
+actions = do
+ i <- arbitrary
+ liftM (NewQSem i:) (actions' i)
+
+
+actions' :: Int -> Gen [Action]
+actions' quantity =
+ oneof ([return [],
+ liftM (SignalQSem:) (actions' (quantity+1))] ++
+ if quantity<=0
+ then []
+ else [liftM (WaitQSem:) (actions' (quantity-1))])
+
+
+(=^) :: [Action] -> [Action] -> Property
+c =^ c' =
+ forAll (actions' (delta 0 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 0 (pref++c)))
+ (\suff -> observe c pref suff ==
+ observe c' pref suff))
+ where observe x pref suff = unsafePerformIO (perform (pref++x++suff))
+
+
+delta :: Int -> [Action] -> Int
+delta i [] = i
+
+delta _ (NewQSem i:as) = delta i as
+
+delta i (SignalQSem:as) = delta (i+1) as
+
+delta i (WaitQSem:as) = delta (if i<=0
+ then error "wait on 'empty' QSem"
+ else i-1) as
+
diff --git a/testsuite/tests/lib/Concurrent/QSem001.stdout b/testsuite/tests/lib/Concurrent/QSem001.stdout new file mode 100644 index 0000000000..7288d19270 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/QSem001.stdout @@ -0,0 +1,2 @@ +OK, passed 100 tests. +OK, passed 100 tests. diff --git a/testsuite/tests/lib/Concurrent/QSemN001.hs b/testsuite/tests/lib/Concurrent/QSemN001.hs new file mode 100644 index 0000000000..c31d6a6964 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/QSemN001.hs @@ -0,0 +1,96 @@ +import Debug.QuickCheck
+import System.IO.Unsafe
+import Control.Concurrent.QSemN
+import Control.Concurrent
+import Control.Monad
+
+
+main = do
+ t <- myThreadId
+ forkIO (threadDelay 1000000 >> killThread t)
+ -- just in case we deadlock
+ testQSemN
+
+data Action = NewQSemN Int | SignalQSemN Int | WaitQSemN Int
+ deriving (Eq,Show)
+
+
+testQSemN :: IO ()
+testQSemN = do
+ quietCheck prop_SignalWait
+ quietCheck prop_WaitSignal
+
+quietCheck = check defaultConfig{configEvery = \n args -> ""}
+
+
+prop_SignalWait l m n = l+m>=n ==>
+ [NewQSemN l,SignalQSemN m,WaitQSemN n] =^ [NewQSemN (l+m-n)]
+
+prop_WaitSignal l m n = l>=m ==>
+ [NewQSemN l,WaitQSemN m,SignalQSemN n] =^ [NewQSemN (l-m+n)]
+
+
+perform :: [Action] -> IO [Int]
+perform [] = return []
+
+perform (a:as) =
+ case a of
+ NewQSemN n -> newQSemN n >>= \qs -> perform' qs as
+ _ -> error $ "Please use NewQSemN as first action" ++ show a
+
+
+perform' :: QSemN -> [Action] -> IO [Int]
+perform' _ [] = return []
+
+perform' qs (a:as) =
+ case a of
+ SignalQSemN n -> signalQSemN qs n >> perform' qs as
+ WaitQSemN n -> waitQSemN qs n >> perform' qs as
+ _ -> error $ "If you want to use " ++ show a
+ ++ " please use the =^ operator"
+
+
+actions :: Gen [Action]
+actions = do
+ i <- arbitrary
+ liftM (NewQSemN i:) (actions' i)
+
+
+actions' :: Int -> Gen [Action]
+actions' quantity =
+ oneof ([return [],
+ do i<- choose (0,maxBound)
+ liftM (SignalQSemN i:) (actions' (quantity+i))] ++
+ if quantity<=0
+ then []
+ else [do i<- choose (0,quantity)
+ liftM (WaitQSemN i:) (actions' (quantity-i))])
+
+
+(=^) :: [Action] -> [Action] -> Property
+c =^ c' =
+ forAll (actions' (delta 0 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 0 (pref++c)))
+ (\suff -> observe c pref suff ==
+ observe c' pref suff))
+ where observe x pref suff = unsafePerformIO (perform (pref++x++suff))
+
+
+delta :: Int -> [Action] -> Int
+delta i [] = i
+
+delta _ (NewQSemN i:as) = delta i as
+
+delta i (SignalQSemN n:as) = delta (i+n) as
+
+delta i (WaitQSemN n:as) = delta (if i<n
+ then error "wait on 'empty' QSemN"
+ else i-n) as
+
diff --git a/testsuite/tests/lib/Concurrent/QSemN001.stdout b/testsuite/tests/lib/Concurrent/QSemN001.stdout new file mode 100644 index 0000000000..7288d19270 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/QSemN001.stdout @@ -0,0 +1,2 @@ +OK, passed 100 tests. +OK, passed 100 tests. diff --git a/testsuite/tests/lib/Concurrent/SampleVar001.hs b/testsuite/tests/lib/Concurrent/SampleVar001.hs new file mode 100644 index 0000000000..def86c5d54 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/SampleVar001.hs @@ -0,0 +1,132 @@ +-------------------------------------------------------------------------------
+-- Module : SampleVarTest
+-------------------------------------------------------------------------------
+
+import Debug.QuickCheck
+import System.IO.Unsafe
+import Control.Concurrent
+import Control.Concurrent.SampleVar
+import Control.Monad
+
+
+data Action = NewEmptySampleVar | NewSampleVar Int | EmptySampleVar
+ | ReadSampleVar | WriteSampleVar Int | IsEmptySampleVar
+ | ReturnInt Int | ReturnBool Bool
+ deriving (Eq,Show)
+
+
+main = do
+ t <- myThreadId
+ forkIO (threadDelay 1000000 >> killThread t)
+ -- just in case we deadlock
+ testSampleVar
+
+testSampleVar :: IO ()
+testSampleVar = do
+ quickCheck prop_NewEIs_NewERet
+ quickCheck prop_NewIs_NewRet
+ quickCheck prop_NewRead_NewRet
+ quickCheck prop_NewEWriteRead_NewERet
+ quickCheck prop_WriteEmpty_Empty
+ quickCheck prop_WriteRead_Ret
+
+
+
+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)
+ NewEmptySampleVar -> newEmptySampleVar >>= \sv -> perform' sv as
+ NewSampleVar n -> newSampleVar n >>= \sv -> perform' sv as
+
+
+perform' :: SampleVar Int -> [Action] -> IO ([Bool],[Int])
+perform' _ [] = return ([],[])
+
+perform' sv (a:as) =
+ case a of
+ ReturnInt v -> liftM (\(b,l) -> (b,v:l)) (perform' sv as)
+ ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform' sv as)
+ EmptySampleVar -> emptySampleVar sv >> perform' sv as
+ ReadSampleVar -> liftM2 (\v (b,l) -> (b,v:l)) (readSampleVar sv)
+ (perform' sv as)
+ WriteSampleVar n -> writeSampleVar sv n >> perform' sv as
+ IsEmptySampleVar -> liftM2 (\v (b,l) -> (v:b,l)) (isEmptySampleVar sv)
+ (perform' sv as)
+
+
+actions :: Gen [Action]
+actions = do
+ oneof [liftM (NewEmptySampleVar:) (actions' True),
+ liftM2 (:) (liftM NewSampleVar arbitrary) (actions' False)]
+
+
+actions' :: Bool -> Gen [Action]
+actions' empty =
+ oneof ([return [],
+ liftM (IsEmptySampleVar:) (actions' empty),
+ liftM (EmptySampleVar:) (actions' True),
+ liftM2 (:) (liftM WriteSampleVar arbitrary) (actions' False)] ++
+ if empty
+ then []
+ else [liftM (ReadSampleVar:) (actions' True)])
+
+
+(=^) :: [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 _ (NewEmptySampleVar:as) = delta True as
+
+delta _ (NewSampleVar _:as) = delta False as
+
+delta _ (EmptySampleVar:as) = delta True as
+
+delta b (ReadSampleVar:as) = delta (if b
+ then error "read on empty SampleVar"
+ else True) as
+delta _ (WriteSampleVar _:as) = delta False as
+
+delta b (IsEmptySampleVar:as) = delta b as
+
+
+prop_NewEIs_NewERet =
+ [NewEmptySampleVar,IsEmptySampleVar] =^ [NewEmptySampleVar,ReturnBool True]
+
+prop_NewIs_NewRet n =
+ [NewSampleVar n,IsEmptySampleVar] =^ [NewSampleVar n,ReturnBool False]
+
+prop_NewRead_NewRet n =
+ [NewSampleVar n,ReadSampleVar] =^ [NewEmptySampleVar,ReturnInt n]
+
+prop_NewEWriteRead_NewERet n =
+ [NewEmptySampleVar,WriteSampleVar n,ReadSampleVar] =^
+ [NewEmptySampleVar,ReturnInt n]
+
+prop_WriteEmpty_Empty n =
+ [WriteSampleVar n,EmptySampleVar] ^=^ [EmptySampleVar]
+
+prop_WriteRead_Ret n =
+ [WriteSampleVar n,ReadSampleVar] ^=^ [EmptySampleVar,ReturnInt n]
diff --git a/testsuite/tests/lib/Concurrent/SampleVar001.stdout b/testsuite/tests/lib/Concurrent/SampleVar001.stdout new file mode 100644 index 0000000000..65be56c733 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/SampleVar001.stdout @@ -0,0 +1,6 @@ +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. +0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests. diff --git a/testsuite/tests/lib/Concurrent/ThreadDelay001.hs b/testsuite/tests/lib/Concurrent/ThreadDelay001.hs new file mode 100644 index 0000000000..c60f997039 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/ThreadDelay001.hs @@ -0,0 +1,26 @@ + +-- Test that threadDelay actually sleeps for (at least) as long as we +-- ask it + +module Main (main) where + +import Control.Concurrent +import Control.Monad +import System.Time + +main = mapM_ delay (0 : take 11 (iterate (*5) 1)) + +delay n = do + tS <- getClockTime + threadDelay n + tE <- getClockTime + + let req = fromIntegral n * 10 ^ (6 :: Int) + obs = case normalizeTimeDiff (diffClockTimes tE tS) of + TimeDiff 0 0 0 0 0 s ps -> 10^12 * fromIntegral s + ps + diff = obs - req + diff' :: Double + diff' = fromIntegral diff / 10^(12 :: Int) + + when (obs < req) $ print (tS, tE, req, obs, diff, diff') + diff --git a/testsuite/tests/lib/Concurrent/all.T b/testsuite/tests/lib/Concurrent/all.T new file mode 100644 index 0000000000..004c6a1226 --- /dev/null +++ b/testsuite/tests/lib/Concurrent/all.T @@ -0,0 +1,10 @@ +setTestOpts(only_compiler_types(['ghc'])) + +test('SampleVar001', reqlib('QuickCheck'), compile_and_run, ['-package QuickCheck']) +test('4876', reqlib('random'), compile_and_run, ['']) # another SampleVar test + +test('Chan001', reqlib('QuickCheck'), compile_and_run, ['-package QuickCheck']) +test('MVar001', reqlib('QuickCheck'), compile_and_run, ['-package QuickCheck']) +test('QSemN001', reqlib('QuickCheck'), compile_and_run, ['-package QuickCheck']) +test('QSem001', reqlib('QuickCheck'), compile_and_run, ['-package QuickCheck']) +test('ThreadDelay001', normal, compile_and_run, ['']) |