dejafu 0.9.0.0 → 0.9.0.1

raw patch · 8 files changed

+95/−40 lines, 8 filesdep −mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: mtl

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +18/−0
• Test/DejaFu/Common.hs +52/−9
• Test/DejaFu/Conc/Internal.hs +7/−8
• Test/DejaFu/Conc/Internal/Memory.hs +3/−3
• Test/DejaFu/Conc/Internal/Threading.hs +1/−1
• Test/DejaFu/SCT/Internal.hs +9/−13
• Test/DejaFu/Schedule.hs +1/−1
• dejafu.cabal +4/−5

@@ -7,6 +7,24 @@ *de facto* standard Haskell versioning scheme.  +0.9.0.1+-------++- **Date**    2017-10-28+- **Git tag** [dejafu-0.9.0.1][]+- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.0.1++### Miscellaneous++- Fixed an issue where tests with exception handlers would sometimes skip over nested handlers or+  try to take the tail of an empty list (#139 and #141).++[dejafu-0.9.0.1]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.0.1+++---------------------------------------------------------------------------------------------------++ 0.9.0.0 ------- 

@@ -66,17 +66,24 @@   -- * Miscellaneous   , MonadFailException(..)   , runRefCont+  , ehead+  , etail+  , eidx+  , efromJust+  , efromList+  , fatal   ) where -import           Control.DeepSeq   (NFData(..))-import           Control.Exception (Exception(..), MaskingState(..),-                                    SomeException, displayException)-import           Control.Monad.Ref (MonadRef(..))-import           Data.Function     (on)-import           Data.List         (intercalate)-import           Data.Maybe        (fromMaybe, mapMaybe)-import           Data.Set          (Set)-import qualified Data.Set          as S+import           Control.DeepSeq    (NFData(..))+import           Control.Exception  (Exception(..), MaskingState(..),+                                     SomeException, displayException)+import           Control.Monad.Ref  (MonadRef(..))+import           Data.Function      (on)+import           Data.List          (intercalate)+import           Data.List.NonEmpty (NonEmpty(..))+import           Data.Maybe         (fromMaybe, mapMaybe)+import           Data.Set           (Set)+import qualified Data.Set           as S  ------------------------------------------------------------------------------- -- Identifiers@@ -982,6 +989,42 @@   ref <- newRef Nothing   let c = k (act . writeRef ref . f)   pure (c, ref)++-- | 'head' but with a better error message if it fails.  Use this+-- only where it shouldn't fail!+ehead :: String -> [a] -> a+ehead _ (x:_) = x+ehead src _ = fatal src "head: empty list"++-- | 'tail' but with a better error message if it fails.  Use this+-- only where it shouldn't fail!+etail :: String -> [a] -> [a]+etail _ (_:xs) = xs+etail src _ = fatal src "tail: empty list"++-- | '(!!)' but with a better error message if it fails.  Use this+-- only where it shouldn't fail!+eidx :: String -> [a] -> Int -> a+eidx src xs i+  | i < length xs = xs !! i+  | otherwise = fatal src "(!!): index too large"++-- | 'fromJust' but with a better error message if it fails.  Use this+-- only where it shouldn't fail!+efromJust :: String -> Maybe a -> a+efromJust _ (Just x) = x+efromJust src _ = fatal src "fromJust: Nothing"++-- | 'fromList' but with a better error message if it fails.  Use this+-- only where it shouldn't fail!+efromList :: String -> [a] -> NonEmpty a+efromList _ (x:xs) = x:|xs+efromList src _ = fatal src "fromList: empty list"++-- | 'error' but saying where it came from+fatal :: String -> String -> a+fatal src msg = error ("(dejafu: " ++ src ++ ") " ++ msg)+  ------------------------------------------------------------------------------- -- Utilities

@@ -21,9 +21,8 @@                                                       writeRef) import           Data.Functor                        (void) import           Data.List                           (sortOn)-import           Data.List.NonEmpty                  (fromList) import qualified Data.Map.Strict                     as M-import           Data.Maybe                          (fromJust, isJust)+import           Data.Maybe                          (isJust) import           Data.Monoid                         ((<>)) import           Data.Sequence                       (Seq, (<|)) import qualified Data.Sequence                       as Seq@@ -64,7 +63,7 @@                     }   (finalCtx, trace, finalAction) <- runThreads sched memtype ref ctx   out <- readRef ref-  pure (fromJust out, finalCtx, trace, finalAction)+  pure (efromJust "runConcurrency" out, finalCtx, trace, finalAction)  -- | The context a collection of threads are running in. data Context n r g = Context@@ -97,7 +96,7 @@              Nothing -> die sofar prior InternalError ctx'            Nothing -> die sofar prior Abort ctx'     where-      (choice, g')  = scheduleThread sched prior (fromList runnable') (cSchedState ctx)+      (choice, g')  = scheduleThread sched prior (efromList "runThreads" runnable') (cSchedState ctx)       runnable'     = [(t, lookahead (_continuation a)) | (t, a) <- sortOn fst $ M.assocs runnable]       runnable      = M.filter (not . isBlocked) threadsc       threadsc      = addCommitThreads (cWriteBuf ctx) threads@@ -290,7 +289,7 @@       wb' <- case memtype of         -- shouldn't ever get here         SequentialConsistency ->-          error "Attempting to commit under SequentialConsistency"+          fatal "stepThread.ACommit" "Attempting to commit under SequentialConsistency"         -- commit using the thread id.         TotalStoreOrder -> commitWrite (cWriteBuf ctx) (t, Nothing)         -- commit using the cref id.@@ -337,8 +336,8 @@      -- run a subcomputation in an exception-catching context.     ACatching h ma c ->-      let a        = runCont ma      (APopCatching . c)-          e exc    = runCont (h exc) (APopCatching . c)+      let a        = runCont ma (APopCatching . c)+          e exc    = runCont (h exc) c           threads' = goto a tid (catching e tid (cThreads ctx))       in simple threads' Catching @@ -351,7 +350,7 @@     -- a function to run a computation with the current masking state.     AMasking m ma c ->       let a = runCont (ma umask) (AResetMask False False m' . c)-          m' = _masking . fromJust $ M.lookup tid (cThreads ctx)+          m' = _masking . efromJust "stepThread.AMasking" $ M.lookup tid (cThreads ctx)           umask mb = resetMask True m' >> mb >>= \b -> resetMask False m >> pure b           resetMask typ ms = cont $ \k -> AResetMask typ True ms $ k ()           threads' = goto a tid (mask m tid (cThreads ctx))

@@ -26,7 +26,7 @@ import           Control.Monad.Ref                   (MonadRef, readRef,                                                       writeRef) import           Data.Map.Strict                     (Map)-import           Data.Maybe                          (fromJust, maybeToList)+import           Data.Maybe                          (maybeToList) import           Data.Monoid                         ((<>)) import           Data.Sequence                       (Seq, ViewL(..), singleton,                                                       viewl, (><))@@ -160,7 +160,7 @@ -- | Read from a @MVar@, blocking if empty. readFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r)             -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId])-readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . fromJust)+readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . efromJust "readFromMVar")  -- | Try to read from a @MVar@, not blocking if empty. tryReadFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r)@@ -170,7 +170,7 @@ -- | Take from a @MVar@, blocking if empty. takeFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r)              -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId])-takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . fromJust)+takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . efromJust "takeFromMVar")  -- | Try to take from a @MVar@, not blocking if empty. tryTakeFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r)

@@ -92,7 +92,7 @@  -- | Remove the most recent exception handler. uncatching :: ThreadId -> Threads n r -> Threads n r-uncatching = M.adjust $ \thread -> thread { _handlers = tail $ _handlers thread }+uncatching = M.adjust $ \thread -> thread { _handlers = etail "uncatching" (_handlers thread) }  -- | Raise an exception in a thread. except :: (MaskingState -> Action n r) -> [Handler n r] -> ThreadId -> Threads n r -> Threads n r

@@ -22,7 +22,7 @@ import           Data.List.NonEmpty   (toList) import           Data.Map.Strict      (Map) import qualified Data.Map.Strict      as M-import           Data.Maybe           (fromJust, fromMaybe, isJust, isNothing,+import           Data.Maybe           (fromMaybe, isJust, isNothing,                                        listToMaybe) import           Data.Sequence        (Seq, (|>)) import qualified Data.Sequence        as Sq@@ -157,7 +157,7 @@     in case dporNext dpor of          Just (t, child)            | t == tid'      -> dpor { dporNext = Just (tid', grow state' tid' rest child) }-           | hasTodos child -> err "incorporateTrace" "replacing child with todos!"+           | hasTodos child -> fatal "incorporateTrace" "replacing child with todos!"          _ ->            let taken = M.insert tid' a (dporTaken dpor)                sleep = dporSleep dpor `M.union` dporTaken dpor@@ -166,7 +166,7 @@                    , dporNext  = Just (tid', subtree state' tid' sleep trc)                    , dporDone  = S.insert tid' (dporDone dpor)                    }-  grow _ _ [] _ = err "incorporateTrace" "trace exhausted without reading a to-do point!"+  grow _ _ [] _ = fatal "incorporateTrace" "trace exhausted without reading a to-do point!"    -- check if there are to-do points in a tree   hasTodos dpor = not (M.null (dporTodo dpor)) || (case dporNext dpor of Just (_, dpor') -> hasTodos dpor'; _ -> False)@@ -193,7 +193,7 @@           ((d', _, a'):_) -> M.singleton (tidOf tid d') a'           [] -> M.empty         }-  subtree _ _ _ [] = err "incorporateTrace" "subtree suffix empty!"+  subtree _ _ _ [] = fatal "incorporateTrace" "subtree suffix empty!"  -- | Produce a list of new backtracking points from an execution -- trace. These are then used to inform new \"to-do\" points in the@@ -251,7 +251,7 @@   -- backtracking points.   doBacktrack killsEarly allThreads enabledThreads bs =     let tagged = reverse $ zip [0..] bs-        idxs   = [ (head is, False, u)+        idxs   = [ (ehead "doBacktrack.idxs" is, False, u)                  | (u, n) <- enabledThreads                  , v <- S.toList allThreads                  , u /= v@@ -301,9 +301,9 @@    child = case dporNext dpor of     Just (t, d)-      | t /= tid -> err "incorporateBacktrackSteps" "incorporating wrong trace!"+      | t /= tid -> fatal "incorporateBacktrackSteps" "incorporating wrong trace!"       | otherwise -> incorporateBacktrackSteps bs d-    Nothing -> err "incorporateBacktrackSteps" "child is missing!"+    Nothing -> fatal "incorporateBacktrackSteps" "child is missing!" incorporateBacktrackSteps [] dpor = dpor  -------------------------------------------------------------------------------@@ -416,7 +416,7 @@         ((i',c',t'):is') -> go i' bs (i'-i0-1) c' t' is'         [] -> bs   go i0 (b:bs) i c tid is = b : go i0 bs (i-1) c tid is-  go _ [] _ _ _ _ = err "backtrackAt" "ran out of schedule whilst backtracking!"+  go _ [] _ _ _ _ = fatal "backtrackAt" "ran out of schedule whilst backtracking!"    -- Backtrack to a single thread   backtrackTo tid c = M.insert tid c . bcktBacktracks@@ -495,7 +495,7 @@     decision = decisionOf (fst <$> prior) (S.fromList tids)      -- Get the action of a thread-    action t = fromJust $ lookup t threads'+    action t = efromJust "dporSched.action" (lookup t threads')      -- The runnable thread IDs     tids = map fst threads'@@ -812,7 +812,3 @@ killsDaemons :: ThreadId -> Lookahead -> Bool killsDaemons t WillStop = t == initialThread killsDaemons _ _ = False---- | Internal errors.-err :: String -> String -> a-err func msg = error (func ++ ": (internal error) " ++ msg)

@@ -98,7 +98,7 @@   go _ threads g =     let threads' = map fst (toList threads)         (choice, g') = randomR (0, length threads' - 1) g-    in (Just $ threads' !! choice, g')+    in (Just $ eidx "randomSched" threads' choice, g')  -- | A round-robin scheduler which, at every step, schedules the -- thread with the next 'ThreadId'.

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                dejafu-version:             0.9.0.0+version:             0.9.0.1 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.9.0.0+  tag:      dejafu-0.9.0.1  library   exposed-modules:     Test.DejaFu@@ -64,13 +64,12 @@                      , deepseq           >=1.1 && <2                      , exceptions        >=0.7 && <0.9                      , leancheck         >=0.6 && <0.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   -- hs-source-dirs:         default-language:    Haskell2010   ghc-options:         -Wall+  if impl(ghc < 8.0.1)+    build-depends: semigroups >=0.16 && <0.19