module Test.HUnit.DejaFu
(
testAuto
, testDejafu
, testDejafus
, testAuto'
, testDejafu'
, testDejafus'
, testAutoIO
, testDejafuIO
, testDejafusIO
, testAutoIO'
, testDejafuIO'
, testDejafusIO'
, Bounds(..)
, MemType(..)
) where
import Control.Monad.Catch (try)
import Data.List (intercalate, intersperse)
import Test.DejaFu
import Test.DejaFu.Deterministic (ConcST, ConcIO, Trace, ThreadId, ThreadAction, Lookahead, showFail, showTrace)
import Test.DejaFu.SCT (sctBound, sctBoundIO)
import Test.HUnit (Assertable(..), Test(..), Testable(..), assertString)
import Test.HUnit.Lang (HUnitFailure(..))
import Unsafe.Coerce (unsafeCoerce)
#if MIN_VERSION_dejafu(0,3,0)
type Trc = Trace ThreadId ThreadAction Lookahead
#else
type Trc = Trace
#endif
instance Testable (ConcST t ()) where
test conc = TestCase (assert conc)
instance Testable (ConcIO ()) where
test conc = TestCase (assert conc)
instance Assertable (ConcST t ()) where
assert conc = do
let traces = sctBound' conc'
assertString . showErr $ assertableP traces
where
conc' :: ConcST t (Either HUnitFailure ())
conc' = try conc
sctBound' :: ConcST t (Either HUnitFailure ()) -> [(Either Failure (Either HUnitFailure ()), Trc)]
sctBound' = unsafeCoerce $ sctBound defaultMemType defaultBounds
instance Assertable (ConcIO ()) where
assert conc = do
traces <- sctBoundIO defaultMemType defaultBounds (try conc)
assertString . showErr $ assertableP traces
assertableP :: Predicate (Either HUnitFailure ())
assertableP = alwaysTrue $ \r -> case r of
Right (Left (HUnitFailure _ _)) -> False
_ -> True
testAuto :: (Eq a, Show a)
=> (forall t. ConcST t a)
-> Test
testAuto = testAuto' defaultMemType
testAuto' :: (Eq a, Show a)
=> MemType
-> (forall t. ConcST t a)
-> Test
testAuto' memtype conc = testDejafus' memtype defaultBounds conc autocheckCases
testAutoIO :: (Eq a, Show a) => ConcIO a -> Test
testAutoIO = testAutoIO' defaultMemType
testAutoIO' :: (Eq a, Show a) => MemType -> ConcIO a -> Test
testAutoIO' memtype concio = testDejafusIO' memtype defaultBounds concio autocheckCases
autocheckCases :: Eq a => [(String, Predicate a)]
autocheckCases =
[("Never Deadlocks", representative deadlocksNever)
, ("No Exceptions", representative exceptionsNever)
, ("Consistent Result", alwaysSame)
]
testDejafu :: Show a
=> (forall t. ConcST t a)
-> String
-> Predicate a
-> Test
testDejafu = testDejafu' defaultMemType defaultBounds
testDejafu' :: Show a
=> MemType
-> Bounds
-> (forall t. ConcST t a)
-> String
-> Predicate a
-> Test
testDejafu' memtype cb conc name p = testDejafus' memtype cb conc [(name, p)]
testDejafus :: Show a
=> (forall t. ConcST t a)
-> [(String, Predicate a)]
-> Test
testDejafus = testDejafus' defaultMemType defaultBounds
testDejafus' :: Show a
=> MemType
-> Bounds
-> (forall t. ConcST t a)
-> [(String, Predicate a)]
-> Test
testDejafus' = testst
testDejafuIO :: Show a => ConcIO a -> String -> Predicate a -> Test
testDejafuIO = testDejafuIO' defaultMemType defaultBounds
testDejafuIO' :: Show a => MemType -> Bounds -> ConcIO a -> String -> Predicate a -> Test
testDejafuIO' memtype cb concio name p = testDejafusIO' memtype cb concio [(name, p)]
testDejafusIO :: Show a => ConcIO a -> [(String, Predicate a)] -> Test
testDejafusIO = testDejafusIO' defaultMemType defaultBounds
testDejafusIO' :: Show a => MemType -> Bounds -> ConcIO a -> [(String, Predicate a)] -> Test
testDejafusIO' = testio
testst :: Show a => MemType -> Bounds -> (forall t. ConcST t a) -> [(String, Predicate a)] -> Test
testst memtype cb conc tests = case map toTest tests of
[t] -> t
ts -> TestList ts
where
toTest (name, p) = TestLabel name . TestCase $
assertString . showErr $ p traces
traces = sctBound memtype cb conc
testio :: Show a => MemType -> Bounds -> ConcIO a -> [(String, Predicate a)] -> Test
testio memtype cb concio tests = case map toTest tests of
[t] -> t
ts -> TestList ts
where
toTest (name, p) = TestLabel name . TestCase $ do
traces <- sctBoundIO memtype cb concio
assertString . showErr $ p traces
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 (indent . showres) . take 5 $ _failures res
showres (r, t) = either showFail show r ++ " " ++ showTrace t
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