Add tests for early-exit

.hlint.yaml

@@ -30,4 +30,5 @@
 - ignore: {name: Reduce duplication, within: Unit.Properties}
 - ignore: {name: Reduce duplication, within: Integration.Litmus}
 - ignore: {name: Reduce duplication, within: Integration.MultiThreaded}
+- ignore: {name: Reduce duplication, within: Integration.SCT}
 - ignore: {name: Reduce duplication, within: Integration.SingleThreaded}

dejafu-tests/dejafu-tests.cabal

@@ -26,7 +26,6 @@ library
                      , Integration.MultiThreaded
                      , Integration.Refinement
                      , Integration.Litmus
-                     , Integration.Discard
                      , Integration.Regressions
                      , Integration.SCT
                      , Integration.Names

dejafu-tests/lib/Integration.hs

@@ -3,7 +3,6 @@ module Integration where
 import           Test.Tasty.Options         (OptionDescription)
 
 import qualified Integration.Async          as A
-import qualified Integration.Discard        as D
 import qualified Integration.Litmus         as L
 import qualified Integration.MultiThreaded  as M
 import qualified Integration.Names          as N
@@ -18,7 +17,6 @@ import           Common
 tests :: [TestTree]
 tests =
   [ testGroup "Async"          A.tests
-  , testGroup "Discard"        D.tests
   , testGroup "Litmus"         L.tests
   , testGroup "MultiThreaded"  M.tests
   , testGroup "Names"          N.tests

dejafu-tests/lib/Integration/Discard.hs

@@ -1,43 +0,0 @@
-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
-
-tests :: [TestTree]
-tests = toTestList
-  [ check "All results are kept when none are discarded" [1, 2, 3] $
-      const Nothing
-  , check "No results are kept when all are discarded" [] $
-      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 = testDejafuWithSettings (set ldiscard (Just f) defaultSettings) 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 <- runSCTWithSettings (set ldiscard (Just discarder) defaultSettings) 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 ()

dejafu-tests/lib/Integration/SCT.hs

@@ -1,8 +1,13 @@
 module Integration.SCT where
 
-import           Control.Concurrent.Classy
+import           Control.Concurrent.Classy hiding (check)
 import           Control.Monad             (void)
+import           Control.Monad.IO.Class    (liftIO)
+import           Data.Foldable             (for_)
+import qualified Data.IORef                as IORef
 import qualified Data.Set                  as S
+import           System.Random             (mkStdGen)
+import           Test.DejaFu               (gives')
 import           Test.DejaFu.SCT
 import           Test.DejaFu.Types         (Failure(..))
 import           Test.Tasty.HUnit
@@ -11,7 +16,70 @@ import           Common
 
 tests :: [TestTree]
 tests =
-  toTestList
+  [ testGroup "Discard" discardTests
+  , testGroup "EarlyExit" earlyExitTests
+  , testGroup "Results" resultsSetTests
+  ]
+
+-------------------------------------------------------------------------------
+
+discardTests :: [TestTree]
+discardTests = toTestList
+    [ check "All results are kept when none are discarded" [1, 2, 3] $
+        const Nothing
+    , check "No results are kept when all are discarded" [] $
+        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 = testDejafuWithSettings (set ldiscard (Just f) defaultSettings) 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 discarder action = do
+      results <- runSCTWithSettings (set ldiscard (Just discarder) defaultSettings) 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 ()
+
+-------------------------------------------------------------------------------
+
+earlyExitTests :: [TestTree]
+earlyExitTests = toTestList
+    [ eeTest "Without discarding" [1,2,3,4,5] Nothing
+    , eeTest "Discarding some result" [1,2,4,5] $ Just (\efa -> if efa == Right 3 then Just DiscardResultAndTrace else Nothing)
+    , eeTest "Discarding the stop condition" [1,2,3,4] $ Just (\efa -> if efa == Right 5 then Just DiscardResultAndTrace else Nothing)
+    ]
+  where
+    eeTest name expected d = testCase name $ do
+      -- abuse IO to get a different result form every execution
+      r <- liftIO (IORef.newIORef (0::Int))
+      actual <- resultsSetWithSettings (eeSettings d) $ do
+        liftIO (IORef.modifyIORef r (+1))
+        liftIO (IORef.readIORef r)
+      S.fromList (map Right expected) @=? actual
+
+    eeSettings d =
+      set ldiscard d $
+      set learlyExit (Just (==Right 5)) $
+      fromWayAndMemType (randomly (mkStdGen 0) 150) defaultMemType
+
+-------------------------------------------------------------------------------
+
+resultsSetTests :: [TestTree]
+resultsSetTests = toTestList
     [ testCase "Proper results from resultsSet" $ do
         tested <- resultsSet defaultWay defaultMemType testAction
         results @=? tested