Use Settings throughout dejafu-tests

dejafu-tests/lib/Common.hs

@@ -2,6 +2,7 @@
 
 module Common (module Common, module Test.Tasty.DejaFu, T.TestTree, T.expectFail) where
 
+import           Control.Arrow                 (second)
 import           Control.Exception             (ArithException, ArrayException,
                                                 SomeException, displayException)
 import           Control.Monad                 (void)
@@ -38,12 +39,12 @@ instance IsTest T.TestTree where
   toTestList t = [t]
 
 instance IsTest T where
-  toTestList (T n c p) = toTestList (TEST n c p defaultWays True)
+  toTestList (T n c p) = toTestList (TEST n c p (map (second toSettings) defaultWays) True)
-  toTestList (W n c p w) = toTestList (TEST n c p [w] True)
+  toTestList (W n c p w) = toTestList (TEST n c p [second toSettings w] True)
-  toTestList (B n c p b) = toTestList (TEST n c p (defaultWaysFor b) True)
+  toTestList (B n c p b) = toTestList (TEST n c p (map (second toSettings) (defaultWaysFor b)) True)
-  toTestList (TEST n c p w subc) = toTestList . testGroup n $
+  toTestList (TEST n c p ss subc) = toTestList . testGroup n $
-    let mk (name, way) = testDejafuWay way defaultMemType name p c
+    let mk (name, settings) = testDejafuWithSettings settings name p c
-    in map mk w ++ [H.testProperty "dependency func." (prop_dep_fun c) | subc]
+    in map mk ss ++ [H.testProperty "dependency func." (prop_dep_fun c) | subc]
 
 instance IsTest t => IsTest [t] where
   toTestList = concatMap toTestList
@@ -52,7 +53,10 @@ data T where
   T :: (Eq a, Show a) => String -> ConcIO a -> Predicate a -> T
   W :: (Eq a, Show a) => String -> ConcIO a -> Predicate a -> (String, Way) -> T
   B :: (Eq a, Show a) => String -> ConcIO a -> Predicate a -> Bounds -> T
-  TEST :: (Eq a, Show a) => String -> ConcIO a -> Predicate a -> [(String, Way)] -> Bool -> T
+  TEST :: (Eq a, Show a) => String -> ConcIO a -> Predicate a -> [(String, Settings IO a)] -> Bool -> T
+
+toSettings :: Applicative f => Way -> Settings f a
+toSettings w = fromWayAndMemType w defaultMemType
 
 defaultWays :: [(String, Way)]
 defaultWays = defaultWaysFor defaultBounds
@@ -72,13 +76,13 @@ djfu :: (Eq a, Show a) => String -> Predicate a -> ConcIO a -> [T.TestTree]
 djfu name p c = toTestList $ W name c p ("systematically", systematically defaultBounds)
 
 djfuS :: (Eq a, Show a) => String -> Predicate a -> ConcIO a -> [T.TestTree]
-djfuS name p c = toTestList $ TEST name c p [("systematically", systematically defaultBounds)] False
+djfuS name p c = toTestList $ TEST name c p [("systematically", toSettings (systematically defaultBounds))] False
 
 djfuT :: (Eq a, Show a) => String -> Predicate a -> ConcIO a -> [T.TestTree]
 djfuT name p c = toTestList $ T name c p
 
 djfuTS :: (Eq a, Show a) => String -> Predicate a -> ConcIO a -> [T.TestTree]
-djfuTS name p c = toTestList $ TEST name c p defaultWays False
+djfuTS name p c = toTestList $ TEST name c p (map (second toSettings) defaultWays) False
 
 alwaysFailsWith :: (Failure -> Bool) -> Predicate a
 alwaysFailsWith p = alwaysTrue (either p (const False))

dejafu-tests/lib/Examples/ClassLaws.hs

@@ -13,9 +13,9 @@ import           Control.Monad.IO.Class   (MonadIO, liftIO)
 import           Data.Maybe               (isJust)
 import           Data.Set                 (fromList)
 import qualified Hedgehog                 as H
-import           Test.DejaFu              (defaultBounds, defaultMemType)
+import           Test.DejaFu              (defaultMemType, defaultWay)
 import           Test.DejaFu.Conc         (ConcIO)
-import           Test.DejaFu.SCT          (sctBound)
+import           Test.DejaFu.SCT          (runSCT)
 
 import           Common
 
@@ -192,8 +192,8 @@ eq left right = runConcurrently left `eq'` runConcurrently right
 
 eq' :: (MonadIO m, Ord a) => ConcIO a -> ConcIO a -> m Bool
 eq' left right = liftIO $ do
-  leftTraces  <- sctBound defaultMemType defaultBounds left
+  leftTraces  <- runSCT defaultWay defaultMemType left
-  rightTraces <- sctBound defaultMemType defaultBounds right
+  rightTraces <- runSCT defaultWay defaultMemType right
   let toSet = fromList . map fst
   pure (toSet leftTraces == toSet rightTraces)
 

dejafu-tests/lib/Integration/Discard.hs

@@ -21,7 +21,7 @@ tests = toTestList
   , testCase "No traces kept when they get discared" $ testDiscardTrace discarder testAction
   ]
   where
-    check name xs f = testDejafuDiscard f defaultWay defaultMemType name (gives' xs) testAction
+    check name xs f = testDejafuWithSettings (set ldiscard (Just f) defaultSettings) name (gives' xs) testAction
     testAction = do
       mvar <- newEmptyMVarInt
       _ <- fork $ putMVar mvar 1
@@ -34,7 +34,7 @@ tests = toTestList
 
 testDiscardTrace :: (Either Failure a -> Maybe Discard) -> ConcIO a -> Assertion
 testDiscardTrace discarder action = do
-  results <- runSCTDiscard discarder defaultWay defaultMemType action
+  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

dejafu-tests/lib/Integration/SingleThreaded.hs

@@ -7,7 +7,7 @@ import           Control.Exception         (ArithException(..),
 import           Test.DejaFu               (Failure(..), gives, gives', isAbort,
                                             isDeadlock, isIllegalDontCheck,
                                             isUncaughtException)
-import           Test.DejaFu.Defaults      (defaultLengthBound)
+import           Test.DejaFu.Settings      (defaultLengthBound)
 
 import           Control.Concurrent.Classy
 import           Control.Monad             (replicateM_)