barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2025-01-04 11:46:08 +03:00
Code Issues Projects Releases Wiki Activity

Add test for DiscardTrace

Browse Source
This commit is contained in:
Kirill Zaborsky 2018-02-21 01:07:23 +03:00
parent c2a178bd86
commit 7f5680bcd1
2 changed files with 22 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
dejafu-tests/dejafu-tests.cabal
View File

@ -58,6 +58,7 @@ library
, tasty-expected-failure , tasty-expected-failure
, tasty-dejafu , tasty-dejafu
, tasty-hedgehog , tasty-hedgehog
, tasty-hunit
, vector , vector
if impl(ghc < 8.0.1) if impl(ghc < 8.0.1)
build-depends: transformers build-depends: transformers

22
dejafu-tests/lib/Integration/Discard.hs
View File

@ -1,7 +1,12 @@
module Integration.Discard where module Integration.Discard where
import Control.Concurrent.Classy hiding (check) import Control.Concurrent.Classy hiding (check)
import Data.Foldable (for_)
import Test.DejaFu (gives') import Test.DejaFu (gives')
import Test.DejaFu.Conc (ConcIO)
import Test.DejaFu.SCT
import Test.DejaFu.Types (Failure)
import Test.Tasty.HUnit
import Common import Common
@ -13,11 +18,26 @@ tests = toTestList
const (Just DiscardResultAndTrace) const (Just DiscardResultAndTrace)
, check "Results failing the test are not present" [1, 2] $ , check "Results failing the test are not present" [1, 2] $
\x -> if x == Right 3 then Just DiscardResultAndTrace else Nothing \x -> if x == Right 3 then Just DiscardResultAndTrace else Nothing
, testCase "No traces kept when they get discared" $ testDiscardTrace discarder testAction
] ]
where 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 mvar <- newEmptyMVarInt
_ <- fork $ putMVar mvar 1 _ <- fork $ putMVar mvar 1
_ <- fork $ putMVar mvar 2 _ <- fork $ putMVar mvar 2
_ <- fork $ putMVar mvar 3 _ <- fork $ putMVar mvar 3
readMVar mvar 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 ()