diff --git a/Test/Tasty/DejaFu.hs b/Test/Tasty/DejaFu.hs --- a/Test/Tasty/DejaFu.hs +++ b/Test/Tasty/DejaFu.hs @@ -10,8 +10,16 @@ {-# LANGUAGE ImpredicativeTypes #-} #endif --- | This module allows using Deja Fu predicates with Tasty to test --- the behaviour of concurrent systems. +-- | +-- Module : Test.Tasty.DejaFu +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : CPP, FlexibleInstances, GADTs, ImpredicativeTypes, RankNTypes, TypeSynonymInstances +-- +-- This module allows using Deja Fu predicates with Tasty to test the +-- behaviour of concurrent systems. module Test.Tasty.DejaFu ( -- * Unit testing @@ -47,49 +55,66 @@ , MemType(..) ) where +import Control.Monad.ST (runST) import Data.Char (toUpper) import Data.List (intercalate, intersperse) import Data.Proxy (Proxy(..)) import Data.Tagged (Tagged(..)) import Data.Typeable (Typeable) import Test.DejaFu -import Test.DejaFu.Deterministic (ConcST, ConcIO, Trace, ThreadId, ThreadAction, Lookahead, showFail, showTrace) -import Test.DejaFu.SCT (sctBound, sctBoundIO) +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 = Trace ThreadId ThreadAction Lookahead +type Trc = Conc.Trace Conc.ThreadId Conc.ThreadAction Conc.Lookahead #else -type Trc = Trace +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)] + +#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 + -------------------------------------------------------------------------------- -- Unit testing -instance Typeable t => IsTest (ConcST t (Maybe String)) where +instance Typeable t => IsTest (Conc.ConcST t (Maybe String)) where testOptions = Tagged concOptions run options conc callback = do let memtype = lookupOption options :: MemType let bounds = lookupOption options :: Bounds - let sctBound' :: ConcST t (Maybe String) -> [(Either Failure (Maybe String), Trc)] - sctBound' = unsafeCoerce $ sctBound memtype bounds + let sctBound' :: Conc.ConcST t (Maybe String) -> [(Either Failure (Maybe String), Trc)] + sctBound' = unsafeCoerce $ sctBoundST memtype bounds let traces = sctBound' conc run options (ConcTest traces assertableP) callback -instance IsTest (ConcIO (Maybe String)) where +instance IsTest (Conc.ConcIO (Maybe String)) where testOptions = Tagged concOptions run options conc callback = do let memtype = lookupOption options let bounds = lookupOption options - let traces = sctBoundIO memtype bounds conc + let traces = sctBoundIO memtype bounds conc run options (ConcIOTest traces assertableP) callback concOptions :: [OptionDescription] @@ -129,7 +154,7 @@ -- 'MonadConc'. If you need to test something which also uses -- 'MonadIO', use 'testAutoIO'. testAuto :: (Eq a, Show a) - => (forall t. ConcST t a) + => (forall t. Conc.ConcST t a) -- ^ The computation to test -> TestTree testAuto = testAuto' defaultMemType @@ -139,17 +164,17 @@ testAuto' :: (Eq a, Show a) => MemType -- ^ The memory model to use for non-synchronised @CRef@ operations. - -> (forall t. ConcST t a) + -> (forall t. Conc.ConcST t a) -- ^ The computation to test -> TestTree testAuto' memtype conc = testDejafus' memtype defaultBounds conc autocheckCases -- | Variant of 'testAuto' for computations which do 'IO'. -testAutoIO :: (Eq a, Show a) => ConcIO a -> TestTree +testAutoIO :: (Eq a, Show a) => Conc.ConcIO a -> TestTree testAutoIO = testAutoIO' defaultMemType -- | Variant of 'testAuto'' for computations which do 'IO'. -testAutoIO' :: (Eq a, Show a) => MemType -> ConcIO a -> TestTree +testAutoIO' :: (Eq a, Show a) => MemType -> Conc.ConcIO a -> TestTree testAutoIO' memtype concio = testDejafusIO' memtype defaultBounds concio autocheckCases -- | Predicates for the various autocheck functions. @@ -162,7 +187,7 @@ -- | Check that a predicate holds. testDejafu :: Show a - => (forall t. ConcST t a) + => (forall t. Conc.ConcST t a) -- ^ The computation to test -> TestName -- ^ The name of the test. @@ -178,7 +203,7 @@ -- ^ The memory model to use for non-synchronised @CRef@ operations. -> Bounds -- ^ The schedule bounds. - -> (forall t. ConcST t a) + -> (forall t. Conc.ConcST t a) -- ^ The computation to test -> TestName -- ^ The name of the test. @@ -191,7 +216,7 @@ -- test. This will share work between the predicates, rather than -- running the concurrent computation many times for each predicate. testDejafus :: Show a - => (forall t. ConcST t a) + => (forall t. Conc.ConcST t a) -- ^ The computation to test -> [(TestName, Predicate a)] -- ^ The list of predicates (with names) to check @@ -205,7 +230,7 @@ -- ^ The memory model to use for non-synchronised @CRef@ operations. -> Bounds -- ^ The schedule bounds. - -> (forall t. ConcST t a) + -> (forall t. Conc.ConcST t a) -- ^ The computation to test -> [(TestName, Predicate a)] -- ^ The list of predicates (with names) to check @@ -213,19 +238,19 @@ testDejafus' = testst -- | Variant of 'testDejafu' for computations which do 'IO'. -testDejafuIO :: Show a => ConcIO a -> TestName -> Predicate a -> TestTree +testDejafuIO :: Show a => Conc.ConcIO a -> TestName -> Predicate a -> TestTree testDejafuIO = testDejafuIO' defaultMemType defaultBounds -- | Variant of 'testDejafu'' for computations which do 'IO'. -testDejafuIO' :: Show a => MemType -> Bounds -> ConcIO a -> TestName -> Predicate a -> TestTree +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 'testDejafus' for computations which do 'IO'. -testDejafusIO :: Show a => ConcIO a -> [(TestName, Predicate a)] -> TestTree +testDejafusIO :: Show a => Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree testDejafusIO = testDejafusIO' defaultMemType defaultBounds -- | Variant of 'dejafus'' for computations which do 'IO'. -testDejafusIO' :: Show a => MemType -> Bounds -> ConcIO a -> [(TestName, Predicate a)] -> TestTree +testDejafusIO' :: Show a => MemType -> Bounds -> Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree testDejafusIO' = testio -------------------------------------------------------------------------------- @@ -255,7 +280,7 @@ 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. ConcST t a) -> [(TestName, Predicate a)] -> TestTree +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 [t] -> t ts -> testGroup "Deja Fu Tests" ts @@ -263,10 +288,10 @@ where toTest (name, p) = singleTest name $ ConcTest traces p - traces = sctBound memtype cb conc + traces = sctBoundST memtype cb conc -- | Produce a Tasty 'Test' from an IO-using Deja Fu test. -testio :: Show a => MemType -> Bounds -> ConcIO a -> [(TestName, Predicate a)] -> TestTree +testio :: Show a => MemType -> Bounds -> Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree testio memtype cb concio tests = case map toTest tests of [t] -> t ts -> testGroup "Deja Fu Tests" ts @@ -287,7 +312,7 @@ msg = if null (_failureMsg res) then "" else _failureMsg res ++ "\n" - failures = intersperse "" . map (\(r, t) -> indent $ either showFail show r ++ " " ++ showTrace t) . take 5 $ _failures res + failures = intersperse "" . map (\(r, t) -> indent $ either Conc.showFail show r ++ " " ++ Conc.showTrace t) . take 5 $ _failures res rest = if moreThan (_failures res) 5 then "\n\t..." else "" 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.1 +version: 0.3.0.2 synopsis: Deja Fu support for the Tasty test framework. description: @@ -40,7 +40,7 @@ -- other-modules: -- other-extensions: build-depends: base >=4.8 && <5 - , dejafu >=0.2 && <0.4 + , dejafu >=0.2 && <0.5 , tagged >=0.8 && <0.9 , tasty >=0.10 && <0.12 -- hs-source-dirs: