diff --git a/Test/Tasty/DejaFu.hs b/Test/Tasty/DejaFu.hs --- a/Test/Tasty/DejaFu.hs +++ b/Test/Tasty/DejaFu.hs @@ -37,20 +37,21 @@ , testDejafu , testDejafus - , testAuto' - , testDejafu' - , testDejafus' + , testAutoWay + , testDejafuWay + , testDejafusWay -- ** @IO@ , testAutoIO , testDejafuIO , testDejafusIO - , testAutoIO' - , testDejafuIO' - , testDejafusIO' + , testAutoWayIO + , testDejafuWayIO + , testDejafusWayIO -- * Re-exports + , Way(..) , Bounds(..) , MemType(..) ) where @@ -61,38 +62,23 @@ import Data.Proxy (Proxy(..)) import Data.Tagged (Tagged(..)) import Data.Typeable (Typeable) +import System.Random (RandomGen, StdGen, mkStdGen) import Test.DejaFu +import qualified Test.DejaFu.Conc as Conc import qualified Test.DejaFu.SCT as SCT import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.Options (OptionDescription(..), IsOption(..), lookupOption) import Test.Tasty.Providers (IsTest(..), singleTest, testPassed, testFailed) -#if MIN_VERSION_dejafu(0,4,0) -import qualified Test.DejaFu.Conc as Conc -#else -import qualified Test.DejaFu.Deterministic as Conc -#endif - -- Can't put the necessary forall in the @IsTest ConcST t@ -- instance :( import Unsafe.Coerce (unsafeCoerce) -#if MIN_VERSION_dejafu(0,3,0) -type Trc = Conc.Trace Conc.ThreadId Conc.ThreadAction Conc.Lookahead -#else -type Trc = Conc.Trace -#endif - -sctBoundST :: MemType -> Bounds -> (forall t. Conc.ConcST t a) -> [(Either Failure a, Trc)] -sctBoundIO :: MemType -> Bounds -> Conc.ConcIO a -> IO [(Either Failure a, Trc)] +runSCTst :: RandomGen g => Way g -> MemType -> (forall t. Conc.ConcST t a) -> [(Either Failure a, Conc.Trace)] +runSCTst way memtype conc = runST (SCT.runSCT way memtype conc) -#if MIN_VERSION_dejafu(0,4,0) -sctBoundST memtype cb conc = runST (SCT.sctBound memtype cb conc) -sctBoundIO = SCT.sctBound -#else -sctBoundST = SCT.sctBound -sctBoundIO = SCT.sctBoundIO -#endif +runSCTio :: RandomGen g => Way g -> MemType -> Conc.ConcIO a -> IO [(Either Failure a, Conc.Trace)] +runSCTio = SCT.runSCT -------------------------------------------------------------------------------- -- Unit testing @@ -102,10 +88,10 @@ run options conc callback = do let memtype = lookupOption options :: MemType - let bounds = lookupOption options :: Bounds - let sctBound' :: Conc.ConcST t (Maybe String) -> [(Either Failure (Maybe String), Trc)] - sctBound' = unsafeCoerce $ sctBoundST memtype bounds - let traces = sctBound' conc + let way = lookupOption options :: Way StdGen + let runSCTst' :: Conc.ConcST t (Maybe String) -> [(Either Failure (Maybe String), Conc.Trace)] + runSCTst' = unsafeCoerce $ runSCTst way memtype + let traces = runSCTst' conc run options (ConcTest traces assertableP) callback instance IsTest (Conc.ConcIO (Maybe String)) where @@ -113,14 +99,14 @@ run options conc callback = do let memtype = lookupOption options - let bounds = lookupOption options - let traces = sctBoundIO memtype bounds conc + let way = lookupOption options :: Way StdGen + let traces = runSCTio way memtype conc run options (ConcIOTest traces assertableP) callback concOptions :: [OptionDescription] concOptions = - [ Option (Proxy :: Proxy Bounds) - , Option (Proxy :: Proxy MemType) + [ Option (Proxy :: Proxy MemType) + , Option (Proxy :: Proxy (Way StdGen)) ] assertableP :: Predicate (Maybe String) @@ -128,28 +114,31 @@ Right (Just _) -> False _ -> True -instance IsOption Bounds where - defaultValue = defaultBounds - parseValue = const Nothing - optionName = Tagged "schedule-bounds" - optionHelp = Tagged "The schedule bounds to use. This cannot be set on the command line." - instance IsOption MemType where defaultValue = defaultMemType - parseValue str = shortName (map toUpper str) where + parseValue = shortName . map toUpper where shortName "SC" = Just SequentialConsistency shortName "TSO" = Just TotalStoreOrder shortName "PSO" = Just PartialStoreOrder shortName _ = Nothing optionName = Tagged "memory-model" - optionHelp = Tagged "The memory model to use. This should be one of \"SC\", \"TSO\", or \"PSO\"." + optionHelp = Tagged "The memory model to use. This should be one of \"sc\", \"tso\", or \"pso\"." +instance IsOption (Way StdGen) where + defaultValue = defaultWay + parseValue = shortName . map toUpper where + shortName "SYSTEMATICALLY" = Just (Systematically defaultBounds) + shortName "RANDOMLY" = Just (Randomly (mkStdGen 42) 100) + shortName _ = Nothing + optionName = Tagged "way" + optionHelp = Tagged "The execution method to use. This should be one of \"systematically\" or \"randomly\"." + -------------------------------------------------------------------------------- -- Property testing -- | Automatically test a computation. In particular, look for -- deadlocks, uncaught exceptions, and multiple return values. --- +-- -- This uses the 'Conc' monad for testing, which is an instance of -- 'MonadConc'. If you need to test something which also uses -- 'MonadIO', use 'testAutoIO'. @@ -157,25 +146,29 @@ => (forall t. Conc.ConcST t a) -- ^ The computation to test -> TestTree -testAuto = testAuto' defaultMemType +testAuto = testAutoWay defaultWay defaultMemType -- | Variant of 'testAuto' which tests a computation under a given --- memory model. -testAuto' :: (Eq a, Show a) - => MemType +-- execution way and memory model. +testAutoWay :: (Eq a, Show a, RandomGen g) + => Way g + -- ^ How to execute the concurrent program. + -> MemType -- ^ The memory model to use for non-synchronised @CRef@ operations. -> (forall t. Conc.ConcST t a) -- ^ The computation to test -> TestTree -testAuto' memtype conc = testDejafus' memtype defaultBounds conc autocheckCases +testAutoWay way memtype conc = testDejafusWay way memtype conc autocheckCases -- | Variant of 'testAuto' for computations which do 'IO'. testAutoIO :: (Eq a, Show a) => Conc.ConcIO a -> TestTree -testAutoIO = testAutoIO' defaultMemType +testAutoIO = testAutoWayIO defaultWay defaultMemType --- | Variant of 'testAuto'' for computations which do 'IO'. -testAutoIO' :: (Eq a, Show a) => MemType -> Conc.ConcIO a -> TestTree -testAutoIO' memtype concio = testDejafusIO' memtype defaultBounds concio autocheckCases +-- | Variant of 'testAutoWay' for computations which do 'IO'. +testAutoWayIO :: (Eq a, Show a, RandomGen g) + => Way g -> MemType -> Conc.ConcIO a -> TestTree +testAutoWayIO way memtype concio = + testDejafusWayIO way memtype concio autocheckCases -- | Predicates for the various autocheck functions. autocheckCases :: Eq a => [(TestName, Predicate a)] @@ -194,15 +187,15 @@ -> Predicate a -- ^ The predicate to check -> TestTree -testDejafu = testDejafu' defaultMemType defaultBounds +testDejafu = testDejafuWay defaultWay defaultMemType --- | Variant of 'testDejafu' which takes a memory model and --- pre-emption bound. -testDejafu' :: Show a - => MemType +-- | Variant of 'testDejafu' which takes a way to execute the program +-- and a memory model. +testDejafuWay :: (Show a, RandomGen g) + => Way g + -- ^ How to execute the concurrent program. + -> MemType -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> Bounds - -- ^ The schedule bounds. -> (forall t. Conc.ConcST t a) -- ^ The computation to test -> TestName @@ -210,7 +203,8 @@ -> Predicate a -- ^ The predicate to check -> TestTree -testDejafu' memtype cb conc name p = testDejafus' memtype cb conc [(name, p)] +testDejafuWay way memtype conc name p = + testDejafusWay way memtype conc [(name, p)] -- | Variant of 'testDejafu' which takes a collection of predicates to -- test. This will share work between the predicates, rather than @@ -221,47 +215,50 @@ -> [(TestName, Predicate a)] -- ^ The list of predicates (with names) to check -> TestTree -testDejafus = testDejafus' defaultMemType defaultBounds +testDejafus = testDejafusWay defaultWay defaultMemType --- | Variant of 'testDejafus' which takes a memory model and pre-emption --- bound. -testDejafus' :: Show a - => MemType +-- | Variant of 'testDejafus' which takes a way to execute the program +-- and a memory model. +testDejafusWay :: (Show a, RandomGen g) + => Way g + -- ^ How to execute the concurrent program. + -> MemType -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> Bounds - -- ^ The schedule bounds. -> (forall t. Conc.ConcST t a) -- ^ The computation to test -> [(TestName, Predicate a)] -- ^ The list of predicates (with names) to check -> TestTree -testDejafus' = testst +testDejafusWay = testst -- | Variant of 'testDejafu' for computations which do 'IO'. testDejafuIO :: Show a => Conc.ConcIO a -> TestName -> Predicate a -> TestTree -testDejafuIO = testDejafuIO' defaultMemType defaultBounds +testDejafuIO = testDejafuWayIO defaultWay defaultMemType --- | Variant of 'testDejafu'' for computations which do 'IO'. -testDejafuIO' :: Show a => MemType -> Bounds -> Conc.ConcIO a -> TestName -> Predicate a -> TestTree -testDejafuIO' memtype cb concio name p = testDejafusIO' memtype cb concio [(name, p)] +-- | Variant of 'testDejafuWay' for computations which do 'IO'. +testDejafuWayIO :: (Show a, RandomGen g) + => Way g -> MemType -> Conc.ConcIO a -> TestName -> Predicate a -> TestTree +testDejafuWayIO way memtype concio name p = + testDejafusWayIO way memtype concio [(name, p)] -- | Variant of 'testDejafus' for computations which do 'IO'. testDejafusIO :: Show a => Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree -testDejafusIO = testDejafusIO' defaultMemType defaultBounds +testDejafusIO = testDejafusWayIO defaultWay defaultMemType --- | Variant of 'dejafus'' for computations which do 'IO'. -testDejafusIO' :: Show a => MemType -> Bounds -> Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree -testDejafusIO' = testio +-- | Variant of 'dejafusWay' for computations which do 'IO'. +testDejafusWayIO :: (Show a, RandomGen g) + => Way g -> MemType -> Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree +testDejafusWayIO = testio -------------------------------------------------------------------------------- -- Tasty integration data ConcTest where - ConcTest :: Show a => [(Either Failure a, Trc)] -> Predicate a -> ConcTest + ConcTest :: Show a => [(Either Failure a, Conc.Trace)] -> Predicate a -> ConcTest deriving Typeable data ConcIOTest where - ConcIOTest :: Show a => IO [(Either Failure a, Trc)] -> Predicate a -> ConcIOTest + ConcIOTest :: Show a => IO [(Either Failure a, Conc.Trace)] -> Predicate a -> ConcIOTest deriving Typeable instance IsTest ConcTest where @@ -280,19 +277,21 @@ return $ if null err then testPassed "" else testFailed err -- | Produce a Tasty 'TestTree' from a Deja Fu test. -testst :: Show a => MemType -> Bounds -> (forall t. Conc.ConcST t a) -> [(TestName, Predicate a)] -> TestTree -testst memtype cb conc tests = case map toTest tests of +testst :: (Show a, RandomGen g) + => Way g -> MemType -> (forall t. Conc.ConcST t a) -> [(TestName, Predicate a)] -> TestTree +testst way memtype conc tests = case map toTest tests of [t] -> t ts -> testGroup "Deja Fu Tests" ts where toTest (name, p) = singleTest name $ ConcTest traces p - traces = sctBoundST memtype cb conc + traces = runSCTst way memtype conc -- | Produce a Tasty 'Test' from an IO-using Deja Fu test. -testio :: Show a => MemType -> Bounds -> Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree -testio memtype cb concio tests = case map toTest tests of +testio :: (Show a, RandomGen g) + => Way g -> MemType -> Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree +testio way memtype concio tests = case map toTest tests of [t] -> t ts -> testGroup "Deja Fu Tests" ts @@ -301,7 +300,7 @@ -- As with HUnit, constructing a test is side-effect free, so -- sharing of traces can't happen here. - traces = sctBoundIO memtype cb concio + traces = runSCTio way memtype concio -- | Convert a test result into an error message on failure (empty -- string on success). diff --git a/tasty-dejafu.cabal b/tasty-dejafu.cabal --- a/tasty-dejafu.cabal +++ b/tasty-dejafu.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: tasty-dejafu -version: 0.3.0.2 +version: 0.4.0.0 synopsis: Deja Fu support for the Tasty test framework. description: @@ -33,14 +33,15 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: tasty-dejafu-0.3.0.1 + tag: tasty-dejafu-0.4.0.0 library exposed-modules: Test.Tasty.DejaFu -- other-modules: -- other-extensions: build-depends: base >=4.8 && <5 - , dejafu >=0.2 && <0.5 + , dejafu >=0.5 && <0.6 + , random >=1.0 && <1.2 , tagged >=0.8 && <0.9 , tasty >=0.10 && <0.12 -- hs-source-dirs: