mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-12-24 05:55:18 +03:00
Swap main Fixed implementation from IO to ST.
This commit is contained in:
parent
d215306911
commit
7e6fcd4a39
@ -1,8 +1,8 @@
|
|||||||
-- | Concurrent monads with a fixed scheduler.
|
-- | Concurrent monads with a fixed scheduler.
|
||||||
module Control.Monad.Conc.Fixed
|
module Control.Monad.Conc.Fixed
|
||||||
( module Control.Monad.Conc.Fixed.IO
|
( module Control.Monad.Conc.Fixed.ST
|
||||||
, module Control.Monad.Conc.Fixed.Schedulers
|
, module Control.Monad.Conc.Fixed.Schedulers
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.Conc.Fixed.IO
|
import Control.Monad.Conc.Fixed.ST
|
||||||
import Control.Monad.Conc.Fixed.Schedulers
|
import Control.Monad.Conc.Fixed.Schedulers
|
||||||
|
@ -83,14 +83,14 @@ data Decision =
|
|||||||
-- The initial state for each run is the final state of the last run,
|
-- The initial state for each run is the final state of the last run,
|
||||||
-- so it is important that the scheduler actually maintain some
|
-- so it is important that the scheduler actually maintain some
|
||||||
-- internal state, or all the results will be identical.
|
-- internal state, or all the results will be identical.
|
||||||
runSCT :: SCTScheduler s -> s -> Int -> (forall t. Conc t a) -> IO [(Maybe a, SCTTrace)]
|
runSCT :: SCTScheduler s -> s -> Int -> (forall t. Conc t a) -> [(Maybe a, SCTTrace)]
|
||||||
runSCT _ _ 0 _ = return []
|
runSCT _ _ 0 _ = []
|
||||||
runSCT sched s n c = do
|
runSCT sched s n c = (res, zipWith mktrace strace ttrace) : rest where
|
||||||
(res, (s', strace), ttrace) <- runConc' sched (s, [(Start 0, [])]) c
|
|
||||||
rest <- runSCT sched s' (n - 1) c
|
(res, (s', strace), ttrace) = runConc' sched (s, [(Start 0, [])]) c
|
||||||
return $ (res, zipWith mktrace strace ttrace) : rest
|
|
||||||
|
rest = runSCT sched s' (n - 1) c
|
||||||
|
|
||||||
where
|
|
||||||
mktrace (d, alts) (_, act) = (d, alts, act)
|
mktrace (d, alts) (_, act) = (d, alts, act)
|
||||||
|
|
||||||
-- | A simple pre-emptive random scheduler.
|
-- | A simple pre-emptive random scheduler.
|
||||||
|
5
Tests.hs
5
Tests.hs
@ -11,9 +11,8 @@ main = do
|
|||||||
if and results then exitSuccess else exitFailure
|
if and results then exitSuccess else exitFailure
|
||||||
|
|
||||||
runTest :: Bool -> Test -> IO Bool
|
runTest :: Bool -> Test -> IO Bool
|
||||||
runTest verbose (Test {name = name, result = result}) = do
|
runTest verbose (Test {name = name, result = result}) =
|
||||||
res <- result
|
case result of
|
||||||
case res of
|
|
||||||
Pass -> when verbose (putStrLn $ "\27[32m[pass]\27[0m " ++ name) >> return True
|
Pass -> when verbose (putStrLn $ "\27[32m[pass]\27[0m " ++ name) >> return True
|
||||||
Fail str -> putStrLn ("\27[31m[fail]\27[0m " ++ name ++ ": " ++ str) >> return False
|
Fail str -> putStrLn ("\27[31m[fail]\27[0m " ++ name ++ ": " ++ str) >> return False
|
||||||
Error str -> putStrLn ("\27[35m[error]\27[0m " ++ name ++ ": " ++ str) >> return False
|
Error str -> putStrLn ("\27[35m[error]\27[0m " ++ name ++ ": " ++ str) >> return False
|
||||||
|
@ -1,7 +1,6 @@
|
|||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
module Tests.Utils where
|
module Tests.Utils where
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
|
||||||
import Control.Monad.Conc.Fixed (Conc)
|
import Control.Monad.Conc.Fixed (Conc)
|
||||||
import Control.Monad.Conc.SCT (runSCT, sctRandom)
|
import Control.Monad.Conc.SCT (runSCT, sctRandom)
|
||||||
import Data.List (group, sort)
|
import Data.List (group, sort)
|
||||||
@ -9,23 +8,23 @@ import Data.Maybe (isJust, isNothing)
|
|||||||
import System.Random (mkStdGen)
|
import System.Random (mkStdGen)
|
||||||
|
|
||||||
-- Couldn't get Cabal's detailed tests to work, hence this approach.
|
-- 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
|
data Result = Pass | Fail String | Error String
|
||||||
|
|
||||||
-- | Test that a predicate holds over the results of a concurrent
|
-- | Test that a predicate holds over the results of a concurrent
|
||||||
-- computation.
|
-- computation.
|
||||||
testPred :: ([Maybe a] -> Result) -> Int -> (forall t. Conc t a) -> IO Result
|
testPred :: ([Maybe a] -> Result) -> Int -> (forall t. Conc t a) -> Result
|
||||||
testPred predicate num conc = predicate . map fst <$> runSCT sctRandom (mkStdGen 0) num conc
|
testPred predicate num conc = predicate . map fst $ runSCT sctRandom (mkStdGen 0) num conc
|
||||||
|
|
||||||
-- | Test that a concurrent computation is free of deadlocks.
|
-- | 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
|
testDeadlockFree = testPred predicate where
|
||||||
predicate xs = case filter isNothing xs of
|
predicate xs = case filter isNothing xs of
|
||||||
[] -> Pass
|
[] -> Pass
|
||||||
ds -> Fail $ "Found " ++ show (length ds) ++ "/" ++ show (length xs) ++ " deadlocking schedules."
|
ds -> Fail $ "Found " ++ show (length ds) ++ "/" ++ show (length xs) ++ " deadlocking schedules."
|
||||||
|
|
||||||
-- | Test that a concurrent computation always deadlocks.
|
-- | 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
|
testDeadlocks = testPred predicate where
|
||||||
predicate xs = case filter isJust xs of
|
predicate xs = case filter isJust xs of
|
||||||
[] -> Pass
|
[] -> Pass
|
||||||
@ -33,7 +32,7 @@ testDeadlocks = testPred predicate where
|
|||||||
|
|
||||||
-- | Test that a concurrent computation always returns the same
|
-- | Test that a concurrent computation always returns the same
|
||||||
-- result.
|
-- 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
|
testAlwaysSame = testPred predicate where
|
||||||
predicate xs = case group $ sort xs of
|
predicate xs = case group $ sort xs of
|
||||||
[] -> Pass
|
[] -> Pass
|
||||||
@ -41,11 +40,7 @@ testAlwaysSame = testPred predicate where
|
|||||||
gs -> Fail $ "Found " ++ show (length gs) ++ " distinct results."
|
gs -> Fail $ "Found " ++ show (length gs) ++ " distinct results."
|
||||||
|
|
||||||
-- | Invert the result of a test.
|
-- | Invert the result of a test.
|
||||||
testNot :: String -> IO Result -> IO Result
|
testNot :: String -> Result -> Result
|
||||||
testNot err old = do
|
testNot err Pass = Fail err
|
||||||
res <- old
|
testNot _ (Fail _) = Pass
|
||||||
return $
|
testNot _ err = err
|
||||||
case res of
|
|
||||||
Pass -> Fail err
|
|
||||||
Fail _ -> Pass
|
|
||||||
e -> e
|
|
||||||
|
@ -42,6 +42,7 @@ test-suite tests
|
|||||||
build-depends: monad-conc
|
build-depends: monad-conc
|
||||||
, base
|
, base
|
||||||
, containers
|
, containers
|
||||||
|
, monad-st
|
||||||
, mtl
|
, mtl
|
||||||
, random
|
, random
|
||||||
, transformers
|
, transformers
|
||||||
|
Loading…
Reference in New Issue
Block a user