diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -7,6 +7,32 @@ *de facto* standard Haskell versioning scheme. +0.9.1.0 +------- + +- **Date** 2017-11-26 +- **Git tag** [dejafu-0.9.1.0][] +- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.1.0 + +### Test.DejaFu.Common + +- Fix some incorrect "@since" haddock comments. +- Pretty-printed traces now display a pre-emption following a yield with a little "p". + +### Test.DejaFu.Conc + +- Add a missing `MonadFail` instance. + +### Test.DejaFu.STM + +- Add a missing `MonadFail` instance. + +[dejafu-0.9.1.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.1.0 + + +--------------------------------------------------------------------------------------------------- + + 0.9.0.3 ------- diff --git a/Test/DejaFu/Common.hs b/Test/DejaFu/Common.hs --- a/Test/DejaFu/Common.hs +++ b/Test/DejaFu/Common.hs @@ -815,15 +815,20 @@ -- @since 0.5.0.0 showTrace :: Trace -> String showTrace [] = "" -showTrace trc = intercalate "\n" $ concatMap go trc : strkey where - go (_,_,CommitCRef _ _) = "C-" - go (Start (ThreadId _ i),_,_) = "S" ++ show i ++ "-" - go (SwitchTo (ThreadId _ i),_,_) = "P" ++ show i ++ "-" - go (Continue,_,_) = "-" +showTrace trc = intercalate "\n" $ go False trc : strkey where + go _ ((_,_,CommitCRef _ _):rest) = "C-" ++ go False rest + go _ ((Start (ThreadId _ i),_,a):rest) = "S" ++ show i ++ "-" ++ go (didYield a) rest + go y ((SwitchTo (ThreadId _ i),_,a):rest) = (if y then "p" else "P") ++ show i ++ "-" ++ go (didYield a) rest + go _ ((Continue,_,a):rest) = '-' : go (didYield a) rest + go _ _ = "" strkey = [" " ++ show i ++ ": " ++ name | (i, name) <- threadNames trc] + didYield Yield = True + didYield (ThreadDelay _) = True + didYield _ = False + -- | Get all named threads in the trace. -- -- @since 0.7.3.0 @@ -933,21 +938,21 @@ -- | Check if a failure is an @InternalError@. -- --- @since undefined +-- @since 0.9.0.0 isInternalError :: Failure -> Bool isInternalError InternalError = True isInternalError _ = False -- | Check if a failure is an @Abort@. -- --- @since undefined +-- @since 0.9.0.0 isAbort :: Failure -> Bool isAbort Abort = True isAbort _ = False -- | Check if a failure is a @Deadlock@ or an @STMDeadlock@. -- --- @since undefined +-- @since 0.9.0.0 isDeadlock :: Failure -> Bool isDeadlock Deadlock = True isDeadlock STMDeadlock = True @@ -955,14 +960,14 @@ -- | Check if a failure is an @UncaughtException@ -- --- @since undefined +-- @since 0.9.0.0 isUncaughtException :: Failure -> Bool isUncaughtException (UncaughtException _) = True isUncaughtException _ = False -- | Check if a failure is an @IllegalSubconcurrency@ -- --- @since undefined +-- @since 0.9.0.0 isIllegalSubconcurrency :: Failure -> Bool isIllegalSubconcurrency IllegalSubconcurrency = True isIllegalSubconcurrency _ = False diff --git a/Test/DejaFu/Conc.hs b/Test/DejaFu/Conc.hs --- a/Test/DejaFu/Conc.hs +++ b/Test/DejaFu/Conc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -11,7 +12,7 @@ -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeSynonymInstances +-- Portability : CPP, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeSynonymInstances -- -- Deterministic traced execution of concurrent computations. -- @@ -65,8 +66,18 @@ import Test.DejaFu.Conc.Internal.Common import Test.DejaFu.STM +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif + -- | @since 0.6.0.0 newtype ConcT r n a = C { unC :: M n r a } deriving (Functor, Applicative, Monad) + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.9.1.0 +instance Fail.MonadFail (ConcT r n) where + fail = C . fail +#endif -- | A 'MonadConc' implementation using @ST@, this should be preferred -- if you do not need 'liftIO'. 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 @@ -17,7 +17,7 @@ SomeException, fromException) import Data.List (intersect) import Data.Map.Strict (Map) -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (isJust) import Test.DejaFu.Common import Test.DejaFu.Conc.Internal.Common @@ -117,7 +117,7 @@ -- from the parent thread. This ID must not already be in use! launch :: ThreadId -> ThreadId -> ((forall b. M n r b -> M n r b) -> Action n r) -> Threads n r -> Threads n r launch parent tid a threads = launch' ms tid a threads where - ms = fromMaybe Unmasked $ _masking <$> M.lookup parent threads + ms = maybe Unmasked _masking (M.lookup parent threads) -- | Start a thread with the given ID and masking state. This must not already be in use! launch' :: MaskingState -> ThreadId -> ((forall b. M n r b -> M n r b) -> Action n r) -> Threads n r -> Threads n r diff --git a/Test/DejaFu/STM.hs b/Test/DejaFu/STM.hs --- a/Test/DejaFu/STM.hs +++ b/Test/DejaFu/STM.hs @@ -39,8 +39,18 @@ import Test.DejaFu.Common import Test.DejaFu.STM.Internal +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif + -- | @since 0.3.0.0 newtype STMLike n r a = S { runSTM :: M n r a } deriving (Functor, Applicative, Monad) + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.9.1.0 +instance Fail.MonadFail (STMLike r n) where + fail = S . fail +#endif -- | Create a new STM continuation. toSTM :: ((a -> STMAction n r) -> STMAction n r) -> STMLike n r a 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.3 +version: 0.9.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.9.0.3 + tag: dejafu-0.9.1.0 library exposed-modules: Test.DejaFu