barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2024-12-19 19:41:31 +03:00
Code Issues Projects Releases Wiki Activity

Drop the Test type

Browse Source
This commit is contained in:
Michael Walker 2015-01-23 17:12:34 +00:00
parent f733a1ed43
commit dca91cc988
2 changed files with 17 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
Control/Monad/Conc/SCT/Tests.hs
View File

@ -3,9 +3,8 @@
-- | Useful functions for writing SCT test cases for @Conc@
-- computations.
module Control.Monad.Conc.SCT.Tests
( -- * Test suites
Test(..)
, doTests
(
doTests
-- * Test cases
, Result(..)
, runTest
@ -41,27 +40,12 @@ import qualified Control.Monad.Conc.Fixed.IO as CIO
-- * Test suites
-- | A single test, composed of a name to print when running test
-- suites, and a result.
data Test a = Test
{ _name :: String
-- ^ The name of the test case.
, _result :: Result a
-- ^ The result of the test case.
} deriving (Show, Eq)
instance NFData a => NFData (Test a) where
rnf t = rnf (_name t, _result t)
instance Functor Test where
fmap f t = t { _result = f <$> _result t }
-- | Run a collection of tests (with a pb of 2), printing results to
-- stdout, and returning 'True' iff all tests pass.
doTests :: Show a =>
Bool
-- ^ Whether to print test passes.
-> [Test a]
-> [(String, Result a)]
-- ^ The test cases
-> IO Bool
doTests verbose tests = do
@ -69,8 +53,8 @@ doTests verbose tests = do
return $ and results
-- | Run a test and print to stdout
doTest :: Show a => Bool -> Test a -> IO Bool
doTest verbose (Test { _name = name, _result = result }) = do
doTest :: Show a => Bool -> (String, Result a) -> IO Bool
doTest verbose (name, result) = do
if _pass result
then
-- If verbose, display a pass message.

24
tests/Tests/Cases.hs
View File

@ -9,19 +9,19 @@ import Control.Monad.Conc.SCT.Tests
import qualified Tests.Logger as L
-- | List of all tests
testCases :: [Test String]
testCases :: [(String, Result String)]
testCases =
[ Test "Simple 2-Deadlock" . fmap show $ runTest deadlocksSometimes simple2Deadlock
, Test "2 Philosophers" . fmap show $ runTest deadlocksSometimes $ philosophers 2
, Test "3 Philosophers" . fmap show $ runTest deadlocksSometimes $ philosophers 3
, Test "4 Philosophers" . fmap show $ runTest deadlocksSometimes $ philosophers 4
, Test "Threshold Value" . fmap show $ runTest (pNot alwaysSame) thresholdValue
, Test "Forgotten Unlock" . fmap show $ runTest deadlocksAlways forgottenUnlock
, Test "Simple 2-Race" . fmap show $ runTest (pNot alwaysSame) simple2Race
, Test "Racey Stack" . fmap show $ runTest (pNot alwaysSame) raceyStack
, Test "Logger (LA)" . fmap show $ L.testLA
, Test "Logger (LP)" . fmap show $ L.testLP
, Test "Logger (LE)" . fmap show $ L.testLE
[ ("Simple 2-Deadlock" , fmap show $ runTest deadlocksSometimes simple2Deadlock)
, ("2 Philosophers" , fmap show $ runTest deadlocksSometimes $ philosophers 2)
, ("3 Philosophers" , fmap show $ runTest deadlocksSometimes $ philosophers 3)
, ("4 Philosophers" , fmap show $ runTest deadlocksSometimes $ philosophers 4)
, ("Threshold Value" , fmap show $ runTest (pNot alwaysSame) thresholdValue)
, ("Forgotten Unlock" , fmap show $ runTest deadlocksAlways forgottenUnlock)
, ("Simple 2-Race" , fmap show $ runTest (pNot alwaysSame) simple2Race)
, ("Racey Stack" , fmap show $ runTest (pNot alwaysSame) raceyStack)
, ("Logger (LA)" , fmap show $ L.testLA)
, ("Logger (LP)" , fmap show $ L.testLP)
, ("Logger (LE)" , fmap show $ L.testLE)
]
-- | Should deadlock on a minority of schedules.