diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Revision history of io-sim +## 1.11.0.0 + +### Breaking changes + +* Removed `EventSayEvaluationError` and `EventLogEvaluationError`. + +### Non-breaking changes + +* Added `ppSayTrace` which pritty prints `EventSay` which are coming from `say` usage. +* Repository moved to https://github.com/IntersectMBO/io-sim +* Exported `traceMarker`, `traceEvent` from `Control.Monad.Class.MonadEventlog`. +* `say`, `traceM` and `traceSTM` no longer evaluate their arguments to _NF_ or + _WHNF_. This is dropped since it introduced a performance regression in + `io-sim-1.10` on large tests which include `say` used just for debugging + purposes. + ## 1.10.1.0 ### Non-breaking changes diff --git a/NOTICE b/NOTICE --- a/NOTICE +++ b/NOTICE @@ -1,4 +1,4 @@ -Copyright 2019-2024 Input Output Global Inc (IOG) +Copyright 2019-2026 Input Output Global Inc (IOG), 2026 Intersect Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -47,9 +47,9 @@ * [Marcin Szamotulski (@coot) IOSim and Partial Order Reduction][io-sim-por-presentation] [`io-sim`]: https://hackage.haskell.org/package/io-sim -[`io-classes`]: https://input-output-hk.github.io/io-sim/io-classes/index.html -[`si-timers`]: https://input-output-hk.github.io/io-sim/io-classes/si-timers/index.html -[`IOSimPOR`]: https://github.com/input-output-hk/io-sim/tree/main/io-sim/how-to-use-IOSimPOR.md +[`io-classes`]: https://intersectmbo/io-sim/io-classes/index.html +[`si-timers`]: https://intersectmbo/io-sim/io-classes/si-timers/index.html +[`IOSimPOR`]: https://github.com/intersectmbo/io-sim/tree/main/io-sim/how-to-use-IOSimPOR.md [`IOSim`]: https://hackage.haskell.org/package/io-sim/docs/Control-Monad-IOSim.html#t:IOSim [bob-conf]: https://youtu.be/uedUGeWN4ZM diff --git a/io-sim.cabal b/io-sim.cabal --- a/io-sim.cabal +++ b/io-sim.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: io-sim -version: 1.10.1.0 +version: 1.11.0.0 synopsis: A pure simulator for monadic concurrency with STM. description: A pure simulator monad with support of concurrency (base & async style), stm, @@ -9,16 +9,16 @@ = Documentation Documentation is published - [here](https://input-output-hk.github.io/io-sim/io-sim). + [here](https://intersectmbo.github.io/io-sim/io-sim). license: Apache-2.0 license-files: LICENSE NOTICE -copyright: 2022-2025 Input Output Global Inc (IOG) +copyright: 2022-2026 Input Output Global Inc (IOG) 2026 Intersect author: Alexander Vieth, Duncan Coutts, John Hughes, Marcin Szamotulski maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Testing build-type: Simple extra-doc-files: CHANGELOG.md README.md -bug-reports: https://github.com/input-output-hk/io-sim/issues +bug-reports: https://github.com/intersectmbo/io-sim/issues tested-with: GHC == { 9.6, 9.8, 9.10, 9.12, 9.14 } flag asserts @@ -28,7 +28,7 @@ source-repository head type: git - location: https://github.com/input-output-hk/io-sim + location: https://github.com/intersectmbo/io-sim subdir: io-sim common test-warnings @@ -66,7 +66,7 @@ default-extensions: GADTs build-depends: base >=4.16 && <4.23, io-classes:{io-classes,strict-stm,si-timers} - ^>=1.10, + ^>=1.11, exceptions >=0.10, containers, deepseq, diff --git a/src/Control/Monad/IOSim.hs b/src/Control/Monad/IOSim.hs --- a/src/Control/Monad/IOSim.hs +++ b/src/Control/Monad/IOSim.hs @@ -58,6 +58,7 @@ -- ** Pretty printers , ppTrace , ppTrace_ + , ppSayTrace , ppEvents , ppSimEvent , ppDebug @@ -361,12 +362,12 @@ -- | An internal failure of the simulator. -- -- Please open an issue at - -- . + -- . | FailureInternal String deriving Show instance Exception Failure where - displayException (FailureException err) = displayException err + displayException (FailureException err) = displayException err displayException (FailureDeadlock threads) = concat [ "<>\n" , "please report the issue at\n" - , "https://github.com/input-output-hk/io-sim/issues" + , "https://github.com/intersectmbo/io-sim/issues" ] @@ -486,6 +487,16 @@ ] +-- | Filter `EventSay` and pretty print them. +-- +ppSayTrace :: SimTrace a -> String +ppSayTrace tr = ppEvents + [ a + | a@(_, _, _, EventSay {}) + <- traceEvents tr + ] + + -- | See 'runSimTraceST' below. -- runSimTrace :: forall a. (forall s. IOSim s a) -> SimTrace a @@ -500,7 +511,7 @@ -- /IOSimPOR/ is a different interpreter of 'IOSim' which has the ability to -- discover race conditions and replay the simulation using a schedule which -- reverts them. For extended documentation how to use it see --- [here](https://github.com/input-output-hk/io-sim/blob/main/io-sim/how-to-use-IOSimPOR.md). +-- [here](https://github.com/intersectmbo/io-sim/blob/main/io-sim/how-to-use-IOSimPOR.md). -- -- /IOSimPOR/ only discovers races between events which happen in the same time -- slot. In /IOSim/ and /IOSimPOR/ time only moves explicitly through timer diff --git a/src/Control/Monad/IOSim/Internal.hs b/src/Control/Monad/IOSim/Internal.hs --- a/src/Control/Monad/IOSim/Internal.hs +++ b/src/Control/Monad/IOSim/Internal.hs @@ -56,7 +56,6 @@ import Data.Set qualified as Set import Data.Time (UTCTime (..), fromGregorian) -import Control.DeepSeq (force) import Control.Exception (NonTermination (..), SomeAsyncException, assert, throw) import Control.Monad (join, when) @@ -314,36 +313,14 @@ $ trace Say msg k -> do - mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of - Nothing -> Just e - Just {} -> Nothing) - $ evaluate (force msg) - case mbNF of - Left e -> do - let thread' = thread { threadControl = ThreadControl (Throw e) ctl } - trace <- schedule thread' simstate - return $ SimTrace time tid tlbl (EventSayEvaluationError e) - $ trace - Right msg' -> do - let thread' = thread { threadControl = ThreadControl k ctl } - trace <- schedule thread' simstate - return (SimTrace time tid tlbl (EventSay msg') trace) + let thread' = thread { threadControl = ThreadControl k ctl } + trace <- schedule thread' simstate + return (SimTrace time tid tlbl (EventSay msg) trace) - Output x@(Dynamic _ x') k -> do - mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of - Nothing -> Just e - Just {} -> Nothing) - $ evaluate x' - case mbWHNF of - Left e -> do - let thread' = thread { threadControl = ThreadControl (Throw e) ctl } - trace <- schedule thread' simstate - return $ SimTrace time tid tlbl (EventLogEvaluationError e) - $ trace - Right {} -> do - let thread' = thread { threadControl = ThreadControl k ctl } - trace <- schedule thread' simstate - return (SimTrace time tid tlbl (EventLog x) trace) + Output x k -> do + let thread' = thread { threadControl = ThreadControl k ctl } + trace <- schedule thread' simstate + return (SimTrace time tid tlbl (EventLog x) trace) LiftST st k -> do x <- strictToLazyST st @@ -1125,9 +1102,26 @@ -- Skip the right hand alternative and continue with the k continuation go ctl' read written' writtenSeq' createdSeq' nextVid (k x) - ThrowStm e -> - throwStm ctl read written nextVid e + ThrowStm e -> do + -- Rollback `TVar`s written since catch handler was installed + !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written + case ctl of + AtomicallyFrame -> do + k0 $ StmTxAborted (Map.elems read) (toException e) + BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do + -- Execute the left side in a new frame with an empty written set. + -- but preserve ones that were set prior to it, as specified in the + -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package. + let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl' + go ctl'' read Map.empty [] [] nextVid (h e) + + BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do + go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) + + BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do + go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) + CatchStm a h k -> do -- Execute the catch handler with an empty written set. -- but preserve ones that were set prior to it, as specified in the @@ -1194,32 +1188,12 @@ go ctl read written' (SomeTVar v : writtenSeq) createdSeq nextVid k SayStm msg k -> do - mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of - Nothing -> Just e - Just {} -> Nothing) - $ evaluate (force msg) - case mbNF of - Left e -> do - trace <- throwStm ctl read written nextVid e - return $ SimTrace time tid tlbl (EventSayEvaluationError e) - $ trace - Right msg' -> do - trace <- go ctl read written writtenSeq createdSeq nextVid k - return $ SimTrace time tid tlbl (EventSay msg') trace + trace <- go ctl read written writtenSeq createdSeq nextVid k + return $ SimTrace time tid tlbl (EventSay msg) trace - OutputStm x@(Dynamic _ x') k -> do - mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of - Nothing -> Just e - Just {} -> Nothing) - $ evaluate x' - case mbWHNF of - Left e -> do - trace <- throwStm ctl read written nextVid e - return $ SimTrace time tid tlbl (EventLogEvaluationError e) - $ trace - Right {} -> do - trace <- go ctl read written writtenSeq createdSeq nextVid k - return $ SimTrace time tid tlbl (EventLog x) trace + OutputStm x k -> do + trace <- go ctl read written writtenSeq createdSeq nextVid k + return $ SimTrace time tid tlbl (EventLog x) trace LiftSTStm st k -> do x <- strictToLazyST st @@ -1236,34 +1210,6 @@ localInvariant = Map.keysSet written == Set.fromList [ tvarId tvar | SomeTVar tvar <- writtenSeq ] - - -- throw an exception in an STM transaction - throwStm :: forall b. - StmStack s b a - -> Map TVarId (SomeTVar s) - -> Map TVarId (SomeTVar s) - -> VarId - -> SomeException - -> ST s (SimTrace c) - throwStm ctl read written nextVid e = do - -- Rollback `TVar`s written since catch handler was installed - !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written - case ctl of - AtomicallyFrame -> do - k0 $ StmTxAborted (Map.elems read) (toException e) - - BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do - -- Execute the left side in a new frame with an empty written set. - -- but preserve ones that were set prior to it, as specified in the - -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package. - let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl' - go ctl'' read Map.empty [] [] nextVid (h e) - - BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do - go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) - - BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do - go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) -- | Special case of 'execAtomically' supporting only var reads and writes diff --git a/src/Control/Monad/IOSim/Types.hs b/src/Control/Monad/IOSim/Types.hs --- a/src/Control/Monad/IOSim/Types.hs +++ b/src/Control/Monad/IOSim/Types.hs @@ -145,20 +145,14 @@ -- can then be recovered with `selectTraceEventsDynamic` or -- `selectTraceEventsDynamic'`. -- --- Note: `traceM` evaluates the `a` to `WHNF`, exceptions are thrown by the --- current thread and the trace will include `EventLogEvaluationError`. --- traceM :: Typeable a => a -> IOSim s () -traceM x = IOSim $ oneShot $ \k -> Output (toDyn x) (k ()) +traceM !x = IOSim $ oneShot $ \k -> Output (toDyn x) (k ()) -- | Trace a value, in the same was as `traceM` does, but from the `STM` monad. -- This is primarily useful for debugging. -- --- Note: `traceSTM` evaluates the `a` to `WHNF`, if exception is thrown, the --- trace will end with `TraceException`. --- traceSTM :: Typeable a => a -> STMSim s () -traceSTM x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ()) +traceSTM !x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ()) data Thrower = ThrowSelf | ThrowOther deriving (Ord, Eq, Show) @@ -339,10 +333,6 @@ instance MonadFix (STM s) where mfix f = STM $ oneShot $ \k -> FixStm f k --- | `IOSim s` instance is strict: the string will be evaluated to normal form, --- if an exception is encountered it is thrown in the current thread, and the --- log will contain `EventSayEvaluationError`. --- instance MonadSay (IOSim s) where say msg = IOSim $ oneShot $ \k -> Say msg (k ()) @@ -493,10 +483,6 @@ instance MonadTest (IOSim s) where exploreRaces = IOSim $ oneShot $ \k -> ExploreRaces (k ()) --- | `STM (IOSim s)` instance is strict: the string will be evaluated to normal --- form, if an exception is encountered the trace will finish with --- `TraceException`. --- instance MonadSay (STMSim s) where say msg = STM $ oneShot $ \k -> SayStm msg (k ()) @@ -892,7 +878,7 @@ -- ^ Only returned by /IOSimPOR/ when a step execution took longer than -- 'explorationStepTimelimit` was exceeded. | InternalError String - -- ^ An `IOSim` bug, please report to + -- ^ An `IOSim` bug, please report to deriving (Show, Functor) ppSimResult :: Show a @@ -1056,13 +1042,9 @@ -- data SimEventType = EventSay String - -- ^ holds value of `say` - | EventSayEvaluationError SomeException - -- ^ holds error resulted from evaluation of the expression passed to `say` to NF. + -- ^ hold value of `say` | EventLog Dynamic - -- ^ holds a dynamic value of `Control.Monad.IOSim.traceM` - | EventLogEvaluationError SomeException - -- ^ holds error resulted from evaluation of the expression passed to `traceM` to WHNF. + -- ^ hold a dynamic value of `Control.Monad.IOSim.traceM` | EventMask MaskingState -- ^ masking state changed @@ -1192,9 +1174,7 @@ ppSimEventType :: SimEventType -> String ppSimEventType = \case EventSay a -> "Say " ++ a - EventSayEvaluationError err -> "SayEvaluationError " ++ show err EventLog a -> "Dynamic " ++ show a - EventLogEvaluationError err -> "DynamicEvaluationError " ++ show err EventMask a -> "Mask " ++ show a EventThrow err -> "Throw " ++ unsafeEvaluateString "exception" (show err) EventThrowTo err tid -> diff --git a/src/Control/Monad/IOSimPOR/Internal.hs b/src/Control/Monad/IOSimPOR/Internal.hs --- a/src/Control/Monad/IOSimPOR/Internal.hs +++ b/src/Control/Monad/IOSimPOR/Internal.hs @@ -59,7 +59,6 @@ import Data.Set qualified as Set import Data.Time (UTCTime (..), fromGregorian) -import Control.DeepSeq (force) import Control.Exception (NonTermination (..), SomeAsyncException, assert, throw) import Control.Monad (join, when) @@ -441,36 +440,14 @@ $ trace Say msg k -> do - mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of - Nothing -> Just e - Just {} -> Nothing) - $ evaluate (force msg) - case mbNF of - Left e -> do - let thread' = thread { threadControl = ThreadControl (Throw e) ctl } - trace <- schedule thread' simstate - return $ SimPORTrace time tid tstep tlbl (EventSayEvaluationError e) - $ trace - Right msg' -> do - let thread' = thread { threadControl = ThreadControl k ctl } - trace <- schedule thread' simstate - return (SimPORTrace time tid tstep tlbl (EventSay msg') trace) + let thread' = thread { threadControl = ThreadControl k ctl } + trace <- schedule thread' simstate + return (SimPORTrace time tid tstep tlbl (EventSay msg) trace) - Output x@(Dynamic _ x') k -> do - mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of - Nothing -> Just e - Just {} -> Nothing) - $ evaluate x' - case mbWHNF of - Left e -> do - let thread' = thread { threadControl = ThreadControl (Throw e) ctl } - trace <- schedule thread' simstate - return $ SimPORTrace time tid tstep tlbl (EventLogEvaluationError e) - $ trace - Right {} -> do - let thread' = thread { threadControl = ThreadControl k ctl } - trace <- schedule thread' simstate - return (SimPORTrace time tid tstep tlbl (EventLog x) trace) + Output x k -> do + let thread' = thread { threadControl = ThreadControl k ctl } + trace <- schedule thread' simstate + return (SimPORTrace time tid tstep tlbl (EventLog x) trace) LiftST st k -> do x <- strictToLazyST st @@ -661,7 +638,7 @@ $ SimPORTrace time tid tstep tlbl (EventDeschedule Yield) $ trace - Atomically a k -> execAtomically time tid (labelledThreads threads) tlbl nextVid (runSTM a) $ \res -> + Atomically a k -> execAtomically time tid tlbl nextVid (runSTM a) $ \res -> case res of StmTxCommitted x written read created tvarDynamicTraces tvarStringTraces nextVid' -> do @@ -1410,13 +1387,12 @@ execAtomically :: forall s a c. SI.Time -> IOSimThreadId - -> [Labelled IOSimThreadId] -> Maybe ThreadLabel -> VarId -> StmA s a -> (StmTxResult s a -> ST s (SimTrace c)) -> ST s (SimTrace c) -execAtomically !time !tid threads !tlbl !nextVid0 !action0 !k0 = +execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 = go AtomicallyFrame Map.empty Map.empty [] [] nextVid0 action0 where go :: forall b. @@ -1474,9 +1450,26 @@ -- Skip the orElse right hand and continue with the k continuation go ctl' read written' writtenSeq' createdSeq' nextVid (k x) - ThrowStm e -> - throwStm ctl read written nextVid e + ThrowStm e -> do + -- Revert all the TVar writes + !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written + case ctl of + AtomicallyFrame -> do + k0 $ StmTxAborted (Map.elems read) (toException e) + BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do + -- Execute the left side in a new frame with an empty written set. + -- but preserve ones that were set prior to it, as specified in the + -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package. + let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl' + go ctl'' read Map.empty [] [] nextVid (h e) + + BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do + go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) + + BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do + go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) + CatchStm a h k -> do -- Execute the left side in a new frame with an empty written set let ctl' = BranchFrame (CatchStmA h) k written writtenSeq createdSeq ctl @@ -1543,36 +1536,14 @@ go ctl read written' (SomeTVar v : writtenSeq) createdSeq nextVid k SayStm msg k -> do - mbNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of - Nothing -> Just e - Just {} -> Nothing) - $ evaluate (force msg) - case mbNF of - Left e -> do - trace <- throwStm ctl read written nextVid e - -- TODO: step - return $ SimPORTrace time tid (-1) tlbl (EventSayEvaluationError e) - $ trace - Right msg' -> do - trace <- go ctl read written writtenSeq createdSeq nextVid k - -- TODO: step - return $ SimPORTrace time tid (-1) tlbl (EventSay msg') trace + trace <- go ctl read written writtenSeq createdSeq nextVid k + -- TODO: step + return $ SimPORTrace time tid (-1) tlbl (EventSay msg) trace - OutputStm x@(Dynamic _ x') k -> do - mbWHNF <- unsafeIOToST $ tryJust (\e -> case fromException @SomeAsyncException e of - Nothing -> Just e - Just {} -> Nothing) - $ evaluate x' - case mbWHNF of - Left e -> do - trace <- throwStm ctl read written nextVid e - -- TODO: step - return $ SimPORTrace time tid (-1) tlbl (EventLogEvaluationError e) - $ trace - Right {} -> do - trace <- go ctl read written writtenSeq createdSeq nextVid k - -- TODO: step - return $ SimPORTrace time tid (-1) tlbl (EventLog x) trace + OutputStm x k -> do + trace <- go ctl read written writtenSeq createdSeq nextVid k + -- TODO: step + return $ SimPORTrace time tid (-1) tlbl (EventLog x) trace LiftSTStm st k -> do x <- strictToLazyST st @@ -1590,34 +1561,6 @@ Map.keysSet written == Set.fromList ([ tvarId tvar | SomeTVar tvar <- writtenSeq ] ++ [ tvarId tvar | SomeTVar tvar <- createdSeq ]) - - -- throw an exception in an STM transaction - throwStm :: forall b. - StmStack s b a - -> Map TVarId (SomeTVar s) - -> Map TVarId (SomeTVar s) - -> VarId - -> SomeException - -> ST s (SimTrace c) - throwStm ctl read written nextVid e = do - -- Revert all the TVar writes - !_ <- traverse_ (\(SomeTVar tvar) -> revertTVar tvar) written - case ctl of - AtomicallyFrame -> do - k0 $ StmTxAborted (Map.elems read) (toException e) - - BranchFrame (CatchStmA h) k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do - -- Execute the left side in a new frame with an empty written set. - -- but preserve ones that were set prior to it, as specified in the - -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package. - let ctl'' = BranchFrame NoOpStmA k writtenOuter writtenOuterSeq createdOuterSeq ctl' - go ctl'' read Map.empty [] [] nextVid (h e) - - BranchFrame (OrElseStmA _r) _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do - go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) - - BranchFrame NoOpStmA _k writtenOuter writtenOuterSeq createdOuterSeq ctl' -> do - go ctl' read writtenOuter writtenOuterSeq createdOuterSeq nextVid (ThrowStm e) -- | Special case of 'execAtomically' supporting only var reads and writes diff --git a/test/Test/Control/Monad/IOSim.hs b/test/Test/Control/Monad/IOSim.hs --- a/test/Test/Control/Monad/IOSim.hs +++ b/test/Test/Control/Monad/IOSim.hs @@ -17,10 +17,8 @@ , TimeoutDuration , ActionDuration , singleTimeoutExperiment - , TraceBottom (..) ) where -import Data.Bifoldable (bifoldMap) import Data.Either (isLeft) import Data.Fixed (Micro) #if __GLASGOW_HASKELL__ < 910 @@ -29,7 +27,7 @@ import Data.Functor (($>)) import Data.Time.Clock (picosecondsToDiffTime) -import Control.Exception (ArithException (..), AsyncException, ErrorCall (..)) +import Control.Exception (ArithException (..), AsyncException) import Control.Monad import Control.Monad.Fix import System.IO.Error (ioeGetErrorString, isUserError) @@ -72,12 +70,6 @@ , testProperty "threadDelay and STM" unit_threadDelay_and_stm , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay , testProperty "throwTo and STM" unit_throwTo_and_stm - , testGroup "trace bottom" - [ testProperty "say" unit_trace_bottom_say - , testProperty "dynamic" unit_trace_bottom_dynamic - , testProperty "saySTM" unit_trace_bottom_saySTM - , testProperty "dynamicSTM" unit_trace_bottom_dynamicSTM - ] ] , testGroup "QuickCheck" [ testProperty "timeout: discardAfter" unit_discardAfter @@ -1286,54 +1278,6 @@ t1 <- getMonotonicTime return (t1 `diffTime` t0 === delay) - - -data TraceBottom = TraceBottomSay - | TraceBottomDynamic - | TraceBottomSaySTM - | TraceBottomDynamicSTM - -prop_trace_bottom :: TraceBottom -> Property -prop_trace_bottom tb = - let trace = runSimTrace sim in - property $ - bifoldMap - (\_ -> Some False) - (\ev -> - case seType ev of - EventSayEvaluationError e - | Just ErrorCall{} <- fromException e - -> Some True - EventLogEvaluationError e - | Just ErrorCall{} <- fromException e - -> Some True - _ -> Some False - ) - trace - where - sim :: IOSim s () - sim = case tb of - TraceBottomSay -> - say (error "bottom") - TraceBottomDynamic -> - traceM (error "bottom" :: String) - TraceBottomSaySTM -> - atomically $ say (error "bottom") - TraceBottomDynamicSTM -> - atomically $ traceSTM (error "bottom" :: String) - -unit_trace_bottom_say :: Property -unit_trace_bottom_say = once (prop_trace_bottom TraceBottomSay) - -unit_trace_bottom_dynamic :: Property -unit_trace_bottom_dynamic = once (prop_trace_bottom TraceBottomDynamic) - -unit_trace_bottom_saySTM :: Property -unit_trace_bottom_saySTM = once (prop_trace_bottom TraceBottomSaySTM) - -unit_trace_bottom_dynamicSTM :: Property -unit_trace_bottom_dynamicSTM = once (prop_trace_bottom TraceBottomDynamicSTM) - -- -- MonadMask properties diff --git a/test/Test/Control/Monad/IOSimPOR.hs b/test/Test/Control/Monad/IOSimPOR.hs --- a/test/Test/Control/Monad/IOSimPOR.hs +++ b/test/Test/Control/Monad/IOSimPOR.hs @@ -6,7 +6,6 @@ module Test.Control.Monad.IOSimPOR (tests) where -import Data.Bifoldable (bifoldMap) import Data.Fixed (Micro) #if __GLASGOW_HASKELL__ >= 910 import Data.Foldable (traverse_) @@ -21,7 +20,7 @@ import System.Exit import System.IO.Error (ioeGetErrorString, isUserError) -import Control.Exception (ArithException (..), AsyncException, ErrorCall (..)) +import Control.Exception (ArithException (..), AsyncException) import Control.Monad import Control.Monad.Fix @@ -38,8 +37,8 @@ import GHC.Generics import Test.Control.Monad.IOSim (ActionDuration, TimeoutDuration, - TraceBottom (..), WithSanityCheck (..), ignoreSanityCheck, - isSanityCheckIgnored, singleTimeoutExperiment, withSanityCheck) + WithSanityCheck (..), ignoreSanityCheck, isSanityCheckIgnored, + singleTimeoutExperiment, withSanityCheck) import Test.Control.Monad.STM import Test.Control.Monad.Utils @@ -78,12 +77,6 @@ , testProperty "timeouts" prop_timeouts , testProperty "stacked timeouts" prop_stacked_timeouts , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay - , testGroup "trace bottom" - [ testProperty "say" unit_trace_bottom_say - , testProperty "dynamic" unit_trace_bottom_dynamic - , testProperty "saySTM" unit_trace_bottom_saySTM - , testProperty "dynamicSTM" unit_trace_bottom_dynamicSTM - ] ] , testProperty "infinite simulation" prop_explore_endless_simulation , testProperty "threadId order (IOSim)" (withNumTests 1000 prop_threadId_order_order_Sim) @@ -1090,49 +1083,6 @@ t1 <- getMonotonicTime return (t1 `diffTime` t0 === delay) - - -prop_trace_bottom :: TraceBottom -> Property -prop_trace_bottom tb = - exploreSimTrace id sim $ \_ trace -> - property $ - bifoldMap - (\_ -> Some False) - (\ev -> - case seType ev of - EventSayEvaluationError e - | Just ErrorCall{} <- fromException e - -> Some True - EventLogEvaluationError e - | Just ErrorCall{} <- fromException e - -> Some True - _ -> Some False - ) - trace - where - sim :: IOSim s () - sim = case tb of - TraceBottomSay -> - say (error "bottom") - TraceBottomDynamic -> - traceM (error "bottom" :: String) - TraceBottomSaySTM -> - atomically $ say (error "bottom") - TraceBottomDynamicSTM -> - atomically $ traceSTM (error "bottom" :: String) - -unit_trace_bottom_say :: Property -unit_trace_bottom_say = once (prop_trace_bottom TraceBottomSay) - -unit_trace_bottom_dynamic :: Property -unit_trace_bottom_dynamic = once (prop_trace_bottom TraceBottomDynamic) - -unit_trace_bottom_saySTM :: Property -unit_trace_bottom_saySTM = once (prop_trace_bottom TraceBottomSaySTM) - -unit_trace_bottom_dynamicSTM :: Property -unit_trace_bottom_dynamicSTM = once (prop_trace_bottom TraceBottomDynamicSTM) - unit_timeouts_and_async_exceptions_1 :: Property unit_timeouts_and_async_exceptions_1 =