diff --git a/Control/Monad/Conc/Fixed.hs b/Control/Monad/Conc/Fixed.hs index e92ff53..144947c 100755 --- a/Control/Monad/Conc/Fixed.hs +++ b/Control/Monad/Conc/Fixed.hs @@ -1,8 +1,8 @@ -- | Concurrent monads with a fixed scheduler. module Control.Monad.Conc.Fixed - ( module Control.Monad.Conc.Fixed.IO + ( module Control.Monad.Conc.Fixed.ST , module Control.Monad.Conc.Fixed.Schedulers ) where -import Control.Monad.Conc.Fixed.IO +import Control.Monad.Conc.Fixed.ST import Control.Monad.Conc.Fixed.Schedulers diff --git a/Control/Monad/Conc/SCT.hs b/Control/Monad/Conc/SCT.hs index f0cde2a..85450df 100644 --- a/Control/Monad/Conc/SCT.hs +++ b/Control/Monad/Conc/SCT.hs @@ -83,15 +83,15 @@ data Decision = -- The initial state for each run is the final state of the last run, -- so it is important that the scheduler actually maintain some -- internal state, or all the results will be identical. -runSCT :: SCTScheduler s -> s -> Int -> (forall t. Conc t a) -> IO [(Maybe a, SCTTrace)] -runSCT _ _ 0 _ = return [] -runSCT sched s n c = do - (res, (s', strace), ttrace) <- runConc' sched (s, [(Start 0, [])]) c - rest <- runSCT sched s' (n - 1) c - return $ (res, zipWith mktrace strace ttrace) : rest +runSCT :: SCTScheduler s -> s -> Int -> (forall t. Conc t a) -> [(Maybe a, SCTTrace)] +runSCT _ _ 0 _ = [] +runSCT sched s n c = (res, zipWith mktrace strace ttrace) : rest where - where - mktrace (d, alts) (_, act) = (d, alts, act) + (res, (s', strace), ttrace) = runConc' sched (s, [(Start 0, [])]) c + + rest = runSCT sched s' (n - 1) c + + mktrace (d, alts) (_, act) = (d, alts, act) -- | A simple pre-emptive random scheduler. sctRandom :: RandomGen g => SCTScheduler g diff --git a/Tests.hs b/Tests.hs index 379c74f..b890068 100644 --- a/Tests.hs +++ b/Tests.hs @@ -11,9 +11,8 @@ main = do if and results then exitSuccess else exitFailure runTest :: Bool -> Test -> IO Bool -runTest verbose (Test {name = name, result = result}) = do - res <- result - case res of +runTest verbose (Test {name = name, result = result}) = + case result of Pass -> when verbose (putStrLn $ "\27[32m[pass]\27[0m " ++ name) >> return True Fail str -> putStrLn ("\27[31m[fail]\27[0m " ++ name ++ ": " ++ str) >> return False Error str -> putStrLn ("\27[35m[error]\27[0m " ++ name ++ ": " ++ str) >> return False diff --git a/Tests/Utils.hs b/Tests/Utils.hs index 98dc575..08dab42 100644 --- a/Tests/Utils.hs +++ b/Tests/Utils.hs @@ -1,7 +1,6 @@ {-# LANGUAGE RankNTypes #-} module Tests.Utils where -import Control.Applicative ((<$>)) import Control.Monad.Conc.Fixed (Conc) import Control.Monad.Conc.SCT (runSCT, sctRandom) import Data.List (group, sort) @@ -9,23 +8,23 @@ import Data.Maybe (isJust, isNothing) import System.Random (mkStdGen) -- Couldn't get Cabal's detailed tests to work, hence this approach. -data Test = Test { name :: String, result :: IO Result } +data Test = Test { name :: String, result :: Result } data Result = Pass | Fail String | Error String -- | Test that a predicate holds over the results of a concurrent -- computation. -testPred :: ([Maybe a] -> Result) -> Int -> (forall t. Conc t a) -> IO Result -testPred predicate num conc = predicate . map fst <$> runSCT sctRandom (mkStdGen 0) num conc +testPred :: ([Maybe a] -> Result) -> Int -> (forall t. Conc t a) -> Result +testPred predicate num conc = predicate . map fst $ runSCT sctRandom (mkStdGen 0) num conc -- | Test that a concurrent computation is free of deadlocks. -testDeadlockFree :: Int -> (forall t. Conc t a) -> IO Result +testDeadlockFree :: Int -> (forall t. Conc t a) -> Result testDeadlockFree = testPred predicate where predicate xs = case filter isNothing xs of [] -> Pass ds -> Fail $ "Found " ++ show (length ds) ++ "/" ++ show (length xs) ++ " deadlocking schedules." -- | Test that a concurrent computation always deadlocks. -testDeadlocks :: Int -> (forall t. Conc t a) -> IO Result +testDeadlocks :: Int -> (forall t. Conc t a) -> Result testDeadlocks = testPred predicate where predicate xs = case filter isJust xs of [] -> Pass @@ -33,7 +32,7 @@ testDeadlocks = testPred predicate where -- | Test that a concurrent computation always returns the same -- result. -testAlwaysSame :: (Eq a, Ord a) => Int -> (forall t. Conc t a) -> IO Result +testAlwaysSame :: (Eq a, Ord a) => Int -> (forall t. Conc t a) -> Result testAlwaysSame = testPred predicate where predicate xs = case group $ sort xs of [] -> Pass @@ -41,11 +40,7 @@ testAlwaysSame = testPred predicate where gs -> Fail $ "Found " ++ show (length gs) ++ " distinct results." -- | Invert the result of a test. -testNot :: String -> IO Result -> IO Result -testNot err old = do - res <- old - return $ - case res of - Pass -> Fail err - Fail _ -> Pass - e -> e +testNot :: String -> Result -> Result +testNot err Pass = Fail err +testNot _ (Fail _) = Pass +testNot _ err = err diff --git a/monad-conc.cabal b/monad-conc.cabal index 9688d17..f178212 100755 --- a/monad-conc.cabal +++ b/monad-conc.cabal @@ -42,6 +42,7 @@ test-suite tests build-depends: monad-conc , base , containers + , monad-st , mtl , random , transformers