barrucadu/dejafu
1
1
Fork 0
mirror of https://github.com/barrucadu/dejafu.git synced 2024-11-23 14:14:36 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #252 from barrucadu/234-ghc841

Browse Source 
Drop GHC 7.10 support
This commit is contained in:
Michael Walker 2018-03-28 19:31:39 +01:00 committed by GitHub
commit ee8bb171e6
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
35 changed files with 573 additions and 299 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.travis.yml
View File

@ -19,12 +19,12 @@ cache:
matrix:
fast_finish: true
include:
- env: MODE=test RESOLVER=lts-6.0 # GHC 7.10
addons: {apt: {packages: [libgmp-dev]}}
- env: MODE=test RESOLVER=lts-9.0 # GHC 8.0
addons: {apt: {packages: [libgmp-dev]}}
- env: MODE=test RESOLVER=lts-10.0 # GHC 8.2
addons: {apt: {packages: [libgmp-dev]}}
- env: MODE=test RESOLVER=nightly-2018-03-23 # GHC 8.4
addons: {apt: {packages: [libgmp-dev]}}
- env: MODE=test RESOLVER=nightly
addons: {apt: {packages: [libgmp-dev]}}
- env: MODE=doctest
@ -46,11 +46,7 @@ before_install:
# Run tests
script:
- stack --no-terminal build concurrency
- stack --no-terminal build dejafu
- stack --no-terminal build hunit-dejafu
- stack --no-terminal build tasty-dejafu
- stack --no-terminal build dejafu-tests
- if [[ "$MODE" == "test" ]]; then stack --no-terminal build --ghc-options=-Werror; else stack --no-terminal build; fi
- |
echo -en 'travis_fold:start:script.test\\r'

1
.travis/lts-6.0.yaml
View File

@ -10,5 +10,4 @@ packages:
extra-deps:
- hedgehog-0.5.2
- leancheck-0.6.7
- tasty-hedgehog-0.1.0.1
- wl-pprint-annotated-0.1.0.0

1
.travis/lts-9.0.yaml
View File

@ -9,4 +9,3 @@ packages:
extra-deps:
- hedgehog-0.5.2
- tasty-hedgehog-0.1.0.1

17
.weeder.yaml
View File

@ -1,17 +0,0 @@
# It would be good to not need this
# https://github.com/ndmitchell/weeder/issues/24
- package:
- name: dejafu
- section:
- name: library
- message:
- name: Redundant build-depends entry
- depends: semigroups
- package:
- name: dejafu-tests
- section:
- name: library
- message:
- name: Redundant build-depends entry
- depends: transformers

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.4.0.2 | Typeclasses, functions, and data types for concurrency and STM. |
| [dejafu][h:dejafu] | 1.4.0.0 | Systematic testing for Haskell concurrency. |
| [hunit-dejafu][h:hunit] | 1.1.0.3 | Deja Fu support for the HUnit test framework. |
| [tasty-dejafu][h:tasty] | 1.1.0.2 | Deja Fu support for the Tasty test framework. |
| [concurrency][h:conc] | 1.5.0.0 | Typeclasses, functions, and data types for concurrency and STM. |
| [dejafu][h:dejafu] | 1.5.0.0 | Systematic testing for Haskell concurrency. |
| [hunit-dejafu][h:hunit] | 1.2.0.0 | Deja Fu support for the HUnit test framework. |
| [tasty-dejafu][h:tasty] | 1.2.0.0 | Deja Fu support for the Tasty test framework. |
Each package has its own README and CHANGELOG in its subdirectory.

27
concurrency/CHANGELOG.rst
View File

@ -7,6 +7,33 @@ standard Haskell versioning scheme.
.. _PVP: https://pvp.haskell.org/
1.5.0.0 - No More 7.10 (2018-03-28)
-----------------------------------
* Git: :tag:`concurrency-1.5.0.0`
* Hackage: :hackage:`concurrency-1.5.0.0`
Added
~~~~~
* (:issue:`132`) ``forkOSWithUnmask`` in ``MonadConc``
Changed
~~~~~~~
* (:issue:`132`) ``Control.Monad.Conc.Class.fork``, ``forkOn``,
``forkOS``, and ``forkOSN`` are top-level definitions.
Miscellaneous
~~~~~~~~~~~~~
* GHC 7.10 support is dropped. Dependency lower bounds are:
* :hackage:`base`: 4.9
* :hackage:`array`: 0.5.1
* :hackage:`transformers`: 0.5
1.4.0.2 (2018-03-11)
--------------------

12
concurrency/Control/Concurrent/Classy/Async.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
-- |
@ -7,7 +6,7 @@
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : stable
-- Portability : CPP, RankNTypes
-- Portability : RankNTypes
--
-- This module is a version of the
-- <https://hackage.haskell.org/package/async async> package. It
@ -103,10 +102,7 @@ import Control.Monad.Catch (finally, onException, try)
import Control.Monad.Conc.Class
import Control.Monad.STM.Class
import Data.Foldable (foldMap)
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup(..))
#endif
-----------------------------------------------------------------------------------------
-- Asynchronous and Concurrent Actions
@ -171,13 +167,9 @@ instance MonadConc m => Alternative (Concurrently m) where
Concurrently as <|> Concurrently bs =
Concurrently $ either id id <$> race as bs
#if MIN_VERSION_base(4,9,0)
-- | Only defined for base >= 4.9.0.0
--
-- @since 1.1.2.0
-- | @since 1.1.2.0
instance (MonadConc m, Semigroup a) => Semigroup (Concurrently m a) where
(<>) = liftA2 (<>)
#endif
-- | @since 1.1.2.0
instance (MonadConc m, Monoid a) => Monoid (Concurrently m a) where

5
concurrency/Control/Concurrent/Classy/STM/TArray.hs
View File

@ -37,9 +37,8 @@ newtype TArray stm i e = TArray (Array i (TVar stm e))
instance MonadSTM stm => MArray (TArray stm) e stm where
getBounds (TArray a) = pure (bounds a)
newArray b e = do
a <- rep (rangeSize b) (newTVar e)
pure $ TArray (listArray b a)
newArray b e =
TArray . listArray b <$> rep (rangeSize b) (newTVar e)
newArray_ b = newArray b arrEleBottom

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

@ -31,8 +31,11 @@ module Control.Monad.Conc.Class
( MonadConc(..)
-- * Threads
, spawn
, fork
, forkOn
, forkOS
, forkFinally
, spawn
, killThread
-- ** Bound threads
@ -59,6 +62,7 @@ module Control.Monad.Conc.Class
-- ** Named Threads
, forkN
, forkOnN
, forkOSN
-- * Exceptions
, throw
@ -146,8 +150,8 @@ import qualified Control.Monad.Writer.Strict as WS
-- Do not be put off by the use of @UndecidableInstances@, it is safe
-- here.
--
-- @since 1.4.0.0
class ( Applicative m, Monad m
-- @since 1.5.0.0
class ( Monad m
, MonadCatch m, MonadThrow m, MonadMask m
, MonadSTM (STM m)
, Ord (ThreadId m), Show (ThreadId m)) => MonadConc m where
@ -155,7 +159,7 @@ class ( Applicative m, Monad m
{-# MINIMAL
(forkWithUnmask | forkWithUnmaskN)
, (forkOnWithUnmask | forkOnWithUnmaskN)
, (forkOS | forkOSN)
, (forkOSWithUnmask | forkOSWithUnmaskN)
, isCurrentThreadBound
, getNumCapabilities
, setNumCapabilities
@ -211,15 +215,6 @@ class ( Applicative m, Monad m
-- @since 1.0.0.0
type ThreadId m :: *
-- | Fork a computation to happen concurrently. Communication may
-- happen over @MVar@s.
--
-- > fork ma = forkWithUnmask (const ma)
--
-- @since 1.0.0.0
fork :: m () -> m (ThreadId m)
fork ma = forkWithUnmask (const ma)
-- | Like 'fork', but the child thread is passed a function that can
-- be used to unmask asynchronous exceptions. This function should
-- not be used within a 'mask' or 'uninterruptibleMask'.
@ -239,18 +234,6 @@ class ( Applicative m, Monad m
forkWithUnmaskN :: String -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkWithUnmaskN _ = forkWithUnmask
-- | Fork a computation to happen on a specific processor. The
-- specified int is the /capability number/, typically capabilities
-- correspond to physical processors or cores but this is
-- implementation dependent. The int is interpreted modulo to the
-- total number of capabilities as returned by 'getNumCapabilities'.
--
-- > forkOn c ma = forkOnWithUnmask c (const ma)
--
-- @since 1.0.0.0
forkOn :: Int -> m () -> m (ThreadId m)
forkOn c ma = forkOnWithUnmask c (const ma)
-- | Like 'forkWithUnmask', but the child thread is pinned to the
-- given CPU, as with 'forkOn'.
--
@ -269,24 +252,24 @@ class ( Applicative m, Monad m
forkOnWithUnmaskN :: String -> Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkOnWithUnmaskN _ = forkOnWithUnmask
-- | Fork a computation to happen in a /bound thread/, which is
-- necessary if you need to call foreign (non-Haskell) libraries
-- that make use of thread-local state, such as OpenGL.
-- | Like 'forkOS', but the child thread is passed a function that
-- can be used to unmask asynchronous exceptions. This function
-- should not be used within a 'mask' or 'uninterruptibleMask'.
--
-- > forkOS = forkOSN ""
-- > forkOSWithUnmask = forkOSWithUnmaskN ""
--
-- @since 1.3.0.0
forkOS :: m () -> m (ThreadId m)
forkOS = forkOSN ""
-- @since 1.5.0.0
forkOSWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkOSWithUnmask = forkOSWithUnmaskN ""
-- | Like 'forkOS', but the thread is given a name which may be used
-- to present more useful debugging information.
-- | Like 'forkOSWithUnmask', but the thread is given a name which
-- may be used to present more useful debugging information.
--
-- > forkOSN _ = forkOS
-- > forkOSWithUnmaskN _ = forkOSWithUnmask
--
-- @since 1.3.0.0
forkOSN :: String -> m () -> m (ThreadId m)
forkOSN _ = forkOS
-- @since 1.5.0.0
forkOSWithUnmaskN :: String -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
forkOSWithUnmaskN _ = forkOSWithUnmask
-- | Returns 'True' if the calling thread is bound, that is, if it
-- is safe to use foreign libraries that rely on thread-local state
@ -500,15 +483,30 @@ class ( Applicative m, Monad m
-- Threads
-- | Create a concurrent computation for the provided action, and
-- return a @MVar@ which can be used to query the result.
-- | Fork a computation to happen concurrently. Communication may
-- happen over @MVar@s.
--
-- @since 1.0.0.0
spawn :: MonadConc m => m a -> m (MVar m a)
spawn ma = do
cvar <- newEmptyMVar
_ <- fork $ ma >>= putMVar cvar
pure cvar
-- @since 1.5.0.0
fork :: MonadConc m => m () -> m (ThreadId m)
fork ma = forkWithUnmask (const ma)
-- | Fork a computation to happen on a specific processor. The
-- specified int is the /capability number/, typically capabilities
-- correspond to physical processors or cores but this is
-- implementation dependent. The int is interpreted modulo to the
-- total number of capabilities as returned by 'getNumCapabilities'.
--
-- @since 1.5.0.0
forkOn :: MonadConc m => Int -> m () -> m (ThreadId m)
forkOn c ma = forkOnWithUnmask c (const ma)
-- | Fork a computation to happen in a /bound thread/, which is
-- necessary if you need to call foreign (non-Haskell) libraries
-- that make use of thread-local state, such as OpenGL.
--
-- @since 1.5.0.0
forkOS :: MonadConc m => m () -> m (ThreadId m)
forkOS ma = forkOSWithUnmask (const ma)
-- | Fork a thread and call the supplied function when the thread is
-- about to terminate, with an exception or a returned value. The
@ -523,6 +521,16 @@ forkFinally action and_then =
mask $ \restore ->
fork $ Ca.try (restore action) >>= and_then
-- | Create a concurrent computation for the provided action, and
-- return a @MVar@ which can be used to query the result.
--
-- @since 1.0.0.0
spawn :: MonadConc m => m a -> m (MVar m a)
spawn ma = do
cvar <- newEmptyMVar
_ <- fork $ ma >>= putMVar cvar
pure cvar
-- | Raise the 'ThreadKilled' exception in the target thread. Note
-- that if the thread is prepared to catch this exception, it won't
-- actually kill it.
@ -545,6 +553,13 @@ forkN name ma = forkWithUnmaskN name (const ma)
forkOnN :: MonadConc m => String -> Int -> m () -> m (ThreadId m)
forkOnN name i ma = forkOnWithUnmaskN name i (const ma)
-- | Like 'forkOS', but the thread is given a name which may be used
-- to present more useful debugging information.
--
-- @since 1.5.0.0
forkOSN :: MonadConc m => String -> m () -> m (ThreadId m)
forkOSN name ma = forkOSWithUnmaskN name (const ma)
-- | Run the computation passed as the first argument. If the calling
-- thread is not /bound/, a bound thread is created temporarily.
-- @runInBoundThread@ doesn't finish until the inner computation
@ -695,16 +710,9 @@ instance MonadConc IO where
type Ticket IO = IO.Ticket
type ThreadId IO = IO.ThreadId
fork = IO.forkIO
forkOn = IO.forkOn
forkOS = IO.forkOS
forkWithUnmask = IO.forkIOWithUnmask
forkOnWithUnmask = IO.forkOnWithUnmask
forkOSN n ma = forkOS $ do
labelMe n
ma
forkOSWithUnmask = IO.forkOSWithUnmask
forkWithUnmaskN n ma = forkWithUnmask $ \umask -> do
labelMe n
@ -714,6 +722,10 @@ instance MonadConc IO where
labelMe n
ma umask
forkOSWithUnmaskN n ma = forkOSWithUnmask $ \umask -> do
labelMe n
ma umask
isCurrentThreadBound = IO.isCurrentThreadBound
getNumCapabilities = IO.getNumCapabilities
@ -778,17 +790,12 @@ instance MonadConc m => MonadConc (IsConc m) where
type Ticket (IsConc m) = Ticket m
type ThreadId (IsConc m) = ThreadId m
fork ma = toIsConc (fork $ unIsConc ma)
forkOn i ma = toIsConc (forkOn i $ unIsConc ma)
forkOS ma = toIsConc (forkOS $ unIsConc ma)
forkOSN n ma = toIsConc (forkOSN n $ unIsConc ma)
forkWithUnmask ma = toIsConc (forkWithUnmask (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
forkWithUnmaskN n ma = toIsConc (forkWithUnmaskN n (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
forkOnWithUnmask i ma = toIsConc (forkOnWithUnmask i (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
forkOnWithUnmaskN n i ma = toIsConc (forkOnWithUnmaskN n i (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
forkOSWithUnmask ma = toIsConc (forkOSWithUnmask (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
forkOSWithUnmaskN n ma = toIsConc (forkOSWithUnmaskN n (\umask -> unIsConc $ ma (\mx -> toIsConc (umask $ unIsConc mx))))
isCurrentThreadBound = toIsConc isCurrentThreadBound
@ -831,16 +838,12 @@ instance C => MonadConc (T m) where { \
type Ticket (T m) = Ticket m ; \
type ThreadId (T m) = ThreadId m ; \
\
fork = liftedF F fork ; \
forkOn = liftedF F . forkOn ; \
forkOS = liftedF F forkOS ; \
\
forkOSN = liftedF F . forkOSN ; \
\
forkWithUnmask = liftedFork F forkWithUnmask ; \
forkWithUnmaskN n = liftedFork F (forkWithUnmaskN n ) ; \
forkOnWithUnmask i = liftedFork F (forkOnWithUnmask i) ; \
forkOnWithUnmaskN n i = liftedFork F (forkOnWithUnmaskN n i) ; \
forkOSWithUnmask = liftedFork F forkOSWithUnmask ; \
forkOSWithUnmaskN n = liftedFork F (forkOSWithUnmaskN n ) ; \
\
isCurrentThreadBound = lift isCurrentThreadBound ; \
\

10
concurrency/concurrency.cabal
View File

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: concurrency
version: 1.4.0.2
version: 1.5.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.4.0.2
tag: concurrency-1.5.0.0
library
exposed-modules: Control.Monad.Conc.Class
@ -55,14 +55,14 @@ library
-- other-modules:
-- other-extensions:
build-depends: base >=4.8 && <5
, array >=0.5 && <0.6
build-depends: base >=4.9 && <5
, array >=0.5.1 && <0.6
, atomic-primops >=0.8 && <0.9
, exceptions >=0.7 && <0.11
, monad-control >=1.0 && <1.1
, mtl >=2.2 && <2.3
, stm >=2.4 && <2.5
, transformers >=0.4 && <0.6
, transformers >=0.5 && <0.6
-- hs-source-dirs:
default-language: Haskell2010
ghc-options: -Wall

4
dejafu-tests/dejafu-tests.cabal
View File

@ -43,6 +43,7 @@ library
, Common
, QSemN
, Test.Tasty.Hedgehog
build-depends: base
, abstract-deque
@ -58,11 +59,8 @@ library
, tasty
, tasty-expected-failure
, tasty-dejafu
, tasty-hedgehog
, tasty-hunit
, vector
if impl(ghc < 8.0.1)
build-depends: transformers
hs-source-dirs: lib
default-language: Haskell2010
ghc-options: -Wall

2
dejafu-tests/lib/Common.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -Wno-deprecations -Wno-orphans #-}
{-# LANGUAGE GADTs #-}
module Common (module Common, module Test.Tasty.DejaFu, T.TestTree, T.expectFail) where

7
dejafu-tests/lib/Examples/ParMonad/Direct.hs
View File

@ -333,8 +333,7 @@ baseSessionID = 1000
{-# INLINE new #-}
-- | Creates a new @IVar@
new :: MonadConc m => Par m (IVar m a)
new = io$ do r <- newCRef Empty
pure (IVar r)
new = io$ IVar <$> newCRef Empty
{-# INLINE get #-}
-- | Read the value in an @IVar@. The 'get' operation can only return when the
@ -363,12 +362,10 @@ get (IVar vr) =
-- In this scheduler, puts immediately execute woken work in the current thread.
put_ (IVar vr) !content = do
sched <- RD.ask
ks <- io$ do
ks <- atomicModifyCRef vr $ \case
ks <- io$ atomicModifyCRef vr $ \case
Empty -> (Full content, [])
Full _ -> error "multiple put"
Blocked ks -> (Full content, ks)
pure ks
wakeUp sched ks content
-- | When an IVar is filled in, continuations wake up.

2
dejafu-tests/lib/Integration/SCT.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -Wno-deprecations #-}
module Integration.SCT where
import Control.Concurrent.Classy hiding (check)

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

@ -236,9 +236,9 @@ capabilityTests = toTestList
hacksTests :: [TestTree]
hacksTests = toTestList
[ testGroup "Subconcurrency"
[ djfuS "Failures in subconcurrency can be observed" (gives' [True]) $ do
x <- subconcurrency (newEmptyMVar >>= readMVar)
pure (either (==Deadlock) (const False) x)
[ djfuS "Failures in subconcurrency can be observed" (gives' [True]) $
either (== Deadlock) (const False) <$>
subconcurrency (newEmptyMVar >>= readMVar)
, djfuS "Actions after a failing subconcurrency still happen" (gives' [True]) $ do
var <- newMVarInt 0

239
dejafu-tests/lib/Test/Tasty/Hedgehog.hs Normal file
View File

@ -0,0 +1,239 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-
The tasty-hedgehog package:
http://hackage.haskell.org/package/tasty-hedgehog
This is the verbatim contents of tasty-hedgehog, as of version
0.1.0.2. The original code is available under the 3-clause BSD
license, which is reproduced below.
- - - - -
Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation
(CSIRO) ABN 41 687 119 230.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of QFPL nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}
-- | This package lets you test Hedgehog properties with tasty.
--
-- Typical usage would look like this:
--
-- @
-- testGroup "tasty-hedgehog tests" [
-- testProperty "reverse involutive" prop_reverse_involutive
-- , testProperty "sort idempotent" prop_sort_idempotent
-- ]
-- @
--
module Test.Tasty.Hedgehog (
testProperty
-- * Options you can pass in via tasty
, HedgehogReplay(..)
, HedgehogShowReplay(..)
, HedgehogVerbose(..)
, HedgehogTestLimit(..)
, HedgehogDiscardLimit(..)
, HedgehogShrinkLimit(..)
, HedgehogShrinkRetries(..)
) where
import Data.Typeable
import Test.Tasty.Options
import qualified Test.Tasty.Providers as T
import Hedgehog
import Hedgehog.Internal.Property
import Hedgehog.Internal.Report
import Hedgehog.Internal.Runner as H
import Hedgehog.Internal.Seed as Seed
data HP = HP T.TestName Property
deriving (Typeable)
-- | Create a 'Test' from a Hedgehog property
testProperty :: T.TestName -> Property -> T.TestTree
testProperty name prop = T.singleTest name (HP name prop)
-- | The replay token to use for replaying a previous test run
newtype HedgehogReplay = HedgehogReplay (Maybe (Size, Seed))
deriving (Typeable)
instance IsOption HedgehogReplay where
defaultValue = HedgehogReplay Nothing
parseValue v = HedgehogReplay . Just <$> replay
-- Reads a replay token in the form "{size} {seed}"
where replay = (,) <$> safeRead (unwords size) <*> safeRead (unwords seed)
(size, seed) = splitAt 2 $ words v
optionName = pure "hedgehog-replay"
optionHelp = pure "Replay token to use for replaying a previous test run"
-- | If a test case fails, show a replay token for replaying tests
newtype HedgehogShowReplay = HedgehogShowReplay Bool
deriving (Typeable)
instance IsOption HedgehogShowReplay where
defaultValue = HedgehogShowReplay True
parseValue = fmap HedgehogShowReplay . safeRead
optionName = pure "hedgehog-show-replay"
optionHelp = pure "Show a replay token for replaying tests"
-- | Show the generated Hedgehog test cases
newtype HedgehogVerbose = HedgehogVerbose Bool
deriving (Typeable)
instance IsOption HedgehogVerbose where
defaultValue = HedgehogVerbose False
parseValue = fmap HedgehogVerbose . safeRead
optionName = pure "hedgehog-verbose"
optionHelp = pure "Show the generated Hedgehog test cases"
optionCLParser = flagCLParser Nothing (HedgehogVerbose True)
-- | The number of successful test cases required before Hedgehog will pass a test
newtype HedgehogTestLimit = HedgehogTestLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)
instance IsOption HedgehogTestLimit where
defaultValue = 100
parseValue = fmap HedgehogTestLimit . safeRead
optionName = pure "hedgehog-tests"
optionHelp = pure "Number of successful test cases required before Hedgehog will pass a test"
-- | The number of discarded cases allowed before Hedgehog will fail a test
newtype HedgehogDiscardLimit = HedgehogDiscardLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)
instance IsOption HedgehogDiscardLimit where
defaultValue = 100
parseValue = fmap HedgehogDiscardLimit . safeRead
optionName = pure "hedgehog-discards"
optionHelp = pure "Number of discarded cases allowed before Hedgehog will fail a test"
-- | The number of shrinks allowed before Hedgehog will fail a test
newtype HedgehogShrinkLimit = HedgehogShrinkLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)
instance IsOption HedgehogShrinkLimit where
defaultValue = 100
parseValue = fmap HedgehogShrinkLimit . safeRead
optionName = pure "hedgehog-shrinks"
optionHelp = pure "Number of shrinks allowed before Hedgehog will fail a test"
-- | The number of times to re-run a test during shrinking
newtype HedgehogShrinkRetries = HedgehogShrinkRetries Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)
instance IsOption HedgehogShrinkRetries where
defaultValue = 10
parseValue = fmap HedgehogShrinkRetries . safeRead
optionName = pure "hedgehog-retries"
optionHelp = pure "Number of times to re-run a test during shrinking"
reportToProgress :: Int
-> Int
-> Int
-> Report Progress
-> T.Progress
reportToProgress testLimit _ shrinkLimit (Report testsDone _ status) =
let
ratio x y = 1.0 * fromIntegral x / fromIntegral y
in
-- TODO add details for tests run / discarded / shrunk
case status of
Running ->
T.Progress "Running" (ratio testsDone testLimit)
Shrinking fr ->
T.Progress "Shrinking" (ratio (failureShrinks fr) shrinkLimit)
reportOutput :: Bool
-> Bool
-> String
-> Report Result
-> IO String
reportOutput _ showReplay name report@(Report _ _ status) = do
-- TODO add details for tests run / discarded / shrunk
s <- renderResult Nothing (Just (PropertyName name)) report
pure $ case status of
Failed fr -> do
let
size = failureSize fr
seed = failureSeed fr
replayStr =
if showReplay
then "\nUse '--hedgehog-replay \"" ++ show size ++ " " ++ show seed ++ "\"' to reproduce."
else ""
s ++ replayStr
GaveUp -> "Gave up"
OK -> "OK"
instance T.IsTest HP where
testOptions =
pure [ Option (Proxy :: Proxy HedgehogReplay)
, Option (Proxy :: Proxy HedgehogShowReplay)
, Option (Proxy :: Proxy HedgehogVerbose)
, Option (Proxy :: Proxy HedgehogTestLimit)
, Option (Proxy :: Proxy HedgehogDiscardLimit)
, Option (Proxy :: Proxy HedgehogShrinkLimit)
, Option (Proxy :: Proxy HedgehogShrinkRetries)
]
run opts (HP name (Property _ pTest)) yieldProgress = do
let
HedgehogReplay replay = lookupOption opts
HedgehogShowReplay showReplay = lookupOption opts
HedgehogVerbose verbose = lookupOption opts
HedgehogTestLimit tests = lookupOption opts
HedgehogDiscardLimit discards = lookupOption opts
HedgehogShrinkLimit shrinks = lookupOption opts
HedgehogShrinkRetries retries = lookupOption opts
config =
PropertyConfig
(TestLimit tests)
(DiscardLimit discards)
(ShrinkLimit shrinks)
(ShrinkRetries retries)
randSeed <- Seed.random
let
size = maybe 0 fst replay
seed = maybe randSeed snd replay
report <- checkReport config size seed pTest (yieldProgress . reportToProgress tests discards shrinks)
let
resultFn = if reportStatus report == OK
then T.testPassed
else T.testFailed
out <- reportOutput verbose showReplay name report
pure $ resultFn out

18
dejafu/CHANGELOG.rst
View File

@ -7,6 +7,24 @@ standard Haskell versioning scheme.
.. _PVP: https://pvp.haskell.org/
1.5.0.0 - No More 7.10 (2018-03-28)
-----------------------------------
* Git: :tag:`dejafu-1.5.0.0`
* Hackage: :hackage:`dejafu-1.5.0.0`
Miscellaneous
~~~~~~~~~~~~~
* GHC 7.10 support is dropped. Dependency lower bounds are:
* :hackage:`base`: 4.9
* :hackage:`concurrency`: 1.5
* :hackage:`transformers`: 0.5
* The upper bound on :hackage:`concurrency` is 1.6.
1.4.0.0 (2018-03-17)
--------------------

31
dejafu/Test/DejaFu/Conc.hs
View File

@ -57,6 +57,7 @@ module Test.DejaFu.Conc
import Control.Exception (MaskingState(..))
import qualified Control.Monad.Catch as Ca
import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.IO.Class as IO
import Control.Monad.Trans.Class (MonadTrans(..))
import qualified Data.Foldable as F
@ -74,18 +75,9 @@ import Test.DejaFu.Internal
import Test.DejaFu.Types
import Test.DejaFu.Utils
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
-- | @since 1.4.0.0
newtype ConcT n a = C { unC :: ModelConc n a }
deriving (Functor, Applicative, Monad)
#if MIN_VERSION_base(4,9,0)
instance Fail.MonadFail (ConcT n) where
fail = C . fail
#endif
deriving (Functor, Applicative, Monad, MonadFail)
-- | A 'MonadConc' implementation using @IO@.
--
@ -141,7 +133,10 @@ instance Monad n => C.MonadConc (ConcT n) where
forkWithUnmaskN n ma = toConc (AFork n (\umask -> runModelConc (unC $ ma $ wrap umask) (\_ -> AStop (pure ()))))
forkOnWithUnmaskN n _ = C.forkWithUnmaskN n
forkOSN n ma = forkOSWithUnmaskN n (const ma)
forkOSWithUnmaskN n ma
| C.rtsSupportsBoundThreads =
toConc (AForkOS n (\umask -> runModelConc (unC $ ma $ wrap umask) (\_ -> AStop (pure ()))))
| otherwise = fail "RTS doesn't support multiple OS threads (use ghc -threaded when linking)"
isCurrentThreadBound = toConc AIsBound
@ -191,16 +186,6 @@ instance Monad n => C.MonadConc (ConcT n) where
atomically = toConc . AAtom
-- move this into the instance defn when forkOSWithUnmaskN is added to MonadConc in 2018
forkOSWithUnmaskN :: Applicative n
=> String
-> ((forall a. ConcT n a -> ConcT n a) -> ConcT n ())
-> ConcT n ThreadId
forkOSWithUnmaskN n ma
| C.rtsSupportsBoundThreads =
toConc (AForkOS n (\umask -> runModelConc (unC $ ma $ wrap umask) (\_ -> AStop (pure ()))))
| otherwise = fail "RTS doesn't support multiple OS threads (use ghc -threaded when linking)"
-- | Run a concurrent computation with a given 'Scheduler' and initial
-- state, returning a failure reason on error. Also returned is the
-- final state of the scheduler, and an execution trace.
@ -233,7 +218,7 @@ runConcurrent :: C.MonadConc n
-> n (Either Failure a, s, Trace)
runConcurrent sched memtype s ma = do
res <- runConcurrency False sched memtype s initialIdSource 2 (unC ma)
out <- efromJust "runConcurrent" <$> C.readCRef (finalRef res)
out <- efromJust <$> C.readCRef (finalRef res)
pure ( out
, cSchedState (finalContext res)
, F.toList (finalTrace res)
@ -389,7 +374,7 @@ runWithDCSnapshot sched memtype s snapshot = do
let restore = dcsRestore snapshot
let ref = dcsRef snapshot
res <- runConcurrencyWithSnapshot sched memtype context restore ref
out <- efromJust "runWithDCSnapshot" <$> C.readCRef (finalRef res)
out <- efromJust <$> C.readCRef (finalRef res)
pure ( out
, cSchedState (finalContext res)
, F.toList (finalTrace res)

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

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
@ -8,7 +9,7 @@
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental
-- Portability : MultiWayIf, RankNTypes, RecordWildCards
-- Portability : FlexibleContexts, MultiWayIf, RankNTypes, RecordWildCards
--
-- Concurrent monads with a fixed scheduler: internal types and
-- functions. This module is NOT considered to form part of the public
@ -28,6 +29,7 @@ import Data.Maybe (fromMaybe, isJust,
import Data.Monoid ((<>))
import Data.Sequence (Seq, (<|))
import qualified Data.Sequence as Seq
import GHC.Stack (HasCallStack)
import Test.DejaFu.Conc.Internal.Common
import Test.DejaFu.Conc.Internal.Memory
@ -72,7 +74,7 @@ data DCSnapshot n a = DCSnapshot
-- | Run a concurrent computation with a given 'Scheduler' and initial
-- state, returning a failure reason on error. Also returned is the
-- final state of the scheduler, and an execution trace.
runConcurrency :: C.MonadConc n
runConcurrency :: (C.MonadConc n, HasCallStack)
=> Bool
-> Scheduler g
-> MemType
@ -97,7 +99,7 @@ runConcurrency forSnapshot sched memtype g idsrc caps ma = do
-- main thread.
--
-- Only a separate function because @ADontCheck@ needs it.
runConcurrency' :: C.MonadConc n
runConcurrency' :: (C.MonadConc n, HasCallStack)
=> Bool
-> Scheduler g
-> MemType
@ -111,7 +113,7 @@ runConcurrency' forSnapshot sched memtype ctx ma = do
runThreads forSnapshot sched memtype ref ctx { cThreads = threads }
-- | Like 'runConcurrency' but starts from a snapshot.
runConcurrencyWithSnapshot :: C.MonadConc n
runConcurrencyWithSnapshot :: (C.MonadConc n, HasCallStack)
=> Scheduler g
-> MemType
-> Context n g
@ -127,7 +129,7 @@ runConcurrencyWithSnapshot sched memtype ctx restore ref = do
pure res
-- | Kill the remaining threads
killAllThreads :: C.MonadConc n => Context n g -> n ()
killAllThreads :: (C.MonadConc n, HasCallStack) => Context n g -> n ()
killAllThreads ctx =
let finalThreads = cThreads ctx
in mapM_ (`kill` finalThreads) (M.keys finalThreads)
@ -145,7 +147,7 @@ data Context n g = Context
}
-- | Run a collection of threads, until there are no threads left.
runThreads :: C.MonadConc n
runThreads :: (C.MonadConc n, HasCallStack)
=> Bool
-> Scheduler g
-> MemType
@ -189,7 +191,7 @@ runThreads forSnapshot sched memtype ref = schedule (const $ pure ()) Seq.empty
Nothing -> die InternalError restore sofar prior ctx'
Nothing -> die Abort restore sofar prior ctx'
where
(choice, g') = scheduleThread sched prior (efromList "runThreads" runnable') (cSchedState ctx)
(choice, g') = scheduleThread sched prior (efromList 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
@ -284,7 +286,7 @@ data What n g
--
-- Note: the returned snapshot action will definitely not do the right
-- thing with relaxed memory.
stepThread :: C.MonadConc n
stepThread :: (C.MonadConc n, HasCallStack)
=> Bool
-- ^ Should we record a snapshot?
-> Bool
@ -321,7 +323,7 @@ stepThread _ _ _ _ tid (AForkOS n a b) = \ctx@Context{..} -> do
-- check if the current thread is bound
stepThread _ _ _ _ tid (AIsBound c) = \ctx@Context{..} -> do
let isBound = isJust . _bound $ elookup "stepThread.AIsBound" tid cThreads
let isBound = isJust . _bound $ elookup tid cThreads
pure ( Succeeded ctx { cThreads = goto (c isBound) tid cThreads }
, Single (IsCurrentThreadBound isBound)
, const (pure ())
@ -596,7 +598,7 @@ stepThread _ _ _ _ tid (APopCatching a) = \ctx@Context{..} ->
stepThread _ _ _ _ tid (AMasking m ma c) = \ctx@Context{..} -> pure $
let resetMask typ ms = ModelConc $ \k -> AResetMask typ True ms $ k ()
umask mb = resetMask True m' >> mb >>= \b -> resetMask False m >> pure b
m' = _masking $ elookup "stepThread.AMasking" tid cThreads
m' = _masking $ elookup tid cThreads
a = runModelConc (ma umask) (AResetMask False False m' . c)
in ( Succeeded ctx { cThreads = goto a tid (mask m tid cThreads) }
, Single (SetMasking False m)
@ -632,7 +634,7 @@ stepThread forSnapshot _ sched memtype tid (ASub ma c) = \ctx ->
| M.size (cThreads ctx) > 1 -> pure (Failed IllegalSubconcurrency, Single Subconcurrency, const (pure ()))
| otherwise -> do
res <- runConcurrency False sched memtype (cSchedState ctx) (cIdSource ctx) (cCaps ctx) ma
out <- efromJust "stepThread.ASub" <$> C.readCRef (finalRef res)
out <- efromJust <$> C.readCRef (finalRef res)
pure ( Succeeded ctx
{ cThreads = goto (AStopSub (c out)) tid (cThreads ctx)
, cIdSource = cIdSource (finalContext res)
@ -660,7 +662,7 @@ stepThread forSnapshot isFirst _ _ tid (ADontCheck lb ma c) = \ctx ->
threads' <- kill tid (cThreads ctx)
let dcCtx = ctx { cThreads = threads', cSchedState = lb }
res <- runConcurrency' forSnapshot dcSched SequentialConsistency dcCtx ma
out <- efromJust "stepThread.ADontCheck" <$> C.readCRef (finalRef res)
out <- efromJust <$> C.readCRef (finalRef res)
case out of
Right a -> do
let threads'' = launch' Unmasked tid (const (c a)) (cThreads (finalContext res))

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

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
@ -8,7 +7,7 @@
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental
-- Portability : CPP, ExistentialQuantification, RankNTypes
-- Portability : ExistentialQuantification, RankNTypes
--
-- Common types and utility functions for deterministic execution of
-- 'MonadConc' implementations. This module is NOT considered to form
@ -17,14 +16,11 @@ module Test.DejaFu.Conc.Internal.Common where
import Control.Exception (Exception, MaskingState(..))
import qualified Control.Monad.Conc.Class as C
import qualified Control.Monad.Fail as Fail
import Data.Map.Strict (Map)
import Test.DejaFu.Conc.Internal.STM (ModelSTM)
import Test.DejaFu.Types
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
--------------------------------------------------------------------------------
-- * The @ModelConc@ Monad
@ -51,11 +47,9 @@ instance Monad (ModelConc n) where
return = pure
m >>= k = ModelConc $ \c -> runModelConc m (\x -> runModelConc (k x) c)
#if MIN_VERSION_base(4,9,0)
fail = Fail.fail
instance Fail.MonadFail (ModelConc n) where
#endif
fail e = ModelConc $ \_ -> AThrow (MonadFailException e)
-- | An @MVar@ is modelled as a unique ID and a reference holding a

12
dejafu/Test/DejaFu/Conc/Internal/Memory.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
@ -9,7 +10,7 @@
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental
-- Portability : BangPatterns, GADTs, LambdaCase, RecordWildCards
-- Portability : BangPatterns, GADTs, FlexibleContexts, LambdaCase, RecordWildCards
--
-- Operations over @CRef@s and @MVar@s. This module is NOT considered
-- to form part of the public interface of this library.
@ -31,6 +32,7 @@ import Data.Maybe (maybeToList)
import Data.Monoid ((<>))
import Data.Sequence (Seq, ViewL(..), singleton,
viewl, (><))
import GHC.Stack (HasCallStack)
import Test.DejaFu.Conc.Internal.Common
import Test.DejaFu.Conc.Internal.Threading
@ -174,13 +176,13 @@ tryPutIntoMVar :: C.MonadConc n
tryPutIntoMVar = mutMVar NonBlocking
-- | Read from a @MVar@, blocking if empty.
readFromMVar :: C.MonadConc n
readFromMVar :: (C.MonadConc n, HasCallStack)
=> ModelMVar n a
-> (a -> Action n)
-> ThreadId
-> Threads n
-> n (Bool, Threads n, [ThreadId], n ())
readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . efromJust "readFromMVar")
readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . efromJust)
-- | Try to read from a @MVar@, not blocking if empty.
tryReadFromMVar :: C.MonadConc n
@ -192,13 +194,13 @@ tryReadFromMVar :: C.MonadConc n
tryReadFromMVar = seeMVar NonEmptying NonBlocking
-- | Take from a @MVar@, blocking if empty.
takeFromMVar :: C.MonadConc n
takeFromMVar :: (C.MonadConc n, HasCallStack)
=> ModelMVar n a
-> (a -> Action n)
-> ThreadId
-> Threads n
-> n (Bool, Threads n, [ThreadId], n ())
takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . efromJust "takeFromMVar")
takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . efromJust)
-- | Try to take from a @MVar@, not blocking if empty.
tryTakeFromMVar :: C.MonadConc n

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

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
@ -12,7 +11,7 @@
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental
-- Portability : CPP, ExistentialQuantification, NoMonoLocalBinds, RecordWildCards, TypeFamilies
-- Portability : ExistentialQuantification, NoMonoLocalBinds, RecordWildCards, TypeFamilies
--
-- 'MonadSTM' testing implementation, internal types and definitions.
-- This module is NOT considered to form part of the public interface
@ -25,16 +24,13 @@ import Control.Exception (Exception, SomeException,
import Control.Monad (MonadPlus(..))
import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
import qualified Control.Monad.Conc.Class as C
import qualified Control.Monad.Fail as Fail
import qualified Control.Monad.STM.Class as S
import Data.List (nub)
import Test.DejaFu.Internal
import Test.DejaFu.Types
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
--------------------------------------------------------------------------------
-- * The @ModelSTM@ monad
@ -56,11 +52,9 @@ instance Monad (ModelSTM n) where
return = pure
m >>= k = ModelSTM $ \c -> runModelSTM m (\x -> runModelSTM (k x) c)
#if MIN_VERSION_base(4,9,0)
fail = Fail.fail
instance Fail.MonadFail (ModelSTM n) where
#endif
fail e = ModelSTM $ \_ -> SThrow (MonadFailException e)
instance MonadThrow (ModelSTM n) where

50
dejafu/Test/DejaFu/Conc/Internal/Threading.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-- |
@ -7,7 +8,7 @@
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental
-- Portability : ExistentialQuantification, RankNTypes
-- Portability : ExistentialQuantification, FlexibleContexts, RankNTypes
--
-- Operations and types for threads. This module is NOT considered to
-- form part of the public interface of this library.
@ -21,6 +22,7 @@ import Data.List (intersect)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (isJust)
import GHC.Stack (HasCallStack)
import Test.DejaFu.Conc.Internal.Common
import Test.DejaFu.Internal
@ -84,9 +86,9 @@ data Handler n = forall e. Exception e => Handler (e -> MaskingState -> Action n
-- | Propagate an exception upwards, finding the closest handler
-- which can deal with it.
propagate :: SomeException -> ThreadId -> Threads n -> Maybe (Threads n)
propagate :: HasCallStack => SomeException -> ThreadId -> Threads n -> Maybe (Threads n)
propagate e tid threads = raise <$> propagate' handlers where
handlers = _handlers (elookup "propagate" tid threads)
handlers = _handlers (elookup tid threads)
raise (act, hs) = except act hs tid threads
@ -100,53 +102,53 @@ interruptible thread =
(_masking thread == MaskedInterruptible && isJust (_blocking thread))
-- | Register a new exception handler.
catching :: Exception e => (e -> Action n) -> ThreadId -> Threads n -> Threads n
catching h = eadjust "catching" $ \thread ->
catching :: (Exception e, HasCallStack) => (e -> Action n) -> ThreadId -> Threads n -> Threads n
catching h = eadjust $ \thread ->
let ms0 = _masking thread
h' = Handler $ \e ms -> (if ms /= ms0 then AResetMask False False ms0 else id) (h e)
in thread { _handlers = h' : _handlers thread }
-- | Remove the most recent exception handler.
uncatching :: ThreadId -> Threads n -> Threads n
uncatching = eadjust "uncatching" $ \thread ->
thread { _handlers = etail "uncatching" (_handlers thread) }
uncatching :: HasCallStack => ThreadId -> Threads n -> Threads n
uncatching = eadjust $ \thread ->
thread { _handlers = etail (_handlers thread) }
-- | Raise an exception in a thread.
except :: (MaskingState -> Action n) -> [Handler n] -> ThreadId -> Threads n -> Threads n
except actf hs = eadjust "except" $ \thread -> thread
except :: HasCallStack => (MaskingState -> Action n) -> [Handler n] -> ThreadId -> Threads n -> Threads n
except actf hs = eadjust $ \thread -> thread
{ _continuation = actf (_masking thread)
, _handlers = hs
, _blocking = Nothing
}
-- | Set the masking state of a thread.
mask :: MaskingState -> ThreadId -> Threads n -> Threads n
mask ms = eadjust "mask" $ \thread -> thread { _masking = ms }
mask :: HasCallStack => MaskingState -> ThreadId -> Threads n -> Threads n
mask ms = eadjust $ \thread -> thread { _masking = ms }
--------------------------------------------------------------------------------
-- * Manipulating threads
-- | Replace the @Action@ of a thread.
goto :: Action n -> ThreadId -> Threads n -> Threads n
goto a = eadjust "goto" $ \thread -> thread { _continuation = a }
goto :: HasCallStack => Action n -> ThreadId -> Threads n -> Threads n
goto a = eadjust $ \thread -> thread { _continuation = a }
-- | Start a thread with the given ID, inheriting the masking state
-- from the parent thread. This ID must not already be in use!
launch :: ThreadId -> ThreadId -> ((forall b. ModelConc n b -> ModelConc n b) -> Action n) -> Threads n -> Threads n
launch :: HasCallStack => ThreadId -> ThreadId -> ((forall b. ModelConc n b -> ModelConc n b) -> Action n) -> Threads n -> Threads n
launch parent tid a threads = launch' ms tid a threads where
ms = _masking (elookup "launch" parent threads)
ms = _masking (elookup parent threads)
-- | Start a thread with the given ID and masking state. This must not already be in use!
launch' :: MaskingState -> ThreadId -> ((forall b. ModelConc n b -> ModelConc n b) -> Action n) -> Threads n -> Threads n
launch' ms tid a = einsert "launch'" tid thread where
launch' :: HasCallStack => MaskingState -> ThreadId -> ((forall b. ModelConc n b -> ModelConc n b) -> Action n) -> Threads n -> Threads n
launch' ms tid a = einsert tid thread where
thread = Thread (a umask) Nothing [] ms Nothing
umask mb = resetMask True Unmasked >> mb >>= \b -> resetMask False ms >> pure b
resetMask typ m = ModelConc $ \k -> AResetMask typ True m $ k ()
-- | Block a thread.
block :: BlockedOn -> ThreadId -> Threads n -> Threads n
block blockedOn = eadjust "block" $ \thread -> thread { _blocking = Just blockedOn }
block :: HasCallStack => BlockedOn -> ThreadId -> Threads n -> Threads n
block blockedOn = eadjust $ \thread -> thread { _blocking = Just blockedOn }
-- | Unblock all threads waiting on the appropriate block. For 'TVar'
-- blocks, this will wake all threads waiting on at least one of the
@ -165,13 +167,13 @@ wake blockedOn threads = (unblock <$> threads, M.keys $ M.filter isBlocked threa
-- ** Bound threads
-- | Turn a thread into a bound thread.
makeBound :: C.MonadConc n => ThreadId -> Threads n -> n (Threads n)
makeBound :: (C.MonadConc n, HasCallStack) => ThreadId -> Threads n -> n (Threads n)
makeBound tid threads = do
runboundIO <- C.newEmptyMVar
getboundIO <- C.newEmptyMVar
btid <- C.forkOSN ("bound worker for '" ++ show tid ++ "'") (go runboundIO getboundIO)
let bt = BoundThread runboundIO getboundIO btid
pure (eadjust "makeBound" (\t -> t { _bound = Just bt }) tid threads)
pure (eadjust (\t -> t { _bound = Just bt }) tid threads)
where
go runboundIO getboundIO = forever $ do
na <- C.takeMVar runboundIO
@ -180,9 +182,9 @@ makeBound tid threads = do
-- | Kill a thread and remove it from the thread map.
--
-- If the thread is bound, the worker thread is cleaned up.
kill :: C.MonadConc n => ThreadId -> Threads n -> n (Threads n)
kill :: (C.MonadConc n, HasCallStack) => ThreadId -> Threads n -> n (Threads n)
kill tid threads = do
let thread = elookup "kill" tid threads
let thread = elookup tid threads
maybe (pure ()) (C.killThread . _boundTId) (_bound thread)
pure (M.delete tid threads)

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

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
-- |
@ -8,7 +9,7 @@
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental
-- Portability : DeriveAnyClass, DeriveGeneric, GADTs
-- Portability : DeriveAnyClass, DeriveGeneric, FlexibleContexts, GADTs
--
-- Internal types and functions used throughout DejaFu. This module
-- is NOT considered to form part of the public interface of this
@ -23,6 +24,7 @@ import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack, withFrozenCallStack)
import System.Random (RandomGen)
import Test.DejaFu.Types
@ -328,53 +330,53 @@ simplifyLookahead _ = UnsynchronisedOther
-- | '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"
etail :: HasCallStack => [a] -> [a]
etail (_:xs) = xs
etail _ = withFrozenCallStack $ fatal "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
eidx :: HasCallStack => [a] -> Int -> a
eidx xs i
| i < length xs = xs !! i
| otherwise = fatal src "(!!): index too large"
| otherwise = withFrozenCallStack $ fatal "(!!): 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"
efromJust :: HasCallStack => Maybe a -> a
efromJust (Just x) = x
efromJust _ = withFrozenCallStack $ fatal "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"
efromList :: HasCallStack => [a] -> NonEmpty a
efromList (x:xs) = x:|xs
efromList _ = withFrozenCallStack $ fatal "fromList: empty list"
-- | 'M.adjust' but which errors if the key is not present. Use this
-- only where it shouldn't fail!
eadjust :: (Ord k, Show k) => String -> (v -> v) -> k -> M.Map k v -> M.Map k v
eadjust src f k m = case M.lookup k m of
eadjust :: (Ord k, Show k, HasCallStack) => (v -> v) -> k -> M.Map k v -> M.Map k v
eadjust f k m = case M.lookup k m of
Just v -> M.insert k (f v) m
Nothing -> fatal src ("adjust: key '" ++ show k ++ "' not found")
Nothing -> withFrozenCallStack $ fatal ("adjust: key '" ++ show k ++ "' not found")
-- | 'M.insert' but which errors if the key is already present. Use
-- this only where it shouldn't fail!
einsert :: (Ord k, Show k) => String -> k -> v -> M.Map k v -> M.Map k v
einsert src k v m
| M.member k m = fatal src ("insert: key '" ++ show k ++ "' already present")
einsert :: (Ord k, Show k, HasCallStack) => k -> v -> M.Map k v -> M.Map k v
einsert k v m
| M.member k m = withFrozenCallStack $ fatal ("insert: key '" ++ show k ++ "' already present")
| otherwise = M.insert k v m
-- | 'M.lookup' but which errors if the key is not present. Use this
-- only where it shouldn't fail!
elookup :: (Ord k, Show k) => String -> k -> M.Map k v -> v
elookup src k =
fromMaybe (fatal src ("lookup: key '" ++ show k ++ "' not found")) .
elookup :: (Ord k, Show k, HasCallStack) => k -> M.Map k v -> v
elookup k =
fromMaybe (withFrozenCallStack $ fatal ("lookup: key '" ++ show k ++ "' not found")) .
M.lookup k
-- | 'error' but saying where it came from
fatal :: String -> String -> a
fatal src msg = error ("(dejafu: " ++ src ++ ") " ++ msg)
fatal :: HasCallStack => String -> a
fatal msg = withFrozenCallStack $ error ("(dejafu) " ++ msg)
-------------------------------------------------------------------------------
-- * Miscellaneous

2
dejafu/Test/DejaFu/SCT.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -Wno-deprecations #-}
-- |
-- Module : Test.DejaFu.SCT
-- Copyright : (c) 2015--2018 Michael Walker

43
dejafu/Test/DejaFu/SCT/Internal.hs
View File

@ -20,6 +20,7 @@ import Data.Coerce (Coercible, coerce)
import qualified Data.IntMap.Strict as I
import Data.List (find, mapAccumL)
import Data.Maybe (fromMaybe)
import GHC.Stack (HasCallStack)
import Test.DejaFu.Conc
import Test.DejaFu.Conc.Internal (Context(..), DCSnapshot(..))
@ -34,7 +35,7 @@ import Test.DejaFu.Utils
-- * Exploration
-- | General-purpose SCT function.
sct :: MonadConc n
sct :: (MonadConc n, HasCallStack)
=> Settings n a
-- ^ The SCT settings ('Way' is ignored)
-> ([ThreadId] -> s)
@ -75,11 +76,11 @@ sct settings s0 sfun srun conc
runFull sched s = runConcurrent sched (_memtype settings) s conc
runSnap snap sched s = runWithDCSnapshot sched (_memtype settings) s snap
debugFatal = if _debugFatal settings then fatal "sct" else debugPrint
debugFatal = if _debugFatal settings then fatal else debugPrint
debugPrint = fromMaybe (const (pure ())) (_debugPrint settings)
-- | Like 'sct' but given a function to run the computation.
sct' :: MonadConc n
sct' :: (MonadConc n, HasCallStack)
=> Settings n a
-- ^ The SCT settings ('Way' is ignored)
-> s
@ -95,7 +96,7 @@ sct' :: MonadConc n
-> CRefId
-- ^ The first available @CRefId@
-> n [(Either Failure a, Trace)]
sct' settings s0 sfun srun run nextTId nextCRId = go Nothing [] s0 where
sct' settings s0 sfun srun run nTId nCRId = go Nothing [] s0 where
go (Just res) _ _ | earlyExit res = pure []
go _ seen !s = case sfun s of
Just t -> srun s t >>= \case
@ -126,7 +127,7 @@ sct' settings s0 sfun srun run nextTId nextCRId = go Nothing [] s0 where
dosimplify res trace seen s
| not (_simplify settings) = ((res, trace) :) <$> go (Just res) seen s
| otherwise = do
shrunk <- simplifyExecution settings run nextTId nextCRId res trace
shrunk <- simplifyExecution settings run nTId nCRId res trace
(shrunk :) <$> go (Just res) seen s
earlyExit = fromMaybe (const False) (_earlyExit settings)
@ -146,7 +147,7 @@ sct' settings s0 sfun srun run nextTId nextCRId = go Nothing [] s0 where
-- Unlike shrinking in randomised property-testing tools like
-- QuickCheck or Hedgehog, we only run the test case /once/, at the
-- end, rather than after every simplification step.
simplifyExecution :: MonadConc n
simplifyExecution :: (MonadConc n, HasCallStack)
=> Settings n a
-- ^ The SCT settings ('Way' is ignored)
-> (forall x. Scheduler x -> x -> n (Either Failure a, x, Trace))
@ -159,7 +160,7 @@ simplifyExecution :: MonadConc n
-- ^ The expected result
-> Trace
-> n (Either Failure a, Trace)
simplifyExecution settings run nextTId nextCRId res trace
simplifyExecution settings run nTId nCRId res trace
| tidTrace == simplifiedTrace = do
debugPrint ("Simplifying new result '" ++ p res ++ "': no simplification possible!")
pure (res, trace)
@ -176,9 +177,9 @@ simplifyExecution settings run nextTId nextCRId res trace
where
tidTrace = toTIdTrace trace
simplifiedTrace = simplify (_memtype settings) tidTrace
fixup = renumber (_memtype settings) (fromId nextTId) (fromId nextCRId)
fixup = renumber (_memtype settings) (fromId nTId) (fromId nCRId)
debugFatal = if _debugFatal settings then fatal "sct" else debugPrint
debugFatal = if _debugFatal settings then fatal else debugPrint
debugPrint = fromMaybe (const (pure ())) (_debugPrint settings)
debugShow = fromMaybe (const "_") (_debugShow settings)
p = either show debugShow
@ -333,14 +334,14 @@ renumber memtype tid0 crid0 = snd . mapAccumL go (I.empty, tid0, I.empty, crid0)
-- I can't help but feel there should be some generic programming
-- solution to this sort of thing (and to the many other functions
-- operating over @ThreadAction@s / @Lookahead@s)
updateAction (tidmap, nexttid, cridmap, nextcrid) (Fork old) =
let tidmap' = I.insert (fromId old) nexttid tidmap
nexttid' = nexttid + 1
in ((tidmap', nexttid', cridmap, nextcrid), Fork (toId nexttid))
updateAction (tidmap, nexttid, cridmap, nextcrid) (ForkOS old) =
let tidmap' = I.insert (fromId old) nexttid tidmap
nexttid' = nexttid + 1
in ((tidmap', nexttid', cridmap, nextcrid), ForkOS (toId nexttid))
updateAction (tidmap, nTId, cridmap, nCRId) (Fork old) =
let tidmap' = I.insert (fromId old) nTId tidmap
nTId' = nTId + 1
in ((tidmap', nTId', cridmap, nCRId), Fork (toId nTId))
updateAction (tidmap, nTId, cridmap, nCRId) (ForkOS old) =
let tidmap' = I.insert (fromId old) nTId tidmap
nTId' = nTId + 1
in ((tidmap', nTId', cridmap, nCRId), ForkOS (toId nTId))
updateAction s@(tidmap, _, _, _) (PutMVar mvid olds) =
(s, PutMVar mvid (map (renumbered tidmap) olds))
updateAction s@(tidmap, _, _, _) (TryPutMVar mvid b olds) =
@ -349,10 +350,10 @@ renumber memtype tid0 crid0 = snd . mapAccumL go (I.empty, tid0, I.empty, crid0)
(s, TakeMVar mvid (map (renumbered tidmap) olds))
updateAction s@(tidmap, _, _, _) (TryTakeMVar mvid b olds) =
(s, TryTakeMVar mvid b (map (renumbered tidmap) olds))
updateAction (tidmap, nexttid, cridmap, nextcrid) (NewCRef old) =
let cridmap' = I.insert (fromId old) nextcrid cridmap
nextcrid' = nextcrid + 1
in ((tidmap, nexttid, cridmap', nextcrid'), NewCRef (toId nextcrid))
updateAction (tidmap, nTId, cridmap, nCRId) (NewCRef old) =
let cridmap' = I.insert (fromId old) nCRId cridmap
nCRId' = nCRId + 1
in ((tidmap, nTId, cridmap', nCRId'), NewCRef (toId nCRId))
updateAction s@(_, _, cridmap, _) (ReadCRef old) =
(s, ReadCRef (renumbered cridmap old))
updateAction s@(_, _, cridmap, _) (ReadCRefCas old) =

55
dejafu/Test/DejaFu/SCT/Internal/DPOR.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
-- |
@ -8,7 +9,7 @@
-- License : MIT
-- Maintainer : Michael Walker <mike@barrucadu.co.uk>
-- Stability : experimental
-- Portability : DeriveAnyClass, DeriveGeneric, ViewPatterns
-- Portability : DeriveAnyClass, DeriveGeneric, FlexibleContexts, ViewPatterns
--
-- Internal types and functions for SCT via dynamic partial-order
-- reduction. This module is NOT considered to form part of the
@ -31,6 +32,7 @@ import qualified Data.Sequence as Sq
import Data.Set (Set)
import qualified Data.Set as S
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Test.DejaFu.Internal
import Test.DejaFu.Schedule (Scheduler(..))
@ -69,13 +71,13 @@ data DPOR = DPOR
--
-- This is a reasonable thing to do, because if the state is corrupted
-- then nothing sensible can happen anyway.
validateDPOR :: String -> DPOR -> DPOR
validateDPOR src dpor
| not (todo `S.isSubsetOf` runnable) = fatal src "thread exists in todo set but not runnable set"
| not (done `S.isSubsetOf` runnable) = fatal src "thread exists in done set but not runnable set"
| not (taken `S.isSubsetOf` done) = fatal src "thread exists in taken set but not done set"
| not (todo `disjoint` done) = fatal src "thread exists in both taken set and done set"
| not (maybe True (`S.member` done) next) = fatal src "taken thread does not exist in done set"
validateDPOR :: HasCallStack => DPOR -> DPOR
validateDPOR dpor
| not (todo `S.isSubsetOf` runnable) = fatal "thread exists in todo set but not runnable set"
| not (done `S.isSubsetOf` runnable) = fatal "thread exists in done set but not runnable set"
| not (taken `S.isSubsetOf` done) = fatal "thread exists in taken set but not done set"
| not (todo `disjoint` done) = fatal "thread exists in both taken set and done set"
| not (maybe True (`S.member` done) next) = fatal "taken thread does not exist in done set"
| otherwise = dpor
where
done = dporDone dpor
@ -151,8 +153,8 @@ findSchedulePrefix dpor = case dporNext dpor of
sleeps = dporSleep dpor `M.union` dporTaken dpor
-- | Add a new trace to the stack. This won't work if to-dos aren't explored depth-first.
incorporateTrace
:: MemType
incorporateTrace :: HasCallStack
=> MemType
-> Bool
-- ^ Whether the \"to-do\" point which was used to create this new
-- execution was conservative or not.
@ -168,9 +170,9 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
in case dporNext dpor of
Just (t, child)
| t == tid' ->
validateDPOR "incorporateTrace (grow / Just)" $ dpor { dporNext = Just (tid', grow state' tid' rest child) }
| hasTodos child -> fatal "incorporateTrace" "replacing child with todos!"
_ -> validateDPOR "incorporateTrace (grow / Nothing)" $
validateDPOR $ dpor { dporNext = Just (tid', grow state' tid' rest child) }
| hasTodos child -> fatal "replacing child with todos!"
_ -> validateDPOR $
let taken = M.insert tid' a (dporTaken dpor)
sleep = dporSleep dpor `M.union` dporTaken dpor
in dpor { dporTaken = if conservative then dporTaken dpor else taken
@ -178,13 +180,13 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
, dporNext = Just (tid', subtree state' tid' sleep trc)
, dporDone = S.insert tid' (dporDone dpor)
}
grow _ _ [] _ = fatal "incorporateTrace" "trace exhausted without reading a to-do point!"
grow _ _ [] _ = fatal "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)
-- Construct a new subtree corresponding to a trace suffix.
subtree state tid sleep ((_, _, a):rest) = validateDPOR "incorporateTrace (subtree)" $
subtree state tid sleep ((_, _, a):rest) = validateDPOR $
let state' = updateDepState memtype state tid a
sleep' = M.filterWithKey (\t a' -> not $ dependent state' tid a t a') sleep
in DPOR
@ -205,7 +207,7 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
((d', _, a'):_) -> M.singleton (tidOf tid d') a'
[] -> M.empty
}
subtree _ _ _ [] = fatal "incorporateTrace" "subtree suffix empty!"
subtree _ _ _ [] = fatal "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
@ -299,8 +301,9 @@ findBacktrackSteps memtype backtrack boundKill = go initialDepState S.empty init
-- | Add new backtracking points, if they have not already been
-- visited and aren't in the sleep set.
incorporateBacktrackSteps :: [BacktrackStep] -> DPOR -> DPOR
incorporateBacktrackSteps (b:bs) dpor = validateDPOR "incorporateBacktrackSteps" dpor' where
incorporateBacktrackSteps :: HasCallStack
=> [BacktrackStep] -> DPOR -> DPOR
incorporateBacktrackSteps (b:bs) dpor = validateDPOR dpor' where
tid = bcktThreadid b
dpor' = dpor
@ -318,9 +321,9 @@ incorporateBacktrackSteps (b:bs) dpor = validateDPOR "incorporateBacktrackSteps"
child = case dporNext dpor of
Just (t, d)
| t /= tid -> fatal "incorporateBacktrackSteps" "incorporating wrong trace!"
| t /= tid -> fatal "incorporating wrong trace!"
| otherwise -> incorporateBacktrackSteps bs d
Nothing -> fatal "incorporateBacktrackSteps" "child is missing!"
Nothing -> fatal "child is missing!"
incorporateBacktrackSteps [] dpor = dpor
-------------------------------------------------------------------------------
@ -393,8 +396,8 @@ type BacktrackFunc
-- | Add a backtracking point. If the thread isn't runnable, add all
-- runnable threads. If the backtracking point is already present,
-- don't re-add it UNLESS this would make it conservative.
backtrackAt
:: (ThreadId -> BacktrackStep -> Bool)
backtrackAt :: HasCallStack
=> (ThreadId -> BacktrackStep -> Bool)
-- ^ If this returns @True@, backtrack to all runnable threads,
-- rather than just the given thread.
-> BacktrackFunc
@ -423,7 +426,7 @@ backtrackAt toAll bs0 = backtrackAt' . nubBy ((==) `on` fst') . sortOn fst' wher
((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 _ [] _ _ _ _ = fatal "backtrackAt" "ran out of schedule whilst backtracking!"
go _ [] _ _ _ _ = fatal "ran out of schedule whilst backtracking!"
-- Backtrack to a single thread
backtrackTo tid c = M.insert tid c . bcktBacktracks
@ -439,8 +442,8 @@ backtrackAt toAll bs0 = backtrackAt' . nubBy ((==) `on` fst') . sortOn fst' wher
-- the prior thread if it's (1) still runnable and (2) hasn't just
-- yielded. Furthermore, threads which /will/ yield are ignored in
-- preference of those which will not.
dporSched
:: MemType
dporSched :: HasCallStack
=> MemType
-> IncrementalBoundFunc k
-- ^ Bound function: returns true if that schedule prefix terminated
-- with the lookahead decision fits within the bound.
@ -501,7 +504,7 @@ dporSched memtype boundf = Scheduler $ \prior threads s ->
decision = decisionOf (fst <$> prior) (S.fromList tids)
-- Get the action of a thread
action t = efromJust "dporSched.action" (lookup t threads')
action t = efromJust (lookup t threads')
-- The runnable thread IDs
tids = map fst threads'

2
dejafu/Test/DejaFu/Schedule.hs
View File

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

12
dejafu/dejafu.cabal
View File

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: dejafu
version: 1.4.0.0
version: 1.5.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-1.4.0.0
tag: dejafu-1.5.0.0
library
exposed-modules: Test.DejaFu
@ -58,17 +58,15 @@ library
-- other-modules:
-- other-extensions:
build-depends: base >=4.8 && <5
, concurrency >=1.3 && <1.5
build-depends: base >=4.9 && <5
, concurrency >=1.5 && <1.6
, containers >=0.5 && <0.6
, deepseq >=1.1 && <2
, exceptions >=0.7 && <0.11
, leancheck >=0.6 && <0.8
, profunctors >=4.0 && <6.0
, random >=1.0 && <1.2
, transformers >=0.4 && <0.6
, transformers >=0.5 && <0.6
-- hs-source-dirs:
default-language: Haskell2010
ghc-options: -Wall
if impl(ghc < 8.0.1)
build-depends: semigroups >=0.16 && <0.19

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.4.0.2", "Typeclasses, functions, and data types for concurrency and STM"
":hackage:`dejafu`", "1.4.0.0", "Systematic testing for Haskell concurrency"
":hackage:`hunit-dejafu`", "1.1.0.3", "Déjà Fu support for the HUnit test framework"
":hackage:`tasty-dejafu`", "1.1.0.2", "Déjà Fu support for the tasty test framework"
":hackage:`concurrency`", "1.5.0.0", "Typeclasses, functions, and data types for concurrency and STM"
":hackage:`dejafu`", "1.5.0.0", "Systematic testing for Haskell concurrency"
":hackage:`hunit-dejafu`", "1.2.0.0", "Déjà Fu support for the HUnit test framework"
":hackage:`tasty-dejafu`", "1.2.0.0", "Déjà Fu support for the tasty test framework"
Installation

2
doc/ghc.rst
View File

@ -8,9 +8,9 @@ The currently supported versions are:
.. csv-table::
:header: "GHC", "Stackage", "base"
"8.4", "", "4.11.0.0"
"8.2", "LTS 10.0", "4.10.1.0"
"8.0", "LTS 9.0", "4.9.1.0"
"7.10", "LTS 6.0", "4.8.2.0"
In practice, we may *compile with* older versions of GHC, but keeping
them working is not a priority.

18
hunit-dejafu/CHANGELOG.rst
View File

@ -7,6 +7,24 @@ standard Haskell versioning scheme.
.. _PVP: https://pvp.haskell.org/
1.2.0.0 - No More 7.10 (2018-03-28)
-----------------------------------
* Git: :tag:`hunit-dejafu-1.2.0.0`
* Hackage: :hackage:`hunit-dejafu-1.2.0.0`
Miscellaneous
~~~~~~~~~~~~~
* GHC 7.10 support is dropped. Dependency lower bounds are:
* :hackage:`base`: 4.9
* :hackage:`dejafu`: 1.5
* :hackage:`HUnit`: 1.3.1
* The upper bound on :hackage:`dejafu` is 1.6.
1.1.0.3 (2018-03-17)
--------------------

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

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

17
tasty-dejafu/CHANGELOG.rst
View File

@ -7,6 +7,23 @@ standard Haskell versioning scheme.
.. _PVP: https://pvp.haskell.org/
1.2.0.0 - No More 7.10 (2018-03-28)
-----------------------------------
* Git: :tag:`tasty-dejafu-1.2.0.0`
* Hackage: :hackage:`tasty-dejafu-1.2.0.0`
Miscellaneous
~~~~~~~~~~~~~
* GHC 7.10 support is dropped. Dependency lower bounds are:
* :hackage:`base`: 4.9
* :hackage:`dejafu`: 1.5
* The upper bound on :hackage:`dejafu` is 1.6.
1.1.0.2 (2018-03-17)
--------------------

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

@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: tasty-dejafu
version: 1.1.0.2
version: 1.2.0.0
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-1.1.0.2
tag: tasty-dejafu-1.2.0.0
library
exposed-modules: Test.Tasty.DejaFu
-- other-modules:
-- other-extensions:
build-depends: base >=4.8 && <5
, dejafu >=1.2 && <1.5
build-depends: base >=4.9 && <5
, dejafu >=1.5 && <1.6
, random >=1.0 && <1.2
, tagged >=0.8 && <0.9
, tasty >=0.10 && <1.1