io-sim 1.10.1.0 → 1.11.0.0
raw patch · 10 files changed
+116/−326 lines, 10 filesdep ~io-classes
Dependency ranges changed: io-classes
Files
- CHANGELOG.md +16/−0
- NOTICE +1/−1
- README.md +3/−3
- io-sim.cabal +6/−6
- src/Control/Monad/IOSim.hs +15/−4
- src/Control/Monad/IOSim/Internal.hs +31/−85
- src/Control/Monad/IOSim/Types.hs +5/−25
- src/Control/Monad/IOSimPOR/Internal.hs +35/−92
- test/Test/Control/Monad/IOSim.hs +1/−57
- test/Test/Control/Monad/IOSimPOR.hs +3/−53
CHANGELOG.md view
@@ -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
NOTICE view
@@ -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.
README.md view
@@ -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
io-sim.cabal view
@@ -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,
src/Control/Monad/IOSim.hs view
@@ -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- -- <https://github.com/input-output-hk/io-sim/issues>.+ -- <https://github.com/intersectmbo/io-sim/issues>. | FailureInternal String deriving Show instance Exception Failure where- displayException (FailureException err) = displayException err+ displayException (FailureException err) = displayException err displayException (FailureDeadlock threads) = concat [ "<<io-sim deadlock: " , intercalate ", " (show `map` threads)@@ -387,7 +388,7 @@ , msg , ">>\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
src/Control/Monad/IOSim/Internal.hs view
@@ -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
src/Control/Monad/IOSim/Types.hs view
@@ -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 <https://github.com/input-output-hk/io-sim>+ -- ^ An `IOSim` bug, please report to <https://github.com/intersectmbo/io-sim> 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 ->
src/Control/Monad/IOSimPOR/Internal.hs view
@@ -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
test/Test/Control/Monad/IOSim.hs view
@@ -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
test/Test/Control/Monad/IOSimPOR.hs view
@@ -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 =