Copy tests from GHC testsuite; part of #1161.

libraries/base/tests/4006.hs

+import System.Process
+
+testUnicode :: String -> IO String
+testUnicode str = readProcess "printf" ["%s", str] ""
+
+main = do
+    testUnicode "It works here" >>= putStrLn
+    testUnicode "А здесь сломалось" >>= putStrLn

libraries/base/tests/4006.stdout

+It works here
+А здесь сломалось

libraries/base/tests/Concurrent/4876.hs

+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

libraries/base/tests/Concurrent/4876.stdout

+3

libraries/base/tests/Concurrent/Chan001.hs

+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

libraries/base/tests/Concurrent/Chan001.stdout

+0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests.
+0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests.
+0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests.

libraries/base/tests/Concurrent/MVar001.hs

+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

libraries/base/tests/Concurrent/MVar001.stdout

+0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests.
+0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests.
+0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests.
+0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests.
+0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests.
+0123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899OK, passed 100 tests.

libraries/base/tests/Concurrent/Makefile

+# This Makefile runs the tests using GHC's testsuite framework.  It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../../../../testsuite
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk

libraries/base/tests/Concurrent/QSem001.hs

+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
+

libraries/base/tests/Concurrent/QSem001.stdout

+OK, passed 100 tests.
+OK, passed 100 tests.

libraries/base/tests/Concurrent/QSemN001.hs

+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
+

libraries/base/tests/Concurrent/QSemN001.stdout

+OK, passed 100 tests.
+OK, passed 100 tests.

libraries/base/tests/Concurrent/SampleVar001.hs

+-------------------------------------------------------------------------------
+-- 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),