diff --git a/CHANGELOG.rst b/CHANGELOG.rst --- a/CHANGELOG.rst +++ b/CHANGELOG.rst @@ -6,6 +6,26 @@ .. _PVP: https://pvp.haskell.org/ +2.2.0.0 (2020-05-10) +-------------------- + +* Git: :tag:`dejafu-2.2.0.0` +* Hackage: :hackage:`dejafu-2.2.0.0` + +Added +~~~~~ + +* Thread action constructors for the ``MonadConc`` ``getMaskingState`` + function: + * ``Test.DejaFu.Types.ThreadAction``, ``GetMaskingState`` + * ``Test.DejaFu.Types.Lookahead``, ``WillGetMaskingState`` + +Miscellaneous +~~~~~~~~~~~~~ + +* The version bound on :hackage:`concurrency` is >=1.10 <1.11. + + 2.1.0.3 (2020-02-29) -------------------- 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 @@ -1,17 +1,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Test.DejaFu.Conc.Internal --- Copyright : (c) 2016--2019 Michael Walker +-- Copyright : (c) 2016--2020 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental --- Portability : FlexibleContexts, LambdaCase, MultiWayIf, RankNTypes, RecordWildCards, ScopedTypeVariables +-- Portability : FlexibleContexts, LambdaCase, RankNTypes, RecordWildCards, ScopedTypeVariables -- -- Concurrent monads with a fixed scheduler: internal types and -- functions. This module is NOT considered to form part of the public @@ -596,6 +595,14 @@ , (if b1 then SetMasking else ResetMasking) b2 m , const (pure ()) ) + +-- get the current masking state. +stepThread _ _ _ _ tid (AGetMasking c) = \ctx@Context{..} -> pure $ + let m = _masking $ elookup tid cThreads + in ( Succeeded ctx { cThreads = goto (c m) tid cThreads } + , GetMaskingState m + , const (pure ()) + ) -- execute a 'return' or 'pure'. stepThread _ _ _ _ tid (AReturn c) = \ctx@Context{..} -> diff --git a/Test/DejaFu/Conc/Internal/Common.hs b/Test/DejaFu/Conc/Internal/Common.hs --- a/Test/DejaFu/Conc/Internal/Common.hs +++ b/Test/DejaFu/Conc/Internal/Common.hs @@ -5,7 +5,7 @@ -- | -- Module : Test.DejaFu.Conc.Internal.Common --- Copyright : (c) 2016--2019 Michael Walker +-- Copyright : (c) 2016--2020 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental @@ -170,6 +170,7 @@ | APopCatching (Action n) | forall a. AMasking MaskingState ((forall b. ModelConc n b -> ModelConc n b) -> ModelConc n a) (a -> Action n) | AResetMask Bool Bool MaskingState (Action n) + | AGetMasking (MaskingState -> Action n) | forall a. AAtom (ModelSTM n a) (a -> Action n) | ALift (n (Action n)) @@ -215,6 +216,7 @@ lookahead (APopCatching _) = WillPopCatching lookahead (AMasking ms _ _) = WillSetMasking False ms lookahead (AResetMask b1 b2 ms _) = (if b1 then WillSetMasking else WillResetMasking) b2 ms +lookahead (AGetMasking _) = WillGetMaskingState lookahead (ALift _) = WillLiftIO lookahead (AYield _) = WillYield lookahead (ADelay n _) = WillThreadDelay n diff --git a/Test/DejaFu/Conc/Internal/Program.hs b/Test/DejaFu/Conc/Internal/Program.hs --- a/Test/DejaFu/Conc/Internal/Program.hs +++ b/Test/DejaFu/Conc/Internal/Program.hs @@ -139,6 +139,8 @@ throwTo tid e = ModelConc (\c -> AThrowTo tid e (c ())) + getMaskingState = ModelConc (\c -> AGetMasking c) + -- ---------- atomically = ModelConc . AAtom diff --git a/Test/DejaFu/Internal.hs b/Test/DejaFu/Internal.hs --- a/Test/DejaFu/Internal.hs +++ b/Test/DejaFu/Internal.hs @@ -6,7 +6,7 @@ -- | -- Module : Test.DejaFu.Internal --- Copyright : (c) 2017--2019 Michael Walker +-- Copyright : (c) 2017--2020 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental @@ -198,6 +198,7 @@ rewind (BlockedThrowTo t) = WillThrowTo t rewind (SetMasking b m) = WillSetMasking b m rewind (ResetMasking b m) = WillResetMasking b m +rewind (GetMaskingState _) = WillGetMaskingState rewind LiftIO = WillLiftIO rewind Return = WillReturn rewind Stop = WillStop diff --git a/Test/DejaFu/Types.hs b/Test/DejaFu/Types.hs --- a/Test/DejaFu/Types.hs +++ b/Test/DejaFu/Types.hs @@ -8,7 +8,7 @@ -- | -- Module : Test.DejaFu.Types --- Copyright : (c) 2017--2019 Michael Walker +-- Copyright : (c) 2017--2020 Michael Walker -- License : MIT -- Maintainer : Michael Walker -- Stability : experimental @@ -228,7 +228,7 @@ -- | All the actions that a thread can perform. -- --- @since 2.0.0.0 +-- @since 2.2.0.0 data ThreadAction = Fork ThreadId -- ^ Start a new thread. @@ -311,6 +311,8 @@ -- ^ Return to an earlier masking state. If 'True', this is being -- used to return to the state of the masked block in the argument -- passed to a 'mask'ed function. + | GetMaskingState MaskingState + -- ^ Get the current masking state. | LiftIO -- ^ Lift an IO action. Note that this can only happen with -- 'ConcIO'. @@ -360,6 +362,8 @@ rnf (BlockedThrowTo t) = rnf t rnf (SetMasking b m) = rnf (b, show m) rnf (ResetMasking b m) = rnf (b, show m) + -- deepseq<1.4.4.0 doesn't have an instance for MaskingState + rnf (GetMaskingState m) = m `seq` () rnf LiftIO = () rnf Return = () rnf Stop = () @@ -367,7 +371,7 @@ -- | A one-step look-ahead at what a thread will do next. -- --- @since 2.0.0.0 +-- @since 2.2.0.0 data Lookahead = WillFork -- ^ Will start a new thread. @@ -439,6 +443,8 @@ -- ^ Will return to an earlier masking state. If 'True', this is -- being used to return to the state of the masked block in the -- argument passed to a 'mask'ed function. + | WillGetMaskingState + -- ^ Will get the masking state. | WillLiftIO -- ^ Will lift an IO action. Note that this can only happen with -- 'ConcIO'. @@ -483,6 +489,7 @@ rnf (WillThrowTo t) = rnf t rnf (WillSetMasking b m) = rnf (b, show m) rnf (WillResetMasking b m) = rnf (b, show m) + rnf WillGetMaskingState = () rnf WillLiftIO = () rnf WillReturn = () rnf WillStop = () 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: 2.1.0.3 +version: 2.2.0.0 synopsis: A library for unit-testing concurrent programs. description: @@ -33,7 +33,7 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: dejafu-2.1.0.3 + tag: dejafu-2.2.0.0 library exposed-modules: Test.DejaFu @@ -59,7 +59,7 @@ -- other-modules: -- other-extensions: build-depends: base >=4.9 && <5 - , concurrency >=1.7 && <1.10 + , concurrency >=1.10 && <1.11 , containers >=0.5 && <0.7 , contravariant >=1.2 && <1.6 , deepseq >=1.1 && <2