diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 ------- diff --git a/Test/DejaFu/Common.hs b/Test/DejaFu/Common.hs --- a/Test/DejaFu/Common.hs +++ b/Test/DejaFu/Common.hs @@ -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 diff --git a/Test/DejaFu/Conc/Internal.hs b/Test/DejaFu/Conc/Internal.hs --- a/Test/DejaFu/Conc/Internal.hs +++ b/Test/DejaFu/Conc/Internal.hs @@ -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)) diff --git a/Test/DejaFu/Conc/Internal/Memory.hs b/Test/DejaFu/Conc/Internal/Memory.hs --- a/Test/DejaFu/Conc/Internal/Memory.hs +++ b/Test/DejaFu/Conc/Internal/Memory.hs @@ -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) diff --git a/Test/DejaFu/Conc/Internal/Threading.hs b/Test/DejaFu/Conc/Internal/Threading.hs --- a/Test/DejaFu/Conc/Internal/Threading.hs +++ b/Test/DejaFu/Conc/Internal/Threading.hs @@ -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 diff --git a/Test/DejaFu/SCT/Internal.hs b/Test/DejaFu/SCT/Internal.hs --- a/Test/DejaFu/SCT/Internal.hs +++ b/Test/DejaFu/SCT/Internal.hs @@ -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) diff --git a/Test/DejaFu/Schedule.hs b/Test/DejaFu/Schedule.hs --- a/Test/DejaFu/Schedule.hs +++ b/Test/DejaFu/Schedule.hs @@ -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'. diff --git a/dejafu.cabal b/dejafu.cabal --- a/dejafu.cabal +++ b/dejafu.cabal @@ -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