#if __GLASGOW_HASKELL__ >= 800
#endif
module Test.HUnit.DejaFu
(
testAuto
, testDejafu
, testDejafus
, testAutoWay
, testDejafuWay
, testDejafusWay
, testAutoIO
, testDejafuIO
, testDejafusIO
, testAutoWayIO
, testDejafuWayIO
, testDejafusWayIO
, Way(..)
, 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.Conc as Conc
import qualified Test.DejaFu.SCT as SCT
import Test.HUnit (Assertable(..), Test(..), Testable(..),
assertString)
import Test.HUnit.Lang (HUnitFailure(..))
import Unsafe.Coerce (unsafeCoerce)
runSCTst :: Way -> MemType -> (forall t. Conc.ConcST t a) -> [(Either Failure a, Conc.Trace)]
runSCTst way memtype conc = runST (SCT.runSCT way memtype conc)
runSCTio :: Way -> MemType -> Conc.ConcIO a -> IO [(Either Failure a, Conc.Trace)]
runSCTio = SCT.runSCT
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 = runSCTst' conc'
assertString . showErr $ assertableP traces
where
conc' :: Conc.ConcST t (Either HUnitFailure ())
conc' = try conc
runSCTst' :: Conc.ConcST t (Either HUnitFailure ()) -> [(Either Failure (Either HUnitFailure ()), Conc.Trace)]
runSCTst' = unsafeCoerce $ runSCTst defaultWay defaultMemType
instance Assertable (Conc.ConcIO ()) where
assert conc = do
traces <- runSCTio defaultWay defaultMemType (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 = testAutoWay defaultWay defaultMemType
testAutoWay :: (Eq a, Show a)
=> Way
-> MemType
-> (forall t. Conc.ConcST t a)
-> Test
testAutoWay way memtype conc =
testDejafusWay way memtype conc autocheckCases
testAutoIO :: (Eq a, Show a) => Conc.ConcIO a -> Test
testAutoIO = testAutoWayIO defaultWay defaultMemType
testAutoWayIO :: (Eq a, Show a)
=> Way -> MemType -> Conc.ConcIO a -> Test
testAutoWayIO way memtype concio =
testDejafusWayIO way memtype 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 = testDejafuWay defaultWay defaultMemType
testDejafuWay :: Show a
=> Way
-> MemType
-> (forall t. Conc.ConcST t a)
-> String
-> Predicate a
-> Test
testDejafuWay way memtype conc name p =
testDejafusWay way memtype conc [(name, p)]
testDejafus :: Show a
=> (forall t. Conc.ConcST t a)
-> [(String, Predicate a)]
-> Test
testDejafus = testDejafusWay defaultWay defaultMemType
testDejafusWay :: Show a
=> Way
-> MemType
-> (forall t. Conc.ConcST t a)
-> [(String, Predicate a)]
-> Test
testDejafusWay = testst
testDejafuIO :: Show a => Conc.ConcIO a -> String -> Predicate a -> Test
testDejafuIO = testDejafuWayIO defaultWay defaultMemType
testDejafuWayIO :: Show a
=> Way -> MemType -> Conc.ConcIO a -> String -> Predicate a -> Test
testDejafuWayIO way memtype concio name p =
testDejafusWayIO way memtype concio [(name, p)]
testDejafusIO :: Show a => Conc.ConcIO a -> [(String, Predicate a)] -> Test
testDejafusIO = testDejafusWayIO defaultWay defaultMemType
testDejafusWayIO :: Show a
=> Way -> MemType -> Conc.ConcIO a -> [(String, Predicate a)] -> Test
testDejafusWayIO = testio
testst :: Show a
=> Way -> MemType -> (forall t. Conc.ConcST t a) -> [(String, Predicate a)] -> Test
testst way memtype conc tests = case map toTest tests of
[t] -> t
ts -> TestList ts
where
toTest (name, p) = TestLabel name . TestCase $
assertString . showErr $ p traces
traces = runSCTst way memtype conc
testio :: Show a
=> Way -> MemType -> Conc.ConcIO a -> [(String, Predicate a)] -> Test
testio way memtype concio tests = case map toTest tests of
[t] -> t
ts -> TestList ts
where
toTest (name, p) = TestLabel name . TestCase $ do
traces <- runSCTio way memtype 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