#if __GLASGOW_HASKELL__ >= 800
#endif
module Test.Tasty.DejaFu
(
testAuto
, testDejafu
, testDejafus
, testAutoWay
, testDejafuWay
, testDejafusWay
, testAutoIO
, testDejafuIO
, testDejafusIO
, testAutoWayIO
, testDejafuWayIO
, testDejafusWayIO
, Way(..)
, Bounds(..)
, 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 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)
import Unsafe.Coerce (unsafeCoerce)
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)
runSCTio :: RandomGen g => Way g -> MemType -> Conc.ConcIO a -> IO [(Either Failure a, Conc.Trace)]
runSCTio = SCT.runSCT
instance Typeable t => IsTest (Conc.ConcST t (Maybe String)) where
testOptions = Tagged concOptions
run options conc callback = do
let memtype = lookupOption options :: MemType
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
testOptions = Tagged concOptions
run options conc callback = do
let memtype = lookupOption options
let way = lookupOption options :: Way StdGen
let traces = runSCTio way memtype conc
run options (ConcIOTest traces assertableP) callback
concOptions :: [OptionDescription]
concOptions =
[ Option (Proxy :: Proxy MemType)
, Option (Proxy :: Proxy (Way StdGen))
]
assertableP :: Predicate (Maybe String)
assertableP = alwaysTrue $ \r -> case r of
Right (Just _) -> False
_ -> True
instance IsOption MemType where
defaultValue = defaultMemType
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\"."
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\"."
testAuto :: (Eq a, Show a)
=> (forall t. Conc.ConcST t a)
-> TestTree
testAuto = testAutoWay defaultWay defaultMemType
testAutoWay :: (Eq a, Show a, RandomGen g)
=> Way g
-> MemType
-> (forall t. Conc.ConcST t a)
-> TestTree
testAutoWay way memtype conc = testDejafusWay way memtype conc autocheckCases
testAutoIO :: (Eq a, Show a) => Conc.ConcIO a -> TestTree
testAutoIO = testAutoWayIO defaultWay defaultMemType
testAutoWayIO :: (Eq a, Show a, RandomGen g)
=> Way g -> MemType -> Conc.ConcIO a -> TestTree
testAutoWayIO way memtype concio =
testDejafusWayIO way memtype concio autocheckCases
autocheckCases :: Eq a => [(TestName, Predicate a)]
autocheckCases =
[("Never Deadlocks", representative deadlocksNever)
, ("No Exceptions", representative exceptionsNever)
, ("Consistent Result", alwaysSame)
]
testDejafu :: Show a
=> (forall t. Conc.ConcST t a)
-> TestName
-> Predicate a
-> TestTree
testDejafu = testDejafuWay defaultWay defaultMemType
testDejafuWay :: (Show a, RandomGen g)
=> Way g
-> MemType
-> (forall t. Conc.ConcST t a)
-> TestName
-> Predicate a
-> TestTree
testDejafuWay way memtype conc name p =
testDejafusWay way memtype conc [(name, p)]
testDejafus :: Show a
=> (forall t. Conc.ConcST t a)
-> [(TestName, Predicate a)]
-> TestTree
testDejafus = testDejafusWay defaultWay defaultMemType
testDejafusWay :: (Show a, RandomGen g)
=> Way g
-> MemType
-> (forall t. Conc.ConcST t a)
-> [(TestName, Predicate a)]
-> TestTree
testDejafusWay = testst
testDejafuIO :: Show a => Conc.ConcIO a -> TestName -> Predicate a -> TestTree
testDejafuIO = testDejafuWayIO defaultWay defaultMemType
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)]
testDejafusIO :: Show a => Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree
testDejafusIO = testDejafusWayIO defaultWay defaultMemType
testDejafusWayIO :: (Show a, RandomGen g)
=> Way g -> MemType -> Conc.ConcIO a -> [(TestName, Predicate a)] -> TestTree
testDejafusWayIO = testio
data ConcTest where
ConcTest :: Show a => [(Either Failure a, Conc.Trace)] -> Predicate a -> ConcTest
deriving Typeable
data ConcIOTest where
ConcIOTest :: Show a => IO [(Either Failure a, Conc.Trace)] -> Predicate a -> ConcIOTest
deriving Typeable
instance IsTest ConcTest where
testOptions = return []
run _ (ConcTest traces p) _ =
let err = showErr $ p traces
in return $ if null err then testPassed "" else testFailed err
instance IsTest ConcIOTest where
testOptions = return []
run _ (ConcIOTest iotraces p) _ = do
traces <- iotraces
let err = showErr $ p traces
return $ if null err then testPassed "" else testFailed err
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 = runSCTst way memtype conc
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
where
toTest (name, p) = singleTest name $ ConcIOTest traces p
traces = runSCTio way memtype concio
showErr :: Show a => Result a -> String
showErr res
| _pass res = ""
| otherwise = "Failed after " ++ show (_casesChecked res) ++ " cases:\n" ++ msg ++ unlines failures ++ rest where
msg = if null (_failureMsg res) then "" else _failureMsg res ++ "\n"
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 ""
moreThan :: [a] -> Int -> Bool
moreThan [] n = n < 0
moreThan _ 0 = True
moreThan (_:xs) n = moreThan xs (n1)
indent :: String -> String
indent = intercalate "\n" . map ('\t':) . lines