barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2024-12-24 22:12:25 +03:00
Code Issues Projects Releases Wiki Activity

Use Settings throughout dejafu-tests

Browse Source
This commit is contained in:
Michael Walker 2018-03-04 15:00:16 +00:00
parent 89c14ff2f7
commit dccc2c7992
4 changed files with 20 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
dejafu-tests/lib/Common.hs
View File

@ -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 (W n c p w) = toTestList (TEST n c p [w] True)
toTestList (B n c p b) = toTestList (TEST n c p (defaultWaysFor b) True)
toTestList (TEST n c p w subc) = toTestList . testGroup n $
let mk (name, way) = testDejafuWay way defaultMemType name p c
in map mk w ++ [H.testProperty "dependency func." (prop_dep_fun c) | subc]
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 [second toSettings w] True)
toTestList (B n c p b) = toTestList (TEST n c p (map (second toSettings) (defaultWaysFor b)) True)
toTestList (TEST n c p ss subc) = toTestList . testGroup n $
let mk (name, settings) = testDejafuWithSettings settings name p c
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))

8
dejafu-tests/lib/Examples/ClassLaws.hs
View File

@ -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
rightTraces <- sctBound defaultMemType defaultBounds right
leftTraces <- runSCT defaultWay defaultMemType left
rightTraces <- runSCT defaultWay defaultMemType right
let toSet = fromList . map fst
pure (toSet leftTraces == toSet rightTraces)

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

@ -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

2
dejafu-tests/lib/Integration/SingleThreaded.hs
View File

@ -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_)