diff --git a/dejafu-tests/dejafu-tests.cabal b/dejafu-tests/dejafu-tests.cabal index fa87ae1..b33c45c 100644 --- a/dejafu-tests/dejafu-tests.cabal +++ b/dejafu-tests/dejafu-tests.cabal @@ -58,6 +58,7 @@ library , tasty-expected-failure , tasty-dejafu , tasty-hedgehog + , tasty-hunit , vector if impl(ghc < 8.0.1) build-depends: transformers diff --git a/dejafu-tests/lib/Integration/Discard.hs b/dejafu-tests/lib/Integration/Discard.hs index 53ecd29..ae1e115 100644 --- a/dejafu-tests/lib/Integration/Discard.hs +++ b/dejafu-tests/lib/Integration/Discard.hs @@ -1,7 +1,12 @@ module Integration.Discard where import Control.Concurrent.Classy hiding (check) +import Data.Foldable (for_) import Test.DejaFu (gives') +import Test.DejaFu.Conc (ConcIO) +import Test.DejaFu.SCT +import Test.DejaFu.Types (Failure) +import Test.Tasty.HUnit import Common @@ -13,11 +18,26 @@ tests = toTestList const (Just DiscardResultAndTrace) , check "Results failing the test are not present" [1, 2] $ \x -> if x == Right 3 then Just DiscardResultAndTrace else Nothing + , testCase "No traces kept when they get discared" $ testDiscardTrace discarder testAction ] where - check name xs f = testDejafuDiscard f defaultWay defaultMemType name (gives' xs) $ do + check name xs f = testDejafuDiscard f defaultWay defaultMemType name (gives' xs) testAction + testAction = do mvar <- newEmptyMVarInt _ <- fork $ putMVar mvar 1 _ <- fork $ putMVar mvar 2 _ <- fork $ putMVar mvar 3 readMVar mvar + discarder (Right 2) = Just DiscardTrace + discarder (Right 3) = Just DiscardResultAndTrace + discarder _ = Nothing + +testDiscardTrace :: (Either Failure a -> Maybe Discard) -> ConcIO a -> Assertion +testDiscardTrace discarder action = do + results <- runSCTDiscard discarder defaultWay defaultMemType action + for_ results $ \(efa, trace) -> case discarder efa of + Just DiscardResultAndTrace -> assertFailure "expected result to be discarded" + Just DiscardTrace + | null trace -> pure () + | otherwise -> assertFailure "expected trace to be discarded" + Nothing -> pure ()