barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2024-12-24 22:12:25 +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@ -- | Useful functions for writing SCT test cases for @Conc@
-- computations. -- computations.
module Control.Monad.Conc.SCT.Tests module Control.Monad.Conc.SCT.Tests
( -- * Test suites (
Test(..) doTests
, doTests
-- * Test cases -- * Test cases
, Result(..) , Result(..)
, runTest , runTest
@ -41,27 +40,12 @@ import qualified Control.Monad.Conc.Fixed.IO as CIO
-- * Test suites -- * 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 -- | Run a collection of tests (with a pb of 2), printing results to
-- stdout, and returning 'True' iff all tests pass. -- stdout, and returning 'True' iff all tests pass.
doTests :: Show a => doTests :: Show a =>
Bool Bool
-- ^ Whether to print test passes. -- ^ Whether to print test passes.
-> [Test a] -> [(String, Result a)]
-- ^ The test cases -- ^ The test cases
-> IO Bool -> IO Bool
doTests verbose tests = do doTests verbose tests = do
@ -69,8 +53,8 @@ doTests verbose tests = do
return $ and results return $ and results
-- | Run a test and print to stdout -- | Run a test and print to stdout
doTest :: Show a => Bool -> Test a -> IO Bool doTest :: Show a => Bool -> (String, Result a) -> IO Bool
doTest verbose (Test { _name = name, _result = result }) = do doTest verbose (name, result) = do
if _pass result if _pass result
then then
-- If verbose, display a pass message. -- 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 import qualified Tests.Logger as L
-- | List of all tests -- | List of all tests
testCases :: [Test String] testCases :: [(String, Result String)]
testCases = testCases =
[ Test "Simple 2-Deadlock" . fmap show $ runTest deadlocksSometimes simple2Deadlock [ ("Simple 2-Deadlock" , fmap show $ runTest deadlocksSometimes simple2Deadlock)
, Test "2 Philosophers" . fmap show $ runTest deadlocksSometimes $ philosophers 2 , ("2 Philosophers" , fmap show $ runTest deadlocksSometimes $ philosophers 2)
, Test "3 Philosophers" . fmap show $ runTest deadlocksSometimes $ philosophers 3 , ("3 Philosophers" , fmap show $ runTest deadlocksSometimes $ philosophers 3)
, Test "4 Philosophers" . fmap show $ runTest deadlocksSometimes $ philosophers 4 , ("4 Philosophers" , fmap show $ runTest deadlocksSometimes $ philosophers 4)
, Test "Threshold Value" . fmap show $ runTest (pNot alwaysSame) thresholdValue , ("Threshold Value" , fmap show $ runTest (pNot alwaysSame) thresholdValue)
, Test "Forgotten Unlock" . fmap show $ runTest deadlocksAlways forgottenUnlock , ("Forgotten Unlock" , fmap show $ runTest deadlocksAlways forgottenUnlock)
, Test "Simple 2-Race" . fmap show $ runTest (pNot alwaysSame) simple2Race , ("Simple 2-Race" , fmap show $ runTest (pNot alwaysSame) simple2Race)
, Test "Racey Stack" . fmap show $ runTest (pNot alwaysSame) raceyStack , ("Racey Stack" , fmap show $ runTest (pNot alwaysSame) raceyStack)
, Test "Logger (LA)" . fmap show $ L.testLA , ("Logger (LA)" , fmap show $ L.testLA)
, Test "Logger (LP)" . fmap show $ L.testLP , ("Logger (LP)" , fmap show $ L.testLP)
, Test "Logger (LE)" . fmap show $ L.testLE , ("Logger (LE)" , fmap show $ L.testLE)
] ]
-- | Should deadlock on a minority of schedules. -- | Should deadlock on a minority of schedules.