diff --git a/.hlint.yaml b/.hlint.yaml index 47e5964..7c80ce3 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -27,6 +27,7 @@ # I don't think these help. - ignore: {name: Avoid lambda, within: Integration.Refinement} +- 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.SingleThreaded} diff --git a/dejafu-tests/dejafu-tests.cabal b/dejafu-tests/dejafu-tests.cabal index 03611b5..77cd15b 100644 --- a/dejafu-tests/dejafu-tests.cabal +++ b/dejafu-tests/dejafu-tests.cabal @@ -40,7 +40,6 @@ library , Examples.SearchParty , Examples.SearchParty.Impredicative - , Test.Tasty.LeanCheck , Common , QSemN @@ -52,7 +51,6 @@ library , dejafu , exceptions , hedgehog - , leancheck , mtl , mwc-random , QuickCheck diff --git a/dejafu-tests/lib/Test/Tasty/LeanCheck.hs b/dejafu-tests/lib/Test/Tasty/LeanCheck.hs deleted file mode 100644 index c570d02..0000000 --- a/dejafu-tests/lib/Test/Tasty/LeanCheck.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Test.Tasty.LeanCheck where - -import Data.Proxy (Proxy(..)) -import qualified Test.LeanCheck as LeanCheck -import Test.Tasty.Options -import Test.Tasty.Providers -import Text.Printf (printf) -import Text.Read (readMaybe) - --- | Create a 'Test' for a LeanCheck 'LeanCheck.Testable' property. -testProperty :: LeanCheck.Testable p => TestName -> p -> TestTree -testProperty name = singleTest name . LeanCheckTest - --- | The number of tests for LeanCheck to try. -newtype LeanCheckTests = LeanCheckTests Int - deriving (Num, Ord, Eq, Real, Enum, Integral) - --- | A LeanCheck test. -data LeanCheckTest where - LeanCheckTest :: LeanCheck.Testable p => p -> LeanCheckTest - -instance IsOption LeanCheckTests where - defaultValue = 2500 - parseValue = fmap LeanCheckTests . readMaybe - optionName = pure "leancheck-tests" - optionHelp = pure "Tests to use for leancheck tests" - -instance IsTest LeanCheckTest where - testOptions = pure [Option (Proxy :: Proxy LeanCheckTests)] - - run opts (LeanCheckTest prop) _ = pure $ - let LeanCheckTests tests = lookupOption opts - in case LeanCheck.counterExample tests prop of - Just ce -> testFailed (printf "*** Failed! Counter example:\n%s" (unlines ce)) - Nothing -> testPassed (printf "+++ OK, passed %d tests." tests) diff --git a/dejafu-tests/lib/Unit.hs b/dejafu-tests/lib/Unit.hs index 981244a..df3d6d5 100644 --- a/dejafu-tests/lib/Unit.hs +++ b/dejafu-tests/lib/Unit.hs @@ -1,17 +1,91 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Unit where -import Test.Tasty.Options (OptionDescription) +import Data.Proxy (Proxy(..)) +import Test.Tasty (askOption, localOption) +import Test.Tasty.Hedgehog (HedgehogDiscardLimit(..), + HedgehogShrinkLimit(..), + HedgehogShrinkRetries(..), + HedgehogTestLimit) +import Test.Tasty.Options (IsOption(..), OptionDescription(..)) +import Text.Read (readMaybe) -import qualified Unit.Properties as P +import qualified Unit.Properties as P import Common -- | Run all the unit tests. tests :: [TestTree] -tests = +tests = map applyHedgehogOptions [ testGroup "Properties" P.tests ] -- | Tasty options options :: [OptionDescription] -options = [] +options = + [ Option (Proxy :: Proxy UnitHedgehogTestLimit) + , Option (Proxy :: Proxy UnitHedgehogDiscardLimit) + , Option (Proxy :: Proxy UnitHedgehogShrinkLimit) + , Option (Proxy :: Proxy UnitHedgehogShrinkRetries) + ] + + +------------------------------------------------------------------------------- +-- Hedgehog options + +-- | The number of successful test cases required before Hedgehog will pass a test +newtype UnitHedgehogTestLimit = UnitHedgehogTestLimit Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +instance IsOption UnitHedgehogTestLimit where + defaultValue = 1500 + parseValue = fmap UnitHedgehogTestLimit . readMaybe + optionName = pure "unit-hedgehog-tests" + optionHelp = pure "hedgehog-tests for the unit tests" + +-- | The number of discarded cases allowed before Hedgehog will fail a test +newtype UnitHedgehogDiscardLimit = UnitHedgehogDiscardLimit Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +instance IsOption UnitHedgehogDiscardLimit where + defaultValue = 1000 + parseValue = fmap UnitHedgehogDiscardLimit . readMaybe + optionName = pure "unit-hedgehog-discards" + optionHelp = pure "hedgehog-discards for the unit tests" + +-- | The number of shrinks allowed before Hedgehog will fail a test +newtype UnitHedgehogShrinkLimit = UnitHedgehogShrinkLimit Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +instance IsOption UnitHedgehogShrinkLimit where + defaultValue = + let HedgehogShrinkLimit d = defaultValue + in fromIntegral d + parseValue = fmap UnitHedgehogShrinkLimit . readMaybe + optionName = pure "unit-hedgehog-shrinks" + optionHelp = pure "hedgehog-shrinks for the unit tests" + +-- | The number of times to re-run a test during shrinking +newtype UnitHedgehogShrinkRetries = UnitHedgehogShrinkRetries Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +instance IsOption UnitHedgehogShrinkRetries where + defaultValue = + let HedgehogShrinkRetries d = defaultValue + in fromIntegral d + parseValue = fmap UnitHedgehogShrinkRetries . readMaybe + optionName = pure "unit-hedgehog-retries" + optionHelp = pure "hedgehog-retries for the unit tests" + +-- | Apply the Hedgehog options. +applyHedgehogOptions :: TestTree -> TestTree +applyHedgehogOptions tt0 = + askOption $ \(UnitHedgehogTestLimit tl) -> + askOption $ \(UnitHedgehogDiscardLimit dl) -> + askOption $ \(UnitHedgehogShrinkLimit sl) -> + askOption $ \(UnitHedgehogShrinkRetries sr) -> + localOption (fromIntegral tl :: HedgehogTestLimit) $ + localOption (fromIntegral dl :: HedgehogDiscardLimit) $ + localOption (fromIntegral sl :: HedgehogShrinkLimit) $ + localOption (fromIntegral sr :: HedgehogShrinkRetries) tt0 diff --git a/dejafu-tests/lib/Unit/Properties.hs b/dejafu-tests/lib/Unit/Properties.hs index 14ae4b9..ef3a226 100644 --- a/dejafu-tests/lib/Unit/Properties.hs +++ b/dejafu-tests/lib/Unit/Properties.hs @@ -1,29 +1,22 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} module Unit.Properties where import qualified Control.Exception as E import Control.Monad (zipWithM) import qualified Control.Monad.ST as ST import qualified Data.Foldable as F -import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (fromJust, isJust) -import Data.Proxy (Proxy(..)) import qualified Data.Sequence as S -import Data.Set (Set) import qualified Data.Set as Set import qualified Data.STRef as ST +import qualified Hedgehog as H +import qualified Hedgehog.Gen as HGen import qualified Test.DejaFu.Conc.Internal.Common as D import qualified Test.DejaFu.Conc.Internal.Memory as Mem import qualified Test.DejaFu.Internal as D import qualified Test.DejaFu.SCT.Internal.DPOR as SCT -import Test.DejaFu.Types (Lookahead, ThreadAction) import qualified Test.DejaFu.Types as D -import Test.LeanCheck (Listable(..), cons0, cons1, - cons2, cons3, mapT, (==>), - (><), (\/)) -import Test.Tasty.LeanCheck (testProperty) +import qualified Test.Tasty.Hedgehog as H import Common @@ -39,111 +32,177 @@ tests = classLawProps :: [TestTree] classLawProps = toTestList - [ testGroup "Id" (eqord (Proxy :: Proxy D.Id)) - , testGroup "Failure" (eqord (Proxy :: Proxy D.Failure)) + [ testGroup "Id" (eqord genId) + , testGroup "Failure" (eqord genFailure) ] where - eqord :: forall a. (Eq a, Ord a, Listable a, Show a) => Proxy a -> [TestTree] - eqord _ = - [ testProperty "Reflexivity (==)" $ \(x :: a) -> x == x - , testProperty "Symmetry (==)" $ \(x :: a) y -> (x == y) == (y == x) - , testProperty "Transitivity (==)" $ \(x :: a) y z -> x == y && y == z ==> x == z - , testProperty "Reflexivity (<=)" $ \(x :: a) -> x <= x - , testProperty "Antisymmetry (<=)" $ \(x :: a) y -> x <= y && y <= x ==> x == y - , testProperty "Transitivity (<=)" $ \(x :: a) y z -> x <= y && y <= z ==> x <= z - , testProperty "Eq / Ord Consistency" $ \(x :: a) y -> x == y ==> x <= y + eqord gen = + [ H.testProperty "Reflexivity (==)" . H.property $ do + x <- H.forAll gen + x H.=== x + + , H.testProperty "Symmetry (==)" . H.property $ do + x <- H.forAll gen + y <- H.forAll gen + (x == y) H.=== (y == x) + + , H.testProperty "Transitivity (==)" . H.property $ do + x <- H.forAll gen + y <- H.forAll (HGen.filter (==x) gen) + z <- H.forAll (HGen.filter (==y) gen) + x H.=== z + + , H.testProperty "Reflexivity (<=)" . H.property $ do + x <- H.forAll gen + H.assert (x <= x) + + , H.testProperty "Antisymmetry (<=)" . H.property $ do + x <- H.forAll gen + y <- H.forAll (HGen.filter (\y -> x <= y && y <= x) gen) + x H.=== y + + , H.testProperty "Transitivity (<=)" . H.property $ do + x <- H.forAll gen + y <- H.forAll (HGen.filter (x<=) gen) + z <- H.forAll (HGen.filter (y<=) gen) + H.assert (x <= z) + + , H.testProperty "Eq / Ord Consistency" . H.property $ do + x <- H.forAll gen + y <- H.forAll (HGen.filter (==x) gen) + H.assert (x <= y) + H.assert (y <= x) ] ------------------------------------------------------------------------------- commonProps :: [TestTree] commonProps = toTestList - [ testProperty "simplifyAction a == simplifyLookahead (rewind a)" $ - \act -> canRewind act ==> - D.simplifyAction act == D.simplifyLookahead (rewind' act) + [ H.testProperty "simplifyAction a == simplifyLookahead (rewind a)" . H.property $ do + act <- H.forAll genThreadAction + case D.rewind act of + Just lh -> D.simplifyAction act H.=== D.simplifyLookahead lh + Nothing -> H.discard - , testProperty "isBarrier a ==> synchronises a r" $ - \a r -> D.isBarrier a ==> D.synchronises a r + , H.testProperty "isBarrier a ==> synchronises a r" . H.property $ do + a <- H.forAll (HGen.filter D.isBarrier genActionType) + r <- H.forAll genCRefId + H.assert (D.synchronises a r) - , testProperty "isCommit a r ==> synchronises a r" $ - \a r -> D.isCommit a r ==> D.synchronises a r + , H.testProperty "isCommit a r ==> synchronises a r" . H.property $ do + a <- H.forAll genPartiallySynchronisedActionType + case D.crefOf a of + Just r -> H.assert (D.synchronises a r) + _ -> H.discard ] ------------------------------------------------------------------------------- memoryProps :: [TestTree] memoryProps = toTestList - [ testProperty "bufferWrite emptyBuffer k c a /= emptyBuffer" $ - \k a -> crefProp $ \cref -> do - wb <- Mem.bufferWrite Mem.emptyBuffer k cref a - not <$> wb `eqWB` Mem.emptyBuffer + [ H.testProperty "bufferWrite emptyBuffer k c a /= emptyBuffer" . H.property $ do + k <- H.forAll genWBKey + a <- H.forAll genInt + res <- crefProp $ \cref -> do + wb <- Mem.bufferWrite Mem.emptyBuffer k cref a + wb `eqWB` Mem.emptyBuffer + H.assert (not res) - , testProperty "commitWrite emptyBuffer k == emptyBuffer" $ - \k -> ST.runST $ do - wb <- Mem.commitWrite Mem.emptyBuffer k - wb `eqWB` Mem.emptyBuffer + , H.testProperty "commitWrite emptyBuffer k == emptyBuffer" . H.property $ do + k <- H.forAll genWBKey + H.assert $ ST.runST $ do + wb <- Mem.commitWrite Mem.emptyBuffer k + wb `eqWB` Mem.emptyBuffer - , testProperty "commitWrite (bufferWrite emptyBuffer k a) k == emptyBuffer" $ - \k a -> crefProp $ \cref -> do - wb1 <- Mem.bufferWrite Mem.emptyBuffer k cref a - wb2 <- Mem.commitWrite wb1 k - wb2 `eqWB` Mem.emptyBuffer + , H.testProperty "commitWrite (bufferWrite emptyBuffer k a) k == emptyBuffer" . H.property $ do + k <- H.forAll genWBKey + a <- H.forAll genInt + res <- crefProp $ \cref -> do + wb1 <- Mem.bufferWrite Mem.emptyBuffer k cref a + wb2 <- Mem.commitWrite wb1 k + wb2 `eqWB` Mem.emptyBuffer + H.assert res - , testProperty "Single buffered write/read from same thread" $ - \k@(tid, _) a -> crefProp $ \cref -> do - _ <- Mem.bufferWrite Mem.emptyBuffer k cref a - (a ==) <$> Mem.readCRef cref tid + , H.testProperty "Single buffered write/read from same thread" . H.property $ do + k@(tid, _) <- H.forAll genWBKey + a <- H.forAll genInt + res <- crefProp $ \cref -> do + _ <- Mem.bufferWrite Mem.emptyBuffer k cref a + Mem.readCRef cref tid + a H.=== res - , testProperty "Overriding buffered write/read from same thread" $ - \k@(tid, _) a1 a2 -> crefProp $ \cref -> do - _ <- Mem.bufferWrite Mem.emptyBuffer k cref a1 - _ <- Mem.bufferWrite Mem.emptyBuffer k cref a2 - (a2 ==) <$> Mem.readCRef cref tid + , H.testProperty "Overriding buffered write/read from same thread" . H.property $ do + k@(tid, _) <- H.forAll genWBKey + a1 <- H.forAll genInt + a2 <- H.forAll genInt + res <- crefProp $ \cref -> do + _ <- Mem.bufferWrite Mem.emptyBuffer k cref a1 + _ <- Mem.bufferWrite Mem.emptyBuffer k cref a2 + Mem.readCRef cref tid + a2 H.=== res - , testProperty "Buffered write/read from different thread" $ - \k1@(tid1, _) k2@(tid2, _) a1 a2 -> crefProp $ \cref -> do - _ <- Mem.bufferWrite Mem.emptyBuffer k1 cref a1 - _ <- Mem.bufferWrite Mem.emptyBuffer k2 cref a2 - a' <- Mem.readCRef cref tid1 - pure (tid1 /= tid2 ==> a' == a1) + , H.testProperty "Buffered write/read from different thread" . H.property $ do + k1@(tid, _) <- H.forAll genWBKey + k2 <- H.forAll (HGen.filter ((/=tid) . fst) genWBKey) + a1 <- H.forAll genInt + a2 <- H.forAll genInt + res <- crefProp $ \cref -> do + _ <- Mem.bufferWrite Mem.emptyBuffer k1 cref a1 + _ <- Mem.bufferWrite Mem.emptyBuffer k2 cref a2 + Mem.readCRef cref tid + a1 H.=== res ] where - crefProp :: (forall s. D.CRef (ST.STRef s) Int -> ST.ST s Bool) -> D.CRefId -> Bool - crefProp prop crid = ST.runST $ makeCRef crid >>= prop + crefProp + :: (Monad m, Show a) + => (forall s. D.CRef (ST.STRef s) Int -> ST.ST s a) + -> H.PropertyT m a + crefProp p = do + crefId <- H.forAll genCRefId + pure $ ST.runST $ do + cref <- makeCRef crefId + p cref ------------------------------------------------------------------------------- sctProps :: [TestTree] sctProps = toTestList - [ testProperty "canInterrupt ==> canInterruptL" $ - \ds tid act -> - canRewind act && SCT.canInterrupt ds tid act ==> - SCT.canInterruptL ds tid (rewind' act) + [ H.testProperty "canInterrupt ==> canInterruptL" . H.property $ do + ds <- H.forAll genDepState + tid <- H.forAll genThreadId + act <- H.forAll (HGen.filter (SCT.canInterrupt ds tid) genThreadAction) + case D.rewind act of + Just lh -> H.assert (SCT.canInterruptL ds tid lh) + Nothing -> H.discard - , testProperty "dependent ==> dependent'" $ - \ds tid1 tid2 ta1 ta2 -> - canRewind ta2 && SCT.dependent ds tid1 ta1 tid2 ta2 ==> - SCT.dependent' ds tid1 ta1 tid2 (rewind' ta2) + , H.testProperty "dependent ==> dependent'" . H.property $ do + ds <- H.forAll genDepState + tid1 <- H.forAll genThreadId + tid2 <- H.forAll genThreadId + ta1 <- H.forAll genThreadAction + ta2 <- H.forAll (HGen.filter (SCT.dependent ds tid1 ta1 tid2) genThreadAction) + case D.rewind ta2 of + Just lh -> H.assert (SCT.dependent' ds tid1 ta1 tid2 lh) + Nothing -> H.discard - , testProperty "dependent x y == dependent y x" $ - \ds tid1 tid2 ta1 ta2 -> - SCT.dependent ds tid1 ta1 tid2 ta2 == - SCT.dependent ds tid2 ta2 tid1 ta1 + , H.testProperty "dependent x y == dependent y x" . H.property $ do + ds <- H.forAll genDepState + tid1 <- H.forAll genThreadId + tid2 <- H.forAll genThreadId + ta1 <- H.forAll genThreadAction + ta2 <- H.forAll genThreadAction + SCT.dependent ds tid1 ta1 tid2 ta2 H.=== SCT.dependent ds tid2 ta2 tid1 ta1 - , testProperty "dependentActions x y == dependentActions y x" $ - \ds a1 a2 -> - SCT.dependentActions ds a1 a2 == SCT.dependentActions ds a2 a1 + , H.testProperty "dependentActions x y == dependentActions y x" . H.property $ do + ds <- H.forAll genDepState + a1 <- H.forAll genActionType + a2 <- H.forAll genActionType + SCT.dependentActions ds a1 a2 H.=== SCT.dependentActions ds a2 a1 ] ------------------------------------------------------------------------------- -- Utils -canRewind :: ThreadAction -> Bool -canRewind = isJust . D.rewind - -rewind' :: ThreadAction -> Lookahead -rewind' = fromJust . D.rewind - makeCRef :: D.CRefId -> ST.ST t (D.CRef (ST.STRef t) Int) makeCRef crid = D.CRef crid <$> ST.newSTRef (M.empty, 0, 42) @@ -177,115 +236,168 @@ eqWB (Mem.WriteBuffer wb1) (Mem.WriteBuffer wb2) = andM (pure (ks1 == ks2) : q <- p if q then andM ps else pure False +(==>) :: Monad m => Bool -> H.PropertyT m a -> H.PropertyT m a +False ==> _ = H.discard +True ==> p = p +infixr 0 ==> + ------------------------------------------------------------------------------- --- Typeclass instances +-- Generators -instance Listable D.ThreadId where - tiers = mapT D.ThreadId tiers +genThreadId :: H.Gen D.ThreadId +genThreadId = D.ThreadId <$> genId -instance Listable D.CRefId where - tiers = mapT D.CRefId tiers +genCRefId :: H.Gen D.CRefId +genCRefId = D.CRefId <$> genId -instance Listable D.MVarId where - tiers = mapT D.MVarId tiers +genMVarId :: H.Gen D.MVarId +genMVarId = D.MVarId <$> genId -instance Listable D.TVarId where - tiers = mapT D.TVarId tiers +genTVarId :: H.Gen D.TVarId +genTVarId = D.TVarId <$> genId -instance Listable D.Id where - tiers = mapT (D.Id Nothing) tiers +genId :: H.Gen D.Id +genId = D.Id <$> HGen.maybe genString <*> genSmallInt -instance Listable D.ThreadAction where - tiers = - cons1 D.Fork - \/ cons0 D.MyThreadId - \/ cons1 D.GetNumCapabilities - \/ cons1 D.SetNumCapabilities - \/ cons0 D.Yield - \/ cons1 D.ThreadDelay - \/ cons1 D.NewMVar - \/ cons2 D.PutMVar - \/ cons1 D.BlockedPutMVar - \/ cons3 D.TryPutMVar - \/ cons1 D.ReadMVar - \/ cons2 D.TryReadMVar - \/ cons1 D.BlockedReadMVar - \/ cons2 D.TakeMVar - \/ cons1 D.BlockedTakeMVar - \/ cons3 D.TryTakeMVar - \/ cons1 D.NewCRef - \/ cons1 D.ReadCRef - \/ cons1 D.ReadCRefCas - \/ cons1 D.ModCRef - \/ cons1 D.ModCRefCas - \/ cons1 D.WriteCRef - \/ cons2 D.CasCRef - \/ cons2 D.CommitCRef - \/ cons2 D.STM - \/ cons1 D.BlockedSTM - \/ cons0 D.Catching - \/ cons0 D.PopCatching - \/ cons0 D.Throw - \/ cons1 D.ThrowTo - \/ cons1 D.BlockedThrowTo - \/ cons0 D.Killed - \/ cons2 D.SetMasking - \/ cons2 D.ResetMasking - \/ cons0 D.LiftIO - \/ cons0 D.Return - \/ cons0 D.Stop - \/ cons0 D.Subconcurrency - \/ cons0 D.StopSubconcurrency +genFailure :: H.Gen D.Failure +genFailure = HGen.element $ + [ D.InternalError + , D.Abort + , D.Deadlock + , D.STMDeadlock + , D.IllegalSubconcurrency + ] ++ map D.UncaughtException -- have a few different exception types + [ E.toException E.Overflow + , E.toException E.ThreadKilled + , E.toException E.NonTermination + ] -instance Listable D.TAction where - tiers = - cons1 D.TNew - \/ cons1 D.TRead - \/ cons1 D.TWrite - \/ cons0 D.TRetry - \/ cons2 D.TOrElse - \/ cons0 D.TThrow - \/ cons2 D.TCatch - \/ cons0 D.TStop +genWBKey :: H.Gen (D.ThreadId, Maybe D.CRefId) +genWBKey = (,) <$> genThreadId <*> HGen.maybe genCRefId -instance Listable E.MaskingState where - list = - [ E.Unmasked - , E.MaskedInterruptible - , E.MaskedUninterruptible - ] +genThreadAction :: H.Gen D.ThreadAction +genThreadAction = HGen.choice + [ D.Fork <$> genThreadId + , pure D.MyThreadId + , D.GetNumCapabilities <$> genSmallInt + , D.SetNumCapabilities <$> genSmallInt + , pure D.Yield + , D.ThreadDelay <$> genSmallInt + , D.NewMVar <$> genMVarId + , D.PutMVar <$> genMVarId <*> genSmallList genThreadId + , D.BlockedPutMVar <$> genMVarId + , D.TryPutMVar <$> genMVarId <*> HGen.bool <*> genSmallList genThreadId + , D.ReadMVar <$> genMVarId + , D.TryReadMVar <$> genMVarId <*> HGen.bool + , D.BlockedReadMVar <$> genMVarId + , D.TakeMVar <$> genMVarId <*> genSmallList genThreadId + , D.BlockedTakeMVar <$> genMVarId + , D.TryTakeMVar <$> genMVarId <*> HGen.bool <*> genSmallList genThreadId + , D.NewCRef <$> genCRefId + , D.ReadCRef <$> genCRefId + , D.ReadCRefCas <$> genCRefId + , D.ModCRef <$> genCRefId + , D.ModCRefCas <$> genCRefId + , D.WriteCRef <$> genCRefId + , D.CasCRef <$> genCRefId <*> HGen.bool + , D.CommitCRef <$> genThreadId <*> genCRefId + , D.STM <$> genSmallList genTAction <*> genSmallList genThreadId + , D.BlockedSTM <$> genSmallList genTAction + , pure D.Catching + , pure D.PopCatching + , pure D.Throw + , D.ThrowTo <$> genThreadId + , D.BlockedThrowTo <$> genThreadId + , pure D.Killed + , D.SetMasking <$> HGen.bool <*> genMaskingState + , D.ResetMasking <$> HGen.bool <*> genMaskingState + , pure D.LiftIO + , pure D.Return + , pure D.Stop + , pure D.Subconcurrency + , pure D.StopSubconcurrency + ] -instance Listable D.ActionType where - tiers = - cons1 D.UnsynchronisedRead - \/ cons1 D.UnsynchronisedWrite - \/ cons0 D.UnsynchronisedOther - \/ cons1 D.PartiallySynchronisedCommit - \/ cons1 D.PartiallySynchronisedWrite - \/ cons1 D.PartiallySynchronisedModify - \/ cons1 D.SynchronisedModify - \/ cons1 D.SynchronisedRead - \/ cons1 D.SynchronisedWrite - \/ cons0 D.SynchronisedOther +genTAction :: H.Gen D.TAction +genTAction = HGen.choice + [ D.TNew <$> genTVarId + , D.TRead <$> genTVarId + , D.TWrite <$> genTVarId + , pure D.TRetry + , HGen.small $ D.TOrElse <$> genSmallList genTAction <*> HGen.maybe (genSmallList genTAction) + , pure D.TThrow + , HGen.small $ D.TCatch <$> genSmallList genTAction <*> HGen.maybe (genSmallList genTAction) + , pure D.TStop + ] -instance Listable SCT.DepState where - tiers = mapT (\(a,(b,c)) -> SCT.DepState a b c) (tiers >< tiers >< tiers) +genMaskingState :: H.Gen E.MaskingState +genMaskingState = HGen.element + [ E.Unmasked + , E.MaskedInterruptible + , E.MaskedUninterruptible + ] -instance (Ord k, Listable k, Listable v) => Listable (Map k v) where - tiers = mapT M.fromList tiers +genActionType :: H.Gen D.ActionType +genActionType = HGen.choice + [ genUnsynchronisedActionType + , genPartiallySynchronisedActionType + , genSynchronisedActionType + ] -instance (Ord v, Listable v) => Listable (Set v) where - tiers = mapT Set.fromList tiers +genUnsynchronisedActionType :: H.Gen D.ActionType +genUnsynchronisedActionType = HGen.choice + [ D.UnsynchronisedRead <$> genCRefId + , D.UnsynchronisedWrite <$> genCRefId + , pure D.UnsynchronisedOther + ] -instance Listable D.Failure where - list = - [ D.InternalError - , D.Abort - , D.Deadlock - , D.STMDeadlock - , D.IllegalSubconcurrency - ] ++ map D.UncaughtException -- have a few different exception types - [ E.toException E.Overflow - , E.toException E.ThreadKilled - , E.toException E.NonTermination - ] +genPartiallySynchronisedActionType :: H.Gen D.ActionType +genPartiallySynchronisedActionType = HGen.choice + [ D.PartiallySynchronisedCommit <$> genCRefId + , D.PartiallySynchronisedWrite <$> genCRefId + , D.PartiallySynchronisedModify <$> genCRefId + ] + +genSynchronisedActionType :: H.Gen D.ActionType +genSynchronisedActionType = HGen.choice + [ D.SynchronisedModify <$> genCRefId + , D.SynchronisedRead <$> genMVarId + , D.SynchronisedWrite <$> genMVarId + , pure D.SynchronisedOther + ] + +genDepState :: H.Gen SCT.DepState +genDepState = SCT.DepState + <$> genMap genCRefId HGen.bool + <*> genSet genMVarId + <*> genMap genThreadId genMaskingState + +------------------------------------------------------------------------------- +-- Utility generators + +genSmallInt :: H.Gen Int +genSmallInt = genIntFromTo 0 10 + +genInt :: H.Gen Int +genInt = genIntFromTo 0 100 + +genIntFromTo :: Int -> Int -> H.Gen Int +genIntFromTo from = HGen.int . HRange.linear from + +genMap :: Ord k => H.Gen k -> H.Gen v -> H.Gen (M.Map k v) +genMap genKey genVal = M.fromList <$> genList ((,) <$> genKey <*> genVal) + +genSet :: Ord a => H.Gen a -> H.Gen (Set.Set a) +genSet gen = Set.fromList <$> genList gen + +genString :: H.Gen String +genString = genSmallList HGen.enumBounded + +genList :: H.Gen a -> H.Gen [a] +genList = genListUpTo 100 + +genSmallList :: H.Gen a -> H.Gen [a] +genSmallList = genListUpTo 10 + +genListUpTo :: Int -> H.Gen a -> H.Gen [a] +genListUpTo = HGen.list . HRange.linear 0