packages feed

dejafu 0.7.0.2 → 0.7.1.0

raw patch · 9 files changed

+306/−84 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

- Test.DejaFu.STM: instance GHC.Base.Monad n => Control.Monad.STM.Class.MonadSTM (Test.DejaFu.STM.STMLike n r)
+ Test.DejaFu: DiscardResultAndTrace :: Discard
+ Test.DejaFu: DiscardTrace :: Discard
+ Test.DejaFu: data Discard
+ Test.DejaFu: defaultDiscarder :: Either Failure a -> Maybe Discard
+ Test.DejaFu: dejafuDiscard :: Show a => (Either Failure a -> Maybe Discard) -> Way -> MemType -> (forall t. ConcST t a) -> (String, Predicate a) -> IO Bool
+ Test.DejaFu: dejafuDiscardIO :: Show a => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcIO a -> (String, Predicate a) -> IO Bool
+ Test.DejaFu.Common: runRefCont :: MonadRef r n => (n () -> x) -> (a -> Maybe b) -> ((a -> x) -> x) -> n (x, r (Maybe b))
+ Test.DejaFu.Defaults: defaultDiscarder :: Either Failure a -> Maybe Discard
+ Test.DejaFu.SCT: DiscardResultAndTrace :: Discard
+ Test.DejaFu.SCT: DiscardTrace :: Discard
+ Test.DejaFu.SCT: data Discard
+ Test.DejaFu.SCT: instance Control.DeepSeq.NFData Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Classes.Eq Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Classes.Ord Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Enum.Bounded Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Enum.Enum Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Read.Read Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: instance GHC.Show.Show Test.DejaFu.SCT.Discard
+ Test.DejaFu.SCT: resultsSetDiscard :: (MonadRef r n, Ord a) => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n (Set (Either Failure a))
+ Test.DejaFu.SCT: resultsSetDiscard' :: (MonadRef r n, Ord a, NFData a) => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n (Set (Either Failure a))
+ Test.DejaFu.SCT: runSCTDiscard :: MonadRef r n => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.SCT: runSCTDiscard' :: (MonadRef r n, NFData a) => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.SCT: sctBoundDiscard :: MonadRef r n => (Either Failure a -> Maybe Discard) -> MemType -> Bounds -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.SCT: sctUniformRandomDiscard :: (MonadRef r n, RandomGen g) => (Either Failure a -> Maybe Discard) -> MemType -> g -> Int -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.SCT: sctWeightedRandomDiscard :: (MonadRef r n, RandomGen g) => (Either Failure a -> Maybe Discard) -> MemType -> g -> Int -> Int -> ConcT r n a -> n [(Either Failure a, Trace)]
+ Test.DejaFu.STM: instance Control.Monad.STM.Class.MonadSTM (Test.DejaFu.STM.STMLike n r)

Files

CHANGELOG.markdown view
@@ -6,6 +6,39 @@ This project is versioned according to the [Package Versioning Policy](https://pvp.haskell.org), the *de facto* standard Haskell versioning scheme. +0.7.1.0 [2017-08-10] (git tag: [dejafu-0.7.1.0][])+-------++https://hackage.haskell.org/package/dejafu-0.7.1.0++### Test.DejaFu++- Exposed the new SCT discard functions through `dejafuDiscard` and `dejafuDiscardIO`.++    There are no `dejafusDiscard` and `dejafusDiscardIO` functions because this would probably be+    confusing, as the traces are shared.++- The `Discard` type and `defaultDiscard` function are also exposed.++### Test.DejaFu.Defaults++- Added a new `defaultDiscarder` function, which discards nothing.++### Test.DejaFu.SCT++- Added new SCT functions to selectively discard results or traces, which can be a significant+  memory saving if you know what sorts of results you are interested in:+    - New type: `Discard`.+    - New functions: `runSCTDiscard`, `resultsSetDiscard`, `sctBoundDiscard`,+      `sctUniformRandomDiscard`, and `sctWeightedRandomDiscard`.+    - `resultsSet` and `resultsSet'` now discard traces as they are produced, rather than all at the+      end, greatly improving performance when traces are large.++[dejafu-0.7.1.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.7.1.0+++---------------------------------------------------------------------------------------------------+  0.7.0.2 [2017-06-12] (git tag: [dejafu-0.7.0.2][]) -------
Test/DejaFu.hs view
@@ -107,6 +107,12 @@   , dejafusWay   , dejafusWayIO +  , Discard(..)+  , defaultDiscarder++  , dejafuDiscard+  , dejafuDiscardIO+   -- ** Memory Models    -- | Threads running under modern multicore processors do not behave@@ -378,8 +384,27 @@   -> (String, Predicate a)   -- ^ The predicate (with a name) to check   -> IO Bool-dejafuWay way memtype conc test = dejafusWay way memtype conc [test]+dejafuWay = dejafuDiscard (const Nothing) +-- | Variant of 'dejafuWay' which can selectively discard results.+--+-- @since 0.7.1.0+dejafuDiscard :: Show a+  => (Either Failure a -> Maybe Discard)+  -- ^ Selectively discard results.+  -> Way+  -- ^ How to run the concurrent program.+  -> MemType+  -- ^ The memory model to use for non-synchronised @CRef@ operations.+  -> (forall t. ConcST t a)+  -- ^ The computation to test+  -> (String, Predicate a)+  -- ^ The predicate (with a name) to check+  -> IO Bool+dejafuDiscard discard way memtype conc (name, test) = do+  let traces = runST (runSCTDiscard discard way memtype conc)+  doTest name (test traces)+ -- | Variant of 'dejafu' which takes a collection of predicates to -- test, returning 'True' if all pass. --@@ -421,8 +446,15 @@ -- -- @since 0.6.0.0 dejafuWayIO :: Show a => Way -> MemType -> ConcIO a -> (String, Predicate a) -> IO Bool-dejafuWayIO way memtype concio test =-  dejafusWayIO way memtype concio [test]+dejafuWayIO = dejafuDiscardIO (const Nothing)++-- | Variant of 'dejafuDiscard' for computations which do 'IO'.+--+-- @since 0.7.1.0+dejafuDiscardIO :: Show a => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcIO a -> (String, Predicate a) -> IO Bool+dejafuDiscardIO discard way memtype concio (name, test) = do+  traces <- runSCTDiscard discard way memtype concio+  doTest name (test traces)  -- | Variant of 'dejafus' for computations which do 'IO'. --
Test/DejaFu/Common.hs view
@@ -56,10 +56,14 @@    -- * Memory models   , MemType(..)++  -- * Miscellaneous+  , runRefCont   ) where  import           Control.DeepSeq    (NFData(..)) import           Control.Exception  (MaskingState(..))+import           Control.Monad.Ref  (MonadRef(..)) import           Data.List          (intercalate, nub, sort) import           Data.List.NonEmpty (NonEmpty) import           Data.Maybe         (fromMaybe, mapMaybe)@@ -738,6 +742,7 @@ -- -- @since 0.5.0.0 showTrace :: Trace -> String+showTrace []  = "<trace discarded>" showTrace trc = intercalate "\n" $ concatMap go trc : strkey where   go (_,_,CommitCRef _ _) = "C-"   go (Start    (ThreadId _ i),_,_) = "S" ++ show i ++ "-"@@ -857,6 +862,18 @@ -- | @since 0.5.1.0 instance NFData MemType where   rnf m = m `seq` ()++-------------------------------------------------------------------------------+-- Miscellaneous++-- | Run with a continuation that writes its value into a reference,+-- returning the computation and the reference.  Using the reference+-- is non-blocking, it is up to you to ensure you wait sufficiently.+runRefCont :: MonadRef r n => (n () -> x) -> (a -> Maybe b) -> ((a -> x) -> x) -> n (x, r (Maybe b))+runRefCont act f k = do+  ref <- newRef Nothing+  let c = k (act . writeRef ref . f)+  pure (c, ref)  ------------------------------------------------------------------------------- -- Utilities
Test/DejaFu/Conc/Internal.hs view
@@ -21,11 +21,10 @@                                                       writeRef) import qualified Data.Foldable                       as F import           Data.Functor                        (void)-import           Data.List                           (sort)+import           Data.List                           (sortOn) import           Data.List.NonEmpty                  (NonEmpty(..), fromList) import qualified Data.Map.Strict                     as M-import           Data.Maybe                          (fromJust, isJust,-                                                      isNothing)+import           Data.Maybe                          (fromJust, isJust) import           Data.Monoid                         ((<>)) import           Data.Sequence                       (Seq, (<|)) import qualified Data.Sequence                       as Seq@@ -57,16 +56,13 @@                -> M n r a                -> n (Either Failure a, Context n r g, SeqTrace, Maybe (ThreadId, ThreadAction)) runConcurrency sched memtype g idsrc caps ma = do-  ref <- newRef Nothing--  let c = runCont ma (AStop . writeRef ref . Just . Right)+  (c, ref) <- runRefCont AStop (Just . Right) (runM ma)   let ctx = Context { cSchedState = g                     , cIdSource   = idsrc                     , cThreads    = launch' Unmasked initialThread (const c) M.empty                     , cWriteBuf   = emptyBuffer                     , cCaps       = caps                     }-   (finalCtx, trace, finalAction) <- runThreads sched memtype ref ctx   out <- readRef ref   pure (fromJust out, finalCtx, trace, finalAction)@@ -90,42 +86,28 @@     | isTerminated  = pure (ctx, sofar, prior)     | isDeadlocked  = die sofar prior Deadlock ctx     | isSTMLocked   = die sofar prior STMDeadlock ctx-    | isAborted     = die sofar prior Abort $ ctx { cSchedState = g' }-    | isNonexistant = die sofar prior InternalError $ ctx { cSchedState = g' }-    | isBlocked     = die sofar prior InternalError $ ctx { cSchedState = g' }-    | otherwise = do-      stepped <- stepThread sched memtype chosen (_continuation $ fromJust thread) $ ctx { cSchedState = g' }-      case stepped of-        (Right ctx', actOrTrc) ->-          let (_, trc) = getActAndTrc actOrTrc-              threads' = if (interruptible <$> M.lookup chosen (cThreads ctx')) /= Just False-                         then unblockWaitingOn chosen (cThreads ctx')-                         else cThreads ctx'-              sofarSched' = sofarSched <> map (\(d,_,a) -> (d,a)) (F.toList trc)-              ctx'' = ctx' { cThreads = delCommitThreads threads' }-          in go (sofar <> trc) sofarSched' (getPrior actOrTrc) ctx''-        (Left failure, actOrTrc) ->-          let (_, trc) = getActAndTrc actOrTrc-              ctx'     = ctx { cSchedState = g', cThreads = delCommitThreads threads }-          in die (sofar <> trc) (getPrior actOrTrc) failure ctx'-+    | otherwise =+      let ctx' = ctx { cSchedState = g' }+      in case choice of+           Just chosen -> case M.lookup chosen threadsc of+             Just thread+               | isBlocked thread -> die sofar prior InternalError ctx'+               | otherwise -> step chosen thread ctx'+             Nothing -> die sofar prior InternalError ctx'+           Nothing -> die sofar prior Abort ctx'     where       (choice, g')  = sched sofarSched prior (fromList $ map (\(t,l:|_) -> (t,l)) runnable') (cSchedState ctx)-      chosen        = fromJust choice-      runnable'     = [(t, nextActions t) | t <- sort $ M.keys runnable]-      runnable      = M.filter (isNothing . _blocking) threadsc-      thread        = M.lookup chosen threadsc+      runnable'     = [(t, lookahead (_continuation a)) | (t, a) <- sortOn fst $ M.assocs runnable]+      runnable      = M.filter (not . isBlocked) threadsc       threadsc      = addCommitThreads (cWriteBuf ctx) threads       threads       = cThreads ctx-      isAborted     = isNothing choice-      isBlocked     = isJust . _blocking $ fromJust thread-      isNonexistant = isNothing thread+      isBlocked     = isJust . _blocking       isTerminated  = initialThread `notElem` M.keys threads-      isDeadlocked  = M.null (M.filter (isNothing . _blocking) threads) &&+      isDeadlocked  = M.null (M.filter (not . isBlocked) threads) &&         (((~=  OnMVarFull  undefined) <$> M.lookup initialThread threads) == Just True ||          ((~=  OnMVarEmpty undefined) <$> M.lookup initialThread threads) == Just True ||          ((~=  OnMask      undefined) <$> M.lookup initialThread threads) == Just True)-      isSTMLocked = M.null (M.filter (isNothing . _blocking) threads) &&+      isSTMLocked = M.null (M.filter (not . isBlocked) threads) &&         ((~=  OnTVar []) <$> M.lookup initialThread threads) == Just True        unblockWaitingOn tid = fmap unblock where@@ -133,22 +115,37 @@           Just (OnMask t) | t == tid -> thrd { _blocking = Nothing }           _ -> thrd -      decision-        | Just chosen == (fst <$> prior) = Continue-        | (fst <$> prior) `notElem` map (Just . fst) runnable' = Start chosen-        | otherwise = SwitchTo chosen--      nextActions t = lookahead . _continuation . fromJust $ M.lookup t threadsc-       die sofar' finalDecision reason finalCtx = do         writeRef ref (Just $ Left reason)         pure (finalCtx, sofar', finalDecision) -      getActAndTrc (Single a)    = (a, Seq.singleton (decision, runnable', a))-      getActAndTrc (SubC   as _) = (Subconcurrency, (decision, runnable', Subconcurrency) <| as)+      step chosen thread ctx' = do+          (res, actOrTrc) <- stepThread sched memtype chosen (_continuation thread) $ ctx { cSchedState = g' }+          let trc         = getTrc actOrTrc+          let sofar'      = sofar      <> trc+          let sofarSched' = sofarSched <> map (\(d,_,a) -> (d,a)) (F.toList trc)+          let prior'      = getPrior actOrTrc+          case res of+            Right ctx'' ->+              let threads' = if (interruptible <$> M.lookup chosen (cThreads ctx'')) /= Just False+                             then unblockWaitingOn chosen (cThreads ctx'')+                             else cThreads ctx''+                  ctx''' = ctx'' { cThreads = delCommitThreads threads' }+              in go sofar' sofarSched' prior' ctx'''+            Left failure ->+              let ctx'' = ctx' { cThreads = delCommitThreads threads }+              in die sofar' prior' failure ctx''+        where+          decision+            | Just chosen == (fst <$> prior) = Continue+            | (fst <$> prior) `notElem` map (Just . fst) runnable' = Start chosen+            | otherwise = SwitchTo chosen -      getPrior (Single a)      = Just (chosen, a)-      getPrior (SubC _ finalD) = finalD+          getTrc (Single a)    = Seq.singleton (decision, runnable', a)+          getTrc (SubC   as _) = (decision, runnable', Subconcurrency) <| as++          getPrior (Single a)      = Just (chosen, a)+          getPrior (SubC _ finalD) = finalD  -------------------------------------------------------------------------------- -- * Single-step execution
Test/DejaFu/Defaults.hs view
@@ -19,6 +19,12 @@ defaultWay :: Way defaultWay = systematically defaultBounds +-- | Do not discard any results.+--+-- @since 0.7.1.0+defaultDiscarder :: Either Failure a -> Maybe Discard+defaultDiscarder = const Nothing+ -- | The default memory model: @TotalStoreOrder@ -- -- @since 0.2.0.0
Test/DejaFu/SCT.hs view
@@ -18,9 +18,18 @@   , uniformly   , swarmy   , runSCT-  , runSCT'   , resultsSet++  -- ** Discarding variants+  , Discard(..)+  , runSCTDiscard+  , resultsSetDiscard++  -- ** Strict variants+  , runSCT'   , resultsSet'+  , runSCTDiscard'+  , resultsSetDiscard'    -- * Bounded Partial-order Reduction @@ -51,6 +60,7 @@   , Bounds(..)   , noBounds   , sctBound+  , sctBoundDiscard    -- ** Pre-emption Bounding @@ -91,8 +101,11 @@    , sctUniformRandom   , sctWeightedRandom+  , sctUniformRandomDiscard+  , sctWeightedRandomDiscard   ) where +import           Control.Applicative      ((<|>)) import           Control.DeepSeq          (NFData(..)) import           Control.Monad.Ref        (MonadRef) import           Data.List                (foldl')@@ -201,21 +214,7 @@   -> ConcT r n a   -- ^ The computation to run many times.   -> n [(Either Failure a, Trace)]-runSCT (Systematic cb)      memtype = sctBound memtype cb-runSCT (Weighted g lim use) memtype = sctWeightedRandom memtype g lim use-runSCT (Uniform  g lim)     memtype = sctUniformRandom  memtype g lim---- | A strict variant of 'runSCT'.------ Demanding the result of this will force it to normal form, which--- may be more efficient in some situations.------ @since 0.6.0.0-runSCT' :: (MonadRef r n, NFData a)-  => Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]-runSCT' way memtype conc = do-  res <- runSCT way memtype conc-  rnf res `seq` pure res+runSCT = runSCTDiscard (const Nothing)  -- | Return the set of results of a concurrent program. --@@ -228,9 +227,68 @@   -> ConcT r n a   -- ^ The computation to run many times.   -> n (Set (Either Failure a))-resultsSet way memtype conc =-  S.fromList . map fst <$> runSCT way memtype conc+resultsSet = resultsSetDiscard (const Nothing) +-- | An @Either Failure a -> Maybe Discard@ value can be used to+-- selectively discard results.+--+-- @since 0.7.1.0+data Discard+  = DiscardTrace+  -- ^ Discard the trace but keep the result.  The result will appear+  -- to have an empty trace.+  | DiscardResultAndTrace+  -- ^ Discard the result and the trace.  It will simply not be+  -- reported as a possible behaviour of the program.+  deriving (Eq, Show, Read, Ord, Enum, Bounded)++instance NFData Discard where+  rnf d = d `seq` ()++-- | A variant of 'runSCT' which can selectively discard results.+--+-- @since 0.7.1.0+runSCTDiscard :: MonadRef r n+  => (Either Failure a -> Maybe Discard)+  -- ^ Selectively discard results.+  -> Way+  -- ^ How to run the concurrent program.+  -> MemType+  -- ^ The memory model to use for non-synchronised @CRef@ operations.+  -> ConcT r n a+  -- ^ The computation to run many times.+  -> n [(Either Failure a, Trace)]+runSCTDiscard discard (Systematic cb)      memtype = sctBoundDiscard discard memtype cb+runSCTDiscard discard (Weighted g lim use) memtype = sctWeightedRandomDiscard discard memtype g lim use+runSCTDiscard discard (Uniform  g lim)     memtype = sctUniformRandomDiscard  discard memtype g lim++-- | A variant of 'resultsSet' which can selectively discard results.+--+-- @since 0.7.1.0+resultsSetDiscard :: (MonadRef r n, Ord a)+  => (Either Failure a -> Maybe Discard)+  -- ^ Selectively discard results.  Traces are always discarded.+  -> Way+  -- ^ How to run the concurrent program.+  -> MemType+  -- ^ The memory model to use for non-synchronised @CRef@ operations.+  -> ConcT r n a+  -- ^ The computation to run many times.+  -> n (Set (Either Failure a))+resultsSetDiscard discard way memtype conc =+  let discard' efa = discard efa <|> Just DiscardTrace+  in S.fromList . map fst <$> runSCTDiscard discard' way memtype conc++-- | A strict variant of 'runSCT'.+--+-- Demanding the result of this will force it to normal form, which+-- may be more efficient in some situations.+--+-- @since 0.6.0.0+runSCT' :: (MonadRef r n, NFData a)+  => Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]+runSCT' = runSCTDiscard' (const Nothing)+ -- | A strict variant of 'resultsSet'. -- -- Demanding the result of this will force it to normal form, which@@ -239,10 +297,32 @@ -- @since 0.6.0.0 resultsSet' :: (MonadRef r n, Ord a, NFData a)   => Way -> MemType -> ConcT r n a -> n (Set (Either Failure a))-resultsSet' way memtype conc = do-  res <- resultsSet' way memtype conc+resultsSet' = resultsSetDiscard' (const Nothing)++-- | A strict variant of 'runSCTDiscard'.+--+-- Demanding the result of this will force it to normal form, which+-- may be more efficient in some situations.+--+-- @since 0.7.1.0+runSCTDiscard' :: (MonadRef r n, NFData a)+  => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n [(Either Failure a, Trace)]+runSCTDiscard' discard way memtype conc = do+  res <- runSCTDiscard discard way memtype conc   rnf res `seq` pure res +-- | A strict variant of 'resultsSetDiscard'.+--+-- Demanding the result of this will force it to normal form, which+-- may be more efficient in some situations.+--+-- @since 0.7.1.0+resultsSetDiscard' :: (MonadRef r n, Ord a, NFData a)+  => (Either Failure a -> Maybe Discard) -> Way -> MemType -> ConcT r n a -> n (Set (Either Failure a))+resultsSetDiscard' discard way memtype conc = do+  res <- resultsSetDiscard discard way memtype conc+  rnf res `seq` pure res+ ------------------------------------------------------------------------------- -- Combined Bounds @@ -394,7 +474,22 @@   -> ConcT r n a   -- ^ The computation to run many times   -> n [(Either Failure a, Trace)]-sctBound memtype cb conc = go initialState where+sctBound = sctBoundDiscard (const Nothing)++-- | A variant of 'sctBound' which can selectively discard results.+--+-- @since 0.7.1.0+sctBoundDiscard :: MonadRef r n+  => (Either Failure a -> Maybe Discard)+  -- ^ Selectively discard results.+  -> MemType+  -- ^ The memory model to use for non-synchronised @CRef@ operations.+  -> Bounds+  -- ^ The combined bounds.+  -> ConcT r n a+  -- ^ The computation to run many times+  -> n [(Either Failure a, Trace)]+sctBoundDiscard discard memtype cb conc = go initialState where   -- Repeatedly run the computation gathering all the results and   -- traces into a list until there are no schedules remaining to try.   go dp = case findSchedulePrefix dp of@@ -408,8 +503,8 @@       let newDPOR = addTrace conservative trace dp        if schedIgnore s-      then go newDPOR-      else ((res, trace):) <$> go (addBacktracks bpoints newDPOR)+        then go newDPOR+        else checkDiscard discard res trace $ go (addBacktracks bpoints newDPOR)      Nothing -> pure [] @@ -443,14 +538,32 @@   -> ConcT r n a   -- ^ The computation to run many times.   -> n [(Either Failure a, Trace)]-sctUniformRandom memtype g0 lim0 conc = go g0 (max 0 lim0) where+sctUniformRandom = sctUniformRandomDiscard (const Nothing)++-- | A variant of 'sctUniformRandom' which can selectively discard+-- results.+--+-- @since 0.7.1.0+sctUniformRandomDiscard :: (MonadRef r n, RandomGen g)+  => (Either Failure a -> Maybe Discard)+  -- ^ Selectively discard results.+  -> MemType+  -- ^ The memory model to use for non-synchronised @CRef@ operations.+  -> g+  -- ^ The random number generator.+  -> Int+  -- ^ The number of executions to perform.+  -> ConcT r n a+  -- ^ The computation to run many times.+  -> n [(Either Failure a, Trace)]+sctUniformRandomDiscard discard memtype g0 lim0 conc = go g0 (max 0 lim0) where   go _ 0 = pure []   go g n = do     (res, s, trace) <- runConcurrent (randSched $ \g' -> (1, g'))                                      memtype                                      (initialRandSchedState Nothing g)                                      conc-    ((res, trace):) <$> go (schedGen s) (n-1)+    checkDiscard discard res trace $ go (schedGen s) (n-1)  -- | SCT via weighted random scheduling. --@@ -472,7 +585,27 @@   -> ConcT r n a   -- ^ The computation to run many times.   -> n [(Either Failure a, Trace)]-sctWeightedRandom memtype g0 lim0 use0 conc = go g0 (max 0 lim0) (max 1 use0) M.empty where+sctWeightedRandom = sctWeightedRandomDiscard (const Nothing)++-- | A variant of 'sctWeightedRandom' which can selectively discard+-- results.+--+-- @since 0.7.1.0+sctWeightedRandomDiscard :: (MonadRef r n, RandomGen g)+  => (Either Failure a -> Maybe Discard)+  -- ^ Selectively discard results.+  -> MemType+  -- ^ The memory model to use for non-synchronised @CRef@ operations.+  -> g+  -- ^ The random number generator.+  -> Int+  -- ^ The number of executions to perform.+  -> Int+  -- ^ The number of executions to use the same set of weights for.+  -> ConcT r n a+  -- ^ The computation to run many times.+  -> n [(Either Failure a, Trace)]+sctWeightedRandomDiscard discard memtype g0 lim0 use0 conc = go g0 (max 0 lim0) (max 1 use0) M.empty where   go _ 0 _ _ = pure []   go g n 0 _ = go g n (max 1 use0) M.empty   go g n use ws = do@@ -480,7 +613,7 @@                                      memtype                                      (initialRandSchedState (Just ws) g)                                      conc-    ((res, trace):) <$> go (schedGen s) (n-1) (use-1) (schedWeights s)+    checkDiscard discard res trace $ go (schedGen s) (n-1) (use-1) (schedWeights s)  ------------------------------------------------------------------------------- -- Utilities@@ -542,3 +675,10 @@ -- satisfied. (&+&) :: BoundFunc -> BoundFunc -> BoundFunc (&+&) b1 b2 ts dl = b1 ts dl && b2 ts dl++-- | Apply the discard function.+checkDiscard :: Functor f => (a -> Maybe Discard) -> a -> [b] -> f [(a, [b])] -> f [(a, [b])]+checkDiscard discard res trace rest = case discard res of+  Just DiscardResultAndTrace -> rest+  Just DiscardTrace -> ((res, []):) <$> rest+  Nothing -> ((res, trace):) <$> rest
Test/DejaFu/STM.hs view
@@ -71,7 +71,7 @@ instance MonadCatch (STMLike n r) where   catch (S stm) handler = toSTM (SCatch (runSTM . handler) stm) -instance Monad n => C.MonadSTM (STMLike n r) where+instance C.MonadSTM (STMLike n r) where   type TVar (STMLike n r) = TVar r    retry = toSTM (const SRetry)
Test/DejaFu/STM/Internal.hs view
@@ -101,12 +101,8 @@ -- | Run a STM transaction, returning an action to undo its effects. doTransaction :: MonadRef r n => M n r a -> IdSource -> n (Result a, n (), IdSource, TTrace) doTransaction ma idsource = do-  ref <- newRef Nothing--  let c = runCont ma (SStop . writeRef ref . Just . Right)-+  (c, ref) <- runRefCont SStop (Just . Right) (runCont ma)   (idsource', undo, readen, written, trace) <- go ref c (pure ()) idsource [] [] []-   res <- readRef ref    case res of
dejafu.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                dejafu-version:             0.7.0.2+version:             0.7.1.0 synopsis:            Systematic testing for Haskell concurrency.  description:@@ -37,7 +37,7 @@ source-repository this   type:     git   location: https://github.com/barrucadu/dejafu.git-  tag:      dejafu-0.7.0.2+  tag:      dejafu-0.7.1.0  library   exposed-modules:     Test.DejaFu@@ -67,6 +67,7 @@                      , mtl               >=2.2  && <2.3                      , random            >=1.0  && <1.2                      , ref-fd            >=0.4  && <0.5+                     -- remove semigroups dep when GHC 8.4 is out                      , semigroups        >=0.16 && <0.19                      , transformers      >=0.4  && <0.6                      , transformers-base >=0.4  && <0.5