dejafu 1.4.0.0 → 1.5.0.0

raw patch · 13 files changed

+162/−159 lines, 13 filesdep −semigroupsdep ~basedep ~concurrencydep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies removed: semigroups

Dependency ranges changed: base, concurrency, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.rst +18/−0
• Test/DejaFu/Conc.hs +8/−23
• Test/DejaFu/Conc/Internal.hs +14/−12
• Test/DejaFu/Conc/Internal/Common.hs +2/−8
• Test/DejaFu/Conc/Internal/Memory.hs +7/−5
• Test/DejaFu/Conc/Internal/STM.hs +2/−8
• Test/DejaFu/Conc/Internal/Threading.hs +26/−24
• Test/DejaFu/Internal.hs +26/−24
• Test/DejaFu/SCT.hs +2/−0
• Test/DejaFu/SCT/Internal.hs +22/−21
• Test/DejaFu/SCT/Internal/DPOR.hs +29/−26
• Test/DejaFu/Schedule.hs +1/−1
• dejafu.cabal +5/−7

@@ -7,6 +7,24 @@ .. _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) -------------------- 

@@ -57,6 +57,7 @@  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.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 @@    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 @@    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 @@   -> 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 @@   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)

@@ -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.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 @@ -- | 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 @@ -- 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 @@   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 @@   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 @@   }  -- | 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 @@              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 @@ -- -- 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 @@  -- 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 (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 @@      | 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 @@          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))

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

@@ -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.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 = 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 = 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

@@ -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.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 @@     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

@@ -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.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 @@  -- | 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 @@   (_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 @@ -- ** 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 @@ -- | 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) 

@@ -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.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 @@  -- | '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

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

@@ -20,6 +20,7 @@ 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 @@ -- * 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 @@     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 @@   -> 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 @@   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 @@ -- 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 @@   -- ^ 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 @@   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 @@   -- 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 @@     (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) =

@@ -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           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 @@ -- -- 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 @@     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 @@     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 @@                    , 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 @@           ((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 @@  -- | 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 @@    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 @@ -- | 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 @@         ((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 @@ -- 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 @@     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'

@@ -63,7 +63,7 @@   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'.

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