#if __GLASGOW_HASKELL__ >= 800
#endif
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 Control.Monad.ST (runST)
import Data.List (intercalate, intersperse)
import Test.DejaFu
import qualified Test.DejaFu.SCT as SCT
import Test.HUnit (Assertable(..), Test(..), Testable(..), assertString)
import Test.HUnit.Lang (HUnitFailure(..))
#if MIN_VERSION_dejafu(0,4,0)
import qualified Test.DejaFu.Conc as Conc
#else
import qualified Test.DejaFu.Deterministic as Conc
#endif
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)]
#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
instance Testable (Conc.ConcST t ()) where
test conc = TestCase (assert conc)
instance Testable (Conc.ConcIO ()) where
test conc = TestCase (assert conc)
instance Assertable (Conc.ConcST t ()) where
assert conc = do
let traces = sctBound' conc'
assertString . showErr $ assertableP traces
where
conc' :: Conc.ConcST t (Either HUnitFailure ())
conc' = try conc
sctBound' :: Conc.ConcST t (Either HUnitFailure ()) -> [(Either Failure (Either HUnitFailure ()), Trc)]
sctBound' = unsafeCoerce $ sctBoundST defaultMemType defaultBounds
instance Assertable (Conc.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. Conc.ConcST t a)
-> Test
testAuto = testAuto' defaultMemType
testAuto' :: (Eq a, Show a)
=> MemType
-> (forall t. Conc.ConcST t a)
-> Test
testAuto' memtype conc = testDejafus' memtype defaultBounds conc autocheckCases
testAutoIO :: (Eq a, Show a) => Conc.ConcIO a -> Test
testAutoIO = testAutoIO' defaultMemType
testAutoIO' :: (Eq a, Show a) => MemType -> Conc.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. Conc.ConcST t a)
-> String
-> Predicate a
-> Test
testDejafu = testDejafu' defaultMemType defaultBounds
testDejafu' :: Show a
=> MemType
-> Bounds
-> (forall t. Conc.ConcST t a)
-> String
-> Predicate a
-> Test
testDejafu' memtype cb conc name p = testDejafus' memtype cb conc [(name, p)]
testDejafus :: Show a
=> (forall t. Conc.ConcST t a)
-> [(String, Predicate a)]
-> Test
testDejafus = testDejafus' defaultMemType defaultBounds
testDejafus' :: Show a
=> MemType
-> Bounds
-> (forall t. Conc.ConcST t a)
-> [(String, Predicate a)]
-> Test
testDejafus' = testst
testDejafuIO :: Show a => Conc.ConcIO a -> String -> Predicate a -> Test
testDejafuIO = testDejafuIO' defaultMemType defaultBounds
testDejafuIO' :: Show a => MemType -> Bounds -> Conc.ConcIO a -> String -> Predicate a -> Test
testDejafuIO' memtype cb concio name p = testDejafusIO' memtype cb concio [(name, p)]
testDejafusIO :: Show a => Conc.ConcIO a -> [(String, Predicate a)] -> Test
testDejafusIO = testDejafusIO' defaultMemType defaultBounds
testDejafusIO' :: Show a => MemType -> Bounds -> Conc.ConcIO a -> [(String, Predicate a)] -> Test
testDejafusIO' = testio
testst :: Show a => MemType -> Bounds -> (forall t. Conc.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 = sctBoundST memtype cb conc
testio :: Show a => MemType -> Bounds -> Conc.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 Conc.showFail show r ++ " " ++ Conc.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