diff --git a/.hlint.yaml b/.hlint.yaml index 7c80ce3..7457e0a 100644 --- a/.hlint.yaml +++ b/.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} diff --git a/dejafu-tests/dejafu-tests.cabal b/dejafu-tests/dejafu-tests.cabal index 3c7b4ce..3c316e9 100644 --- a/dejafu-tests/dejafu-tests.cabal +++ b/dejafu-tests/dejafu-tests.cabal @@ -26,7 +26,6 @@ library , Integration.MultiThreaded , Integration.Refinement , Integration.Litmus - , Integration.Discard , Integration.Regressions , Integration.SCT , Integration.Names diff --git a/dejafu-tests/lib/Integration.hs b/dejafu-tests/lib/Integration.hs index f320d5f..003e7b7 100755 --- a/dejafu-tests/lib/Integration.hs +++ b/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 diff --git a/dejafu-tests/lib/Integration/Discard.hs b/dejafu-tests/lib/Integration/Discard.hs deleted file mode 100644 index 8de14c8..0000000 --- a/dejafu-tests/lib/Integration/Discard.hs +++ /dev/null @@ -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 () diff --git a/dejafu-tests/lib/Integration/SCT.hs b/dejafu-tests/lib/Integration/SCT.hs index 4884050..cdc3f4b 100644 --- a/dejafu-tests/lib/Integration/SCT.hs +++ b/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