barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2024-11-22 21:50:51 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #315 from barrucadu/getmaskingstate

Browse Source 
Add getMaskingState to concurrency / dejafu
This commit is contained in:
Michael Walker 2020-05-10 23:16:45 +01:00 committed by GitHub
commit f3c57ea7f9
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 127 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
README.markdown
View File

@ -45,10 +45,10 @@ There are a few different packages under the Déjà Fu umbrella:
| | Version | Summary |
| - | ------- | ------- |
| [concurrency][h:conc] | 1.9.0.0 | Typeclasses, functions, and data types for concurrency and STM. |
| [dejafu][h:dejafu] | 2.1.0.3 | Systematic testing for Haskell concurrency. |
| [hunit-dejafu][h:hunit] | 2.0.0.1 | Deja Fu support for the HUnit test framework. |
| [tasty-dejafu][h:tasty] | 2.0.0.2 | Deja Fu support for the Tasty test framework. |
| [concurrency][h:conc] | 1.10.0.0 | Typeclasses, functions, and data types for concurrency and STM. |
| [dejafu][h:dejafu] | 2.2.0.0 | Systematic testing for Haskell concurrency. |
| [hunit-dejafu][h:hunit] | 2.0.0.2 | Deja Fu support for the HUnit test framework. |
| [tasty-dejafu][h:tasty] | 2.0.0.3 | Deja Fu support for the Tasty test framework. |
Each package has its own README and CHANGELOG in its subdirectory.

17
concurrency/CHANGELOG.rst
View File

@ -6,8 +6,20 @@ standard Haskell versioning scheme.
.. _PVP: https://pvp.haskell.org/
1.10.0.0 (2020-05-10)
---------------------
* Git: :tag:`concurrency-1.10.0.0`
* Hackage: :hackage:`concurrency-1.10.0.0`
Added
~~~~~
* (:issue:`312`) ``Control.Monad.Conc.Class.getMaskingState``.
1.9.0.0 (2020-02-26)
====================
--------------------
* Git: :tag:`concurrency-1.9.0.0`
* Hackage: :hackage:`concurrency-1.9.0.0`
@ -20,8 +32,9 @@ Changed
* Changed ``newTBQueue`` to accept ``Natural`` as a size.
* Changed ``lengthTBQueue`` to return a ``Natural``.
1.8.1.0 (2019-11-16)
====================
--------------------
* Git: :tag:`concurrency-1.8.1.0`
* Hackage: :hackage:`concurrency-1.8.1.0`

17
concurrency/Control/Monad/Conc/Class.hs
View File

@ -91,7 +91,8 @@ module Control.Monad.Conc.Class
-- for the class and utilities
import Control.Exception (AsyncException(ThreadKilled),
Exception, SomeException)
Exception, MaskingState,
SomeException)
import Control.Monad.Catch (MonadCatch, MonadMask,
MonadThrow)
import qualified Control.Monad.Catch as Ca
@ -104,6 +105,7 @@ import Data.Proxy (Proxy(..))
-- for the 'IO' instance
import qualified Control.Concurrent as IO
import qualified Control.Concurrent.STM.TVar as IO
import qualified Control.Exception as IO
import qualified Control.Monad.STM as IO
import qualified Data.Atomics as IO
import qualified Data.IORef as IO
@ -152,7 +154,7 @@ import qualified Control.Monad.Writer.Strict as WS
-- Do not be put off by the use of @UndecidableInstances@, it is safe
-- here.
--
-- @since 1.7.0.0
-- @since 1.10.0.0
class ( Monad m
, MonadCatch m, MonadThrow m, MonadMask m
, MonadSTM (STM m)
@ -184,6 +186,7 @@ class ( Monad m
, modifyIORefCAS
, atomically
, throwTo
, getMaskingState
#-}
-- | The associated 'MonadSTM' for this class.
@ -496,6 +499,11 @@ class ( Monad m
-- @since 1.0.0.0
throwTo :: Exception e => ThreadId m -> e -> m ()
-- | Return the 'MaskingState' for the current thread.
--
-- @since 1.10.0.0
getMaskingState :: m MaskingState
-------------------------------------------------------------------------------
-- Utilities
@ -784,6 +792,7 @@ instance MonadConc IO where
atomically = IO.atomically
newTVarConc = IO.newTVarIO
readTVarConc = IO.readTVarIO
getMaskingState = IO.getMaskingState
-- | Label the current thread, if the given label is nonempty.
labelMe :: String -> IO ()
@ -863,6 +872,7 @@ instance MonadConc m => MonadConc (IsConc m) where
atomically = toIsConc . atomically . fromIsSTM
newTVarConc = toIsConc . newTVarConc
readTVarConc = toIsConc . readTVarConc
getMaskingState = toIsConc getMaskingState
-------------------------------------------------------------------------------
-- Transformer instances
@ -912,7 +922,8 @@ instance C => MonadConc (T m) where { \
modifyIORefCAS_ r = lift . modifyIORefCAS_ r ; \
atomically = lift . atomically ; \
newTVarConc = lift . newTVarConc ; \
readTVarConc = lift . readTVarConc }
readTVarConc = lift . readTVarConc ; \
getMaskingState = lift getMaskingState }
-- | New threads inherit the reader state of their parent, but do not
-- communicate results back.

4
concurrency/concurrency.cabal
View File

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: concurrency
version: 1.9.0.0
version: 1.10.0.0
synopsis: Typeclasses, functions, and data types for concurrency and STM.
description:
@ -32,7 +32,7 @@ source-repository head
source-repository this
type: git
location: https://github.com/barrucadu/dejafu.git
tag: concurrency-1.9.0.0
tag: concurrency-1.10.0.0
library
exposed-modules: Control.Monad.Conc.Class

9
dejafu-tests/lib/Integration/SingleThreaded.hs
View File

@ -3,7 +3,8 @@
module Integration.SingleThreaded where
import Control.Exception (ArithException(..),
ArrayException(..))
ArrayException(..),
MaskingState(..))
import Test.DejaFu (Condition(..), gives, gives',
inspectIORef, inspectMVar,
inspectTVar, isDeadlock,
@ -230,6 +231,12 @@ exceptionTests = toTestList
, djfu "MonadConc is a MonadFail" (alwaysFailsWith isUncaughtException)
(fail "hello world" :: (MonadConc m, MonadFail m) => m ()) -- avoid an ambiguous type
, djfu "Masking state is changed by a mask" (gives' [MaskedInterruptible]) $
mask_ getMaskingState
, djfu "Masking state is reset after the mask ends" (gives' [Unmasked]) $
mask_ getMaskingState >> getMaskingState
]
--------------------------------------------------------------------------------

1
dejafu-tests/lib/Unit/Properties.hs
View File

@ -383,6 +383,7 @@ genThreadAction = HGen.choice
, D.BlockedThrowTo <$> genThreadId
, D.SetMasking <$> HGen.bool <*> genMaskingState
, D.ResetMasking <$> HGen.bool <*> genMaskingState
, D.GetMaskingState <$> genMaskingState
, pure D.LiftIO
, pure D.Return
, pure D.Stop

20
dejafu/CHANGELOG.rst
View File

@ -6,6 +6,26 @@ standard Haskell versioning scheme.
.. _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)
--------------------

10
dejafu/Test/DejaFu/Conc/Internal.hs
View File

@ -6,7 +6,7 @@
-- |
-- Module : Test.DejaFu.Conc.Internal
-- Copyright : (c) 2016--2019 Michael Walker
-- Copyright : (c) 2016--2020 Michael Walker
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental
@ -596,6 +596,14 @@ stepThread _ _ _ _ tid (AResetMask b1 b2 m c) = \ctx@Context{..} ->
, 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{..} ->
pure ( Succeeded ctx { cThreads = goto c tid cThreads }

4
dejafu/Test/DejaFu/Conc/Internal/Common.hs
View File

@ -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 <mike@barrucadu.co.uk>
-- Stability : experimental
@ -170,6 +170,7 @@ data Action n =
| 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 (ACatching _ _ _) = WillCatching
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

2
dejafu/Test/DejaFu/Conc/Internal/Program.hs
View File

@ -139,6 +139,8 @@ instance (pty ~ Basic, Monad n) => C.MonadConc (Program pty n) where
throwTo tid e = ModelConc (\c -> AThrowTo tid e (c ()))
getMaskingState = ModelConc (\c -> AGetMasking c)
-- ----------
atomically = ModelConc . AAtom

3
dejafu/Test/DejaFu/Internal.hs
View File

@ -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 <mike@barrucadu.co.uk>
-- Stability : experimental
@ -198,6 +198,7 @@ rewind (ThrowTo t _) = WillThrowTo t
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

13
dejafu/Test/DejaFu/Types.hs
View File

@ -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 <mike@barrucadu.co.uk>
-- Stability : experimental
@ -228,7 +228,7 @@ initialThread = ThreadId (Id (Just "main") 0)
-- | 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 @@ data ThreadAction =
-- ^ 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 @@ instance NFData ThreadAction where
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 @@ instance NFData ThreadAction where
-- | 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 @@ data Lookahead =
-- ^ 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 @@ instance NFData Lookahead where
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 = ()

6
dejafu/dejafu.cabal
View File

@ -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 head
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 @@ library
-- 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

8
doc/getting_started.rst
View File

@ -27,10 +27,10 @@ There are a few different packages under the Déjà Fu umbrella:
.. csv-table::
:header: "Package", "Version", "Summary"
":hackage:`concurrency`", "1.9.0.0", "Typeclasses, functions, and data types for concurrency and STM"
":hackage:`dejafu`", "2.1.0.3", "Systematic testing for Haskell concurrency"
":hackage:`hunit-dejafu`", "2.0.0.1", "Déjà Fu support for the HUnit test framework"
":hackage:`tasty-dejafu`", "2.0.0.2", "Déjà Fu support for the tasty test framework"
":hackage:`concurrency`", "1.10.0.0", "Typeclasses, functions, and data types for concurrency and STM"
":hackage:`dejafu`", "2.2.0.0", "Systematic testing for Haskell concurrency"
":hackage:`hunit-dejafu`", "2.0.0.2", "Déjà Fu support for the HUnit test framework"
":hackage:`tasty-dejafu`", "2.0.0.3", "Déjà Fu support for the tasty test framework"
Installation

12
hunit-dejafu/CHANGELOG.rst
View File

@ -7,6 +7,18 @@ standard Haskell versioning scheme.
.. _PVP: https://pvp.haskell.org/
2.0.0.2 (2020-10-05)
--------------------
* Git: :tag:`hunit-dejafu-2.0.0.2`
* Hackage: :hackage:`hunit-dejafu-2.0.0.2`
Miscellaneous
~~~~~~~~~~~~~
* The upper bound on :hackage:`dejafu` is <2.3
2.0.0.1 (2019-03-24)
--------------------

6
hunit-dejafu/hunit-dejafu.cabal
View File

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: hunit-dejafu
version: 2.0.0.1
version: 2.0.0.2
synopsis: Deja Fu support for the HUnit test framework.
description:
@ -30,7 +30,7 @@ source-repository head
source-repository this
type: git
location: https://github.com/barrucadu/dejafu.git
tag: hunit-dejafu-2.0.0.1
tag: hunit-dejafu-2.0.0.2
library
exposed-modules: Test.HUnit.DejaFu
@ -38,7 +38,7 @@ library
-- other-extensions:
build-depends: base >=4.9 && <5
, exceptions >=0.7 && <0.11
, dejafu >=2.0 && <2.2
, dejafu >=2.0 && <2.3
, HUnit >=1.3.1 && <1.7
-- hs-source-dirs:
default-language: Haskell2010

12
tasty-dejafu/CHANGELOG.rst
View File

@ -7,6 +7,18 @@ standard Haskell versioning scheme.
.. _PVP: https://pvp.haskell.org/
2.0.0.3 (2020-05-10)
--------------------
* Git: :tag:`tasty-dejafu-2.0.0.3`
* Hackage: :hackage:`tasty-dejafu-2.0.0.3`
Miscellaneous
~~~~~~~~~~~~~
* The upper bound on :hackage:`dejafu` is <2.3
2.0.0.2 (2020-05-10)
--------------------

6
tasty-dejafu/tasty-dejafu.cabal
View File

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: tasty-dejafu
version: 2.0.0.2
version: 2.0.0.3
synopsis: Deja Fu support for the Tasty test framework.
description:
@ -30,14 +30,14 @@ source-repository head
source-repository this
type: git
location: https://github.com/barrucadu/dejafu.git
tag: tasty-dejafu-2.0.0.2
tag: tasty-dejafu-2.0.0.3
library
exposed-modules: Test.Tasty.DejaFu
-- other-modules:
-- other-extensions:
build-depends: base >=4.9 && <5
, dejafu >=2.0 && <2.2
, dejafu >=2.0 && <2.3
, random >=1.0 && <1.2
, tagged >=0.8 && <0.9
, tasty >=0.10 && <1.4