io-sim 1.3.1.0 → 1.4.0.0
raw patch · 23 files changed
+457/−408 lines, 23 filesdep ~basedep ~io-classesdep ~si-timersPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, io-classes, si-timers, strict-stm
API changes (from Hackage documentation)
- Control.Monad.IOSim: EventTimerUpdated :: TimeoutId -> Time -> SimEventType
Files
- CHANGELOG.md +6/−1
- NOTICE +1/−1
- README.md +11/−9
- bench/Main.hs +11/−12
- io-sim.cabal +10/−7
- src/Control/Monad/IOSim.hs +57/−61
- src/Control/Monad/IOSim/CommonTypes.hs +11/−11
- src/Control/Monad/IOSim/Internal.hs +38/−38
- src/Control/Monad/IOSim/InternalTypes.hs +6/−5
- src/Control/Monad/IOSim/STM.hs +12/−10
- src/Control/Monad/IOSim/Types.hs +93/−81
- src/Control/Monad/IOSimPOR/Internal.hs +34/−36
- src/Control/Monad/IOSimPOR/QuickCheckUtils.hs +3/−3
- src/Control/Monad/IOSimPOR/Timeout.hs +7/−8
- src/Control/Monad/IOSimPOR/Types.hs +4/−4
- src/Data/Deque/Strict.hs +3/−3
- src/Data/List/Trace.hs +8/−8
- test/Main.hs +4/−4
- test/Test/Control/Concurrent/Class/MonadMVar.hs +15/−15
- test/Test/Control/Monad/IOSim.hs +61/−28
- test/Test/Control/Monad/IOSimPOR.hs +38/−39
- test/Test/Control/Monad/STM.hs +11/−11
- test/Test/Control/Monad/Utils.hs +13/−13
CHANGELOG.md view
@@ -1,10 +1,15 @@ # Revsion history of io-sim -## next release+## 1.4.0.0 ### Breaking changes +* Removed `EventTimerUpdated` constructor (not used anymore).+ ### Non-breaking changes++* `Alternative` & `MonadPlus` instances for `IOSim`.+* Fixed `flushTQueue` implemetation. ## 1.3.1.0
NOTICE view
@@ -1,4 +1,4 @@-Copyright 2019-2023 Input Output Global Inc (IOG)+Copyright 2019-2024 Input Output Global Inc (IOG) 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
@@ -1,4 +1,4 @@-# IOSim - IO Simulator Monad+# [IO Simulator Monad][`io-sim`] A pure simulator monad built on top of the lazy `ST` monad which supports: @@ -14,22 +14,22 @@ * lifting any `ST` computations; * inspection of `STM` mutable data structures; * deadlock detection;- * `MonadFix` instances for both `IOSim` and its corresponding `STM` monad.- * partial order reduction (see [IOSimPOR]).+ * `MonadFix` instances for both [`IOSim`] and its corresponding `STM` monad.+ * partial order reduction (see [`IOSimPOR`]). -`io-sim` together with [`io-classes`] is a drop-in replacement for the `IO`+[`io-sim`] together with [`io-classes`] is a drop-in replacement for the `IO` monad (with some ramifications). It was designed to write easily testable Haskell code (including simulating socket programming or disk IO). Using [`io-classes`] and [`si-timers`] libraries one can write code that can run in-both: the real `IO` and the `IOSim` monad provided by this package. One of the+both: the real `IO` and the [`IOSim`] monad provided by this package. One of the design goals was to keep the API as close as possible to `base`, `exceptions`, `async`, and `stm` packages. -`io-sim` package also provides two interpreters, a standard one and `IOSimPOR`-which supports dynamic discovery or race conditions and schedule exploration+[`io-sim`] package also provides two interpreters, a standard one and [`IOSimPOR`]+which supports dynamic discovery of race conditions and schedule exploration with partial order reduction. -`io-sim` provides API to explore traces produced by a simulation. It can+[`io-sim`] provides API to explore traces produced by a simulation. It can contain arbitrary Haskell terms, a feature that is very useful to build property-based tests using `QuickCheck`. @@ -41,6 +41,8 @@ also the other way around: that `GHC`s `STM` implementation meets the specification. +[`io-sim`]: https://hackage.haskell.org/package/io-sim [`io-classes`]: https://hackage.haskell.org/package/io-classes [`si-timers`]: https://hackage.haskell.org/package/si-timers-[IOSimPOR]: https://github.com/input-output-hk/io-sim/tree/main/io-sim/how-to-use-IOSimPOR.md+[`IOSimPOR`]: https://github.com/input-output-hk/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
bench/Main.hs view
@@ -1,21 +1,20 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Main (main) where -import Control.Concurrent.Class.MonadSTM-import Control.Monad (forever, replicateM)-import Control.Monad.Class.MonadAsync-import Control.Monad.Class.MonadFork-import Control.Monad.Class.MonadSay-import Control.Monad.Class.MonadTimer-import Control.Monad.IOSim+import Control.Concurrent.Class.MonadSTM+import Control.Monad (forever, replicateM)+import Control.Monad.Class.MonadAsync+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadSay+import Control.Monad.Class.MonadTimer+import Control.Monad.IOSim -import Criterion-import Criterion.Main+import Criterion+import Criterion.Main -import Control.Exception (AsyncException (..))-import Data.Foldable (traverse_)+import Control.Exception (AsyncException (..))+import Data.Foldable (traverse_) --
io-sim.cabal view
@@ -1,14 +1,14 @@ cabal-version: 3.0 name: io-sim-version: 1.3.1.0+version: 1.4.0.0 synopsis: A pure simulator for monadic concurrency with STM. description:- A pure simulator monad with support of concurency (base, async), stm,+ A pure simulator monad with support of concurency (base & async style), stm, synchronous and asynchronous exceptions, timeouts & delays, dynamic traces,- and more.+ partial order reduction and more. license: Apache-2.0 license-files: LICENSE NOTICE-copyright: 2022-2023 Input Output Global Inc (IOG)+copyright: 2022-2024 Input Output Global Inc (IOG) author: Alexander Vieth, Duncan Coutts, John Hughes, Marcin Szamotulski maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Testing@@ -57,6 +57,7 @@ Control.Monad.IOSimPOR.Timeout, Data.Deque.Strict default-language: Haskell2010+ default-extensions: ImportQualifiedPost other-extensions: BangPatterns, CPP, DeriveFunctor,@@ -75,14 +76,14 @@ ScopedTypeVariables, TypeFamilies build-depends: base >=4.9 && <4.20,- io-classes ^>=1.3,+ io-classes >=1.3 && <1.5, exceptions >=0.10, containers, deepseq, nothunks, psqueues >=0.2 && <0.3,- strict-stm ^>=1.3,- si-timers ^>=1.3,+ strict-stm ^>=1.4,+ si-timers ^>=1.4, time >=1.9.1 && <1.13, quiet, QuickCheck,@@ -102,6 +103,7 @@ Test.Control.Monad.IOSim Test.Control.Monad.IOSimPOR default-language: Haskell2010+ default-extensions: ImportQualifiedPost build-depends: base, array, containers,@@ -125,6 +127,7 @@ hs-source-dirs: bench main-is: Main.hs default-language: Haskell2010+ default-extensions: ImportQualifiedPost build-depends: base, criterion,
src/Control/Monad/IOSim.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -43,16 +43,7 @@ , unshareClock -- * Simulation trace , type SimTrace- , Trace (Cons,- Nil,- SimTrace,- SimPORTrace,- TraceDeadlock,- TraceLoop,- TraceMainReturn,- TraceMainException,- TraceRacesFound,- TraceInternalError)+ , Trace (Cons, Nil, SimTrace, SimPORTrace, TraceDeadlock, TraceLoop, TraceMainReturn, TraceMainException, TraceRacesFound, TraceInternalError) , SimResult (..) , SimEvent (..) , SimEventType (..)@@ -100,39 +91,42 @@ , awaitTimeout ) where -import Prelude+import Prelude -import Data.Bifoldable-import Data.Bifunctor (first)-import Data.Dynamic (fromDynamic)-import Data.Functor (void)-import Data.List (intercalate)-import Data.Maybe (catMaybes)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Typeable (Typeable)+import Data.Bifoldable+import Data.Bifunctor (first)+import Data.Dynamic (fromDynamic)+import Data.Functor (void)+import Data.List (intercalate)+import Data.Maybe (catMaybes)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Typeable (Typeable) -import Data.List.Trace (Trace (..))-import qualified Data.List.Trace as Trace+import Data.List.Trace (Trace (..))+import Data.List.Trace qualified as Trace -import Control.Exception (throw)+import Control.Exception (throw) -import Control.Monad.ST.Lazy-import Data.STRef.Lazy+import Control.Monad.ST.Lazy+import Data.STRef.Lazy -import Control.Monad.Class.MonadThrow as MonadThrow+import Control.Monad.Class.MonadThrow as MonadThrow -import Control.Monad.IOSim.Internal (runSimTraceST)-import Control.Monad.IOSim.Types-import qualified Control.Monad.IOSimPOR.Internal as IOSimPOR (controlSimTraceST)-import Control.Monad.IOSimPOR.QuickCheckUtils+import Control.Monad.IOSim.Internal (runSimTraceST)+import Control.Monad.IOSim.Types+import Control.Monad.IOSimPOR.Internal qualified as IOSimPOR (controlSimTraceST)+import Control.Monad.IOSimPOR.QuickCheckUtils -import Test.QuickCheck+import Test.QuickCheck -import System.IO.Unsafe-import qualified Debug.Trace as Debug+import Debug.Trace qualified as Debug+import System.IO.Unsafe +-- | Select events according to the predicate function. It throws an error if+-- the simulation ends with 'Failure'.+-- selectTraceEvents :: (Time -> SimEventType -> Maybe b) -> SimTrace a@@ -150,6 +144,9 @@ [] . traceSelectTraceEvents fn +-- | Like 'selectTraceEvents', but it returns even if the simulation trace ends+-- with 'Failure'.+-- selectTraceEvents' :: (Time -> SimEventType -> Maybe b) -> SimTrace a@@ -216,10 +213,10 @@ SimRacesFound {} -> False _ -> True) --- | Select all the traced values matching the expected type. This relies on--- the sim's dynamic trace facility.+-- | Select all the traced values matching the expected type. It relies on the+-- sim's dynamic trace facility. ----- For convenience, this throws exceptions for abnormal sim termination.+-- For convenience, it throws exceptions for abnormal sim termination. -- selectTraceEventsDynamic :: forall a b. Typeable b => SimTrace a -> [b] selectTraceEventsDynamic = selectTraceEvents fn@@ -228,7 +225,8 @@ fn _ (EventLog dyn) = fromDynamic dyn fn _ _ = Nothing --- | Like 'selectTraceEventsDynamic' but also captures time of the trace event.+-- | Like 'selectTraceEventsDynamic' but it also captures time of the trace+-- event. -- selectTraceEventsDynamicWithTime :: forall a b. Typeable b => SimTrace a -> [(Time, b)] selectTraceEventsDynamicWithTime = selectTraceEvents fn@@ -237,8 +235,8 @@ fn t (EventLog dyn) = (t,) <$> fromDynamic dyn fn _ _ = Nothing --- | Like 'selectTraceEventsDynamic' but returns partial trace if an exception--- is found in it.+-- | Like 'selectTraceEventsDynamic' but it returns even if the simulation trace+-- ends with 'Failure'. -- selectTraceEventsDynamic' :: forall a b. Typeable b => SimTrace a -> [b] selectTraceEventsDynamic' = selectTraceEvents' fn@@ -247,7 +245,8 @@ fn _ (EventLog dyn) = fromDynamic dyn fn _ _ = Nothing --- | Like `selectTraceEventsDynamic'` but also captures time of the trace event.+-- | Like `selectTraceEventsDynamic'` but it also captures time of the trace+-- event. -- selectTraceEventsDynamicWithTime' :: forall a b. Typeable b => SimTrace a -> [(Time, b)] selectTraceEventsDynamicWithTime' = selectTraceEvents' fn@@ -258,7 +257,7 @@ -- | Get a trace of 'EventSay'. ----- For convenience, this throws exceptions for abnormal sim termination.+-- For convenience, it throws exceptions for abnormal sim termination. -- selectTraceEventsSay :: SimTrace a -> [String] selectTraceEventsSay = selectTraceEvents fn@@ -267,7 +266,7 @@ fn _ (EventSay s) = Just s fn _ _ = Nothing --- | Like 'selectTraceEventsSay' but also captures time of the trace event.+-- | Like 'selectTraceEventsSay' but it also captures time of the trace event. -- selectTraceEventsSayWithTime :: SimTrace a -> [(Time, String)] selectTraceEventsSayWithTime = selectTraceEvents fn@@ -276,8 +275,8 @@ fn t (EventSay s) = Just (t, s) fn _ _ = Nothing --- | Like 'selectTraceEventsSay' but return partial trace if an exception is--- found in it.+-- | Like 'selectTraceEventsSay' but it returns even if the simulation trace+-- ends with 'Failure'. -- selectTraceEventsSay' :: SimTrace a -> [String] selectTraceEventsSay' = selectTraceEvents' fn@@ -286,7 +285,7 @@ fn _ (EventSay s) = Just s fn _ _ = Nothing --- | Like `selectTraceEventsSay'` but also captures time of the trace event.+-- | Like `selectTraceEventsSay'` but it also captures time of the trace event. -- selectTraceEventsSayWithTime' :: SimTrace a -> [(Time, String)] selectTraceEventsSayWithTime' = selectTraceEvents' fn@@ -297,13 +296,13 @@ -- | Print all 'EventSay' to the console. ----- For convenience, this throws exceptions for abnormal sim termination.+-- For convenience, it throws exceptions for abnormal sim termination. -- printTraceEventsSay :: SimTrace a -> IO () printTraceEventsSay = mapM_ print . selectTraceEventsSay --- | The most general select function. It is a _total_ function.+-- | The most general select function. It is a /total function/. -- traceSelectTraceEvents :: (Time -> SimEventType -> Maybe b)@@ -324,7 +323,7 @@ ) undefined -- it is ignored --- | Select dynamic events. It is a _total_ function.+-- | Select dynamic events. It is a /total function/. -- traceSelectTraceEventsDynamic :: forall a b. Typeable b => SimTrace a -> Trace (SimResult a) b@@ -335,7 +334,7 @@ fn _ _ = Nothing --- | Select say events. It is a _total_ function.+-- | Select say events. It is a /total function/. -- traceSelectTraceEventsSay :: forall a. SimTrace a -> Trace (SimResult a) String traceSelectTraceEventsSay = traceSelectTraceEvents fn@@ -394,8 +393,8 @@ , "please report the issue at\n" , "https://github.com/input-output-hk/io-sim/issues" ]- + -- | 'IOSim' is a pure monad. -- runSim :: forall a. (forall s. IOSim s a) -> Either Failure a@@ -417,7 +416,7 @@ runSimStrictShutdown :: forall a. (forall s. IOSim s a) -> Either Failure a runSimStrictShutdown mainAction = traceResult True (runSimTrace mainAction) --- | Fold through the trace and return either a 'Failure' or the simulation+-- | Fold through the trace and return either 'Failure' or a simulation -- result, i.e. the return value of the main thread. -- traceResult :: Bool@@ -502,19 +501,18 @@ -- slot. In /IOSim/ and /IOSimPOR/ time only moves explicitly through timer -- events, e.g. things like `Control.Monad.Class.MonadTimer.SI.threadDelay`, -- `Control.Monad.Class.MonadTimer.SI.registerDelay` or the--- `Control.Monad.Class.MonadTimer.NonStandard.MonadTimeout` API. The usual+-- `Control.Monad.Class.MonadTimer.MonadTimeout.NonStandard` API. The usual -- QuickCheck techniques can help explore different schedules of -- threads too. -- | Execute a simulation, discover & revert races. Note that this will execute -- the simulation multiple times with different schedules, and thus it's much -- more costly than a simple `runSimTrace` (also the simulation environments has--- much more state to track and hence is slower).+-- much more state to track and hence it is slower). -- -- On property failure it will show the failing schedule (`ScheduleControl`)--- which can be plugged to `controlSimTrace`.------ Note: `exploreSimTrace` evaluates each schedule in parallel (using `par`).+-- which can be passed to `controlSimTrace` to reproduce the failure without+-- discovering the schedule. -- exploreSimTrace :: forall a test. Testable test@@ -533,8 +531,6 @@ -- | An 'ST' version of 'exploreSimTrace'. The callback also receives -- 'ScheduleControl'. This is mostly useful for testing /IOSimPOR/ itself. ----- Note: `exploreSimTraceST` evaluates each schedule sequentially.--- exploreSimTraceST :: forall s a test. Testable test => (ExplorationOptions -> ExplorationOptions)@@ -689,7 +685,7 @@ raceReversals (ControlAwait mods) = length mods raceReversals ControlFollow{} = error "Impossible: raceReversals ControlFollow{}" --- compareTraces is given (maybe) a passing trace and a failing trace,+-- `compareTracesST` is given (maybe) a passing trace and a failing trace, -- and identifies the point at which they diverge, where it inserts a -- "sleep" event for the thread that is delayed in the failing case, -- and a "wake" event before its next action. It also returns the@@ -697,7 +693,7 @@ -- to be consumed lazily (and perhaps only partially), and since the -- sleeping thread is not of interest unless the trace is consumed -- this far, then we collect its identity only if it is reached using--- unsafePerformIO.+-- `unsafePerformIO`. -- TODO: return StepId compareTracesST :: forall a b s.
src/Control/Monad/IOSim/CommonTypes.hs view
@@ -32,19 +32,19 @@ , ppList ) where -import Control.DeepSeq (NFData (..))-import Control.Monad.Class.MonadSTM (TraceValue)-import Control.Monad.ST.Lazy+import Control.DeepSeq (NFData (..))+import Control.Monad.Class.MonadSTM (TraceValue)+import Control.Monad.ST.Lazy -import NoThunks.Class+import NoThunks.Class -import Data.List (intercalate, intersperse)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.STRef.Lazy-import Data.Set (Set)-import GHC.Generics-import Quiet+import Data.List (intercalate, intersperse)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Set (Set)+import Data.STRef.Lazy+import GHC.Generics+import Quiet -- | A thread id.
src/Control/Monad/IOSim/Internal.hs view
@@ -46,42 +46,42 @@ , execReadTVar ) where -import Prelude hiding (read)+import Prelude hiding (read) -import Data.Dynamic-import Data.Foldable (foldlM, toList, traverse_)-import qualified Data.List as List-import qualified Data.List.Trace as Trace-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Maybe (mapMaybe)-import Data.OrdPSQ (OrdPSQ)-import qualified Data.OrdPSQ as PSQ-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Time (UTCTime (..), fromGregorian)-import Data.Deque.Strict (Deque)-import qualified Data.Deque.Strict as Deque+import Data.Deque.Strict (Deque)+import Data.Deque.Strict qualified as Deque+import Data.Dynamic+import Data.Foldable (foldlM, toList, traverse_)+import Data.List qualified as List+import Data.List.Trace qualified as Trace+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.OrdPSQ (OrdPSQ)+import Data.OrdPSQ qualified as PSQ+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Time (UTCTime (..), fromGregorian) -import Control.Exception (NonTermination (..), assert, throw)-import Control.Monad (join, when)-import Control.Monad.ST.Lazy-import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)-import Data.STRef.Lazy+import Control.Exception (NonTermination (..), assert, throw)+import Control.Monad (join, when)+import Control.Monad.ST.Lazy+import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)+import Data.STRef.Lazy -import Control.Concurrent.Class.MonadSTM.TMVar-import Control.Concurrent.Class.MonadSTM.TVar hiding (TVar)-import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)-import Control.Monad.Class.MonadSTM hiding (STM)-import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))-import Control.Monad.Class.MonadThrow hiding (getMaskingState)-import Control.Monad.Class.MonadTime-import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))+import Control.Concurrent.Class.MonadSTM.TMVar+import Control.Concurrent.Class.MonadSTM.TVar hiding (TVar)+import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)+import Control.Monad.Class.MonadSTM hiding (STM)+import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))+import Control.Monad.Class.MonadThrow hiding (getMaskingState)+import Control.Monad.Class.MonadTime+import Control.Monad.Class.MonadTimer.SI (TimeoutState (..)) -import Control.Monad.IOSim.InternalTypes-import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent),- Trace (SimPORTrace))-import Control.Monad.IOSim.Types (SimEvent)+import Control.Monad.IOSim.InternalTypes+import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent),+ Trace (SimPORTrace))+import Control.Monad.IOSim.Types (SimEvent) -- -- Simulation interpreter@@ -861,9 +861,9 @@ where -- we launch a thread responsible for throwing an AsyncCancelled exception -- to the thread which timeout expired- throwToThread :: [(Thread s a, TMVar (IOSim s) IOSimThreadId)] + throwToThread :: [(Thread s a, TMVar (IOSim s) IOSimThreadId)] - (simState', throwToThread) = List.mapAccumR fn simState timeoutExpired + (simState', throwToThread) = List.mapAccumR fn simState timeoutExpired where fn :: SimState s a -> (IOSimThreadId, TimeoutId, TMVar (IOSim s) IOSimThreadId)@@ -991,10 +991,10 @@ lookupThreadLabel tid threads = join (threadLabel <$> Map.lookup tid threads) --- | The most general method of running 'IOSim' is in 'ST' monad. One can--- recover failures or the result from 'SimTrace' with--- 'Control.Monad.IOSim.traceResult', or access 'SimEventType's generated by the--- computation with 'Control.Monad.IOSim.traceEvents'. A slightly more+-- | The most general method of running 'IOSim' is in the lazy 'ST' monad. One+-- can recover failures or the result from 'SimTrace' with+-- 'Control.Monad.IOSim.traceResult', or access 'SimEventType's generated by+-- the computation with 'Control.Monad.IOSim.traceEvents'. A slightly more -- convenient way is exposed by 'Control.Monad.IOSim.runSimTrace'. -- runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a)
src/Control/Monad/IOSim/InternalTypes.hs view
@@ -11,13 +11,14 @@ , unsafeUnregisterTimeout ) where -import Control.Exception (Exception)-import Control.Concurrent.Class.MonadSTM-import Control.Monad.Class.MonadThrow (MaskingState (..))+import Control.Concurrent.Class.MonadSTM+import Control.Exception (Exception)+import Control.Monad.Class.MonadThrow (MaskingState (..)) -import Control.Monad.IOSim.Types (IOSim (..), SimA (..), IOSimThreadId, TimeoutId)+import Control.Monad.IOSim.Types (IOSim (..), IOSimThreadId, SimA (..),+ TimeoutId) -import GHC.Exts (oneShot)+import GHC.Exts (oneShot) -- We hide the type @b@ here, so it's useful to bundle these two parts together, -- rather than having Thread have an existential type, which makes record
src/Control/Monad/IOSim/STM.hs view
@@ -11,18 +11,17 @@ -- module Control.Monad.IOSim.STM where -import Control.Exception (SomeAsyncException (..))+import Control.Exception (SomeAsyncException (..)) -import Control.Concurrent.Class.MonadSTM.TVar-import Control.Monad.Class.MonadSTM (MonadInspectSTM (..),- MonadLabelledSTM, MonadSTM (..), MonadTraceSTM,- TraceValue (..))-import Control.Monad.Class.MonadThrow+import Control.Concurrent.Class.MonadSTM.TVar+import Control.Monad.Class.MonadSTM (MonadInspectSTM (..), MonadLabelledSTM,+ MonadSTM (..), MonadTraceSTM, TraceValue (..))+import Control.Monad.Class.MonadThrow -import Numeric.Natural (Natural)+import Numeric.Natural (Natural) -import Data.Deque.Strict (Deque)-import qualified Data.Deque.Strict as Deque+import Data.Deque.Strict (Deque)+import Data.Deque.Strict qualified as Deque -- -- Default TQueue implementation in terms of a 'TVar' (used by sim)@@ -96,7 +95,10 @@ [] -> Nothing flushTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m [a]-flushTQueueDefault (TQueue queue) = uncurry (++) <$> readTVar queue+flushTQueueDefault (TQueue queue) = do+ (xs, ys) <- readTVar queue+ writeTVar queue ([], [])+ pure (xs <> reverse ys) unGetTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m () unGetTQueueDefault (TQueue queue) a = do
src/Control/Monad/IOSim/Types.hs view
@@ -1,18 +1,19 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTSyntax #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NumericUnderscores #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} -- Needed for `SimEvent` type. {-# OPTIONS_GHC -Wno-partial-fields #-}@@ -73,69 +74,69 @@ , execReadTVar ) where -import Control.Applicative-import Control.Exception (ErrorCall (..), asyncExceptionFromException,- asyncExceptionToException)-import Control.Monad-import Control.Monad.Fix (MonadFix (..))+import Control.Applicative+import Control.Exception (ErrorCall (..), asyncExceptionFromException,+ asyncExceptionToException)+import Control.Monad+import Control.Monad.Fix (MonadFix (..)) -import Control.Concurrent.Class.MonadMVar-import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar)-import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as StrictTVar-import Control.Monad.Class.MonadAsync hiding (Async)-import qualified Control.Monad.Class.MonadAsync as MonadAsync-import Control.Monad.Class.MonadEventlog-import Control.Monad.Class.MonadFork-import Control.Monad.Class.MonadST-import Control.Monad.Class.MonadSTM.Internal (MonadInspectSTM (..),- MonadLabelledSTM (..), MonadSTM, MonadTraceSTM (..),- TArrayDefault, TChanDefault, TMVarDefault, TSemDefault,- TraceValue, atomically, retry)-import qualified Control.Monad.Class.MonadSTM.Internal as MonadSTM-import Control.Monad.Class.MonadSay-import Control.Monad.Class.MonadTest-import Control.Monad.Class.MonadThrow as MonadThrow hiding- (getMaskingState)-import qualified Control.Monad.Class.MonadThrow as MonadThrow-import Control.Monad.Class.MonadTime-import Control.Monad.Class.MonadTime.SI-import Control.Monad.Class.MonadTimer-import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))-import qualified Control.Monad.Class.MonadTimer.SI as SI-import Control.Monad.ST.Lazy-import qualified Control.Monad.ST.Strict as StrictST-import Control.Monad.ST.Unsafe (unsafeSTToIO)+import Control.Concurrent.Class.MonadMVar+import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar)+import Control.Concurrent.Class.MonadSTM.Strict.TVar qualified as StrictTVar+import Control.Monad.Class.MonadAsync hiding (Async)+import Control.Monad.Class.MonadAsync qualified as MonadAsync+import Control.Monad.Class.MonadEventlog+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadSay+import Control.Monad.Class.MonadST+import Control.Monad.Class.MonadSTM.Internal (MonadInspectSTM (..),+ MonadLabelledSTM (..), MonadSTM, MonadTraceSTM (..), TArrayDefault,+ TChanDefault, TMVarDefault, TSemDefault, TraceValue, atomically,+ retry)+import Control.Monad.Class.MonadSTM.Internal qualified as MonadSTM+import Control.Monad.Class.MonadTest+import Control.Monad.Class.MonadThrow as MonadThrow hiding (getMaskingState)+import Control.Monad.Class.MonadThrow qualified as MonadThrow+import Control.Monad.Class.MonadTime+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer+import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))+import Control.Monad.Class.MonadTimer.SI qualified as SI+import Control.Monad.ST.Lazy+import Control.Monad.ST.Strict qualified as StrictST+import Control.Monad.ST.Unsafe (unsafeSTToIO) -import qualified Control.Monad.Catch as Exceptions-import qualified Control.Monad.Fail as Fail+import Control.Monad.Catch qualified as Exceptions+import Control.Monad.Fail qualified as Fail -import Data.Bifoldable-import Data.Bifunctor (bimap)-import Data.Dynamic (Dynamic, toDyn)-import qualified Data.List.Trace as Trace-import Data.Map.Strict (Map)-import Data.Maybe (fromMaybe)-import Data.Monoid (Endo (..))-import Data.STRef.Lazy-import Data.Semigroup (Max (..))-import Data.Time.Clock (diffTimeToPicoseconds)-import Data.Typeable-import Data.Word (Word64)-import qualified Debug.Trace as Debug-import NoThunks.Class (NoThunks (..))-import Text.Printf+import Data.Bifoldable+import Data.Bifunctor (bimap)+import Data.Dynamic (Dynamic, toDyn)+import Data.List.Trace qualified as Trace+import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe)+import Data.Monoid (Endo (..))+import Data.Semigroup (Max (..))+import Data.STRef.Lazy+import Data.Time.Clock (diffTimeToPicoseconds)+import Data.Typeable+import Data.Word (Word64)+import Debug.Trace qualified as Debug+import NoThunks.Class (NoThunks (..))+import Text.Printf -import GHC.Exts (oneShot)-import GHC.Generics (Generic)-import Quiet (Quiet (..))+import GHC.Exts (oneShot)+import GHC.Generics (Generic)+import Quiet (Quiet (..)) -import Control.Monad.IOSim.CommonTypes-import Control.Monad.IOSim.STM-import Control.Monad.IOSimPOR.Types+import Control.Monad.IOSim.CommonTypes+import Control.Monad.IOSim.STM+import Control.Monad.IOSimPOR.Types -import qualified System.IO.Error as IO.Error (userError) import Data.List (intercalate)+import GHC.IO (mkUserError)+import System.IO.Error qualified as IO.Error (userError) {-# ANN module "HLint: ignore Use readTVarIO" #-} newtype IOSim s a = IOSim { unIOSim :: forall r. (a -> SimA s r) -> SimA s r }@@ -143,7 +144,7 @@ runIOSim :: IOSim s a -> SimA s a runIOSim (IOSim k) = k Return --- | 'IOSim' has the ability to story any 'Typeable' value in its trace which+-- | 'IOSim' has the ability to store any 'Typeable' value in its trace which -- can then be recovered with `selectTraceEventsDynamic` or -- `selectTraceEventsDynamic'`. --@@ -234,7 +235,9 @@ LiftSTStm :: StrictST.ST s a -> (a -> StmA s b) -> StmA s b FixStm :: (x -> STM s x) -> (x -> StmA s r) -> StmA s r --- Exported type+-- | `IOSim`'s 'MonadSTM.STM' monad, as 'IOSim' it is parametrised by @s@, e.g.+-- @STMSim s a@ is monadic expression of type @a@.+-- type STMSim = STM --@@ -285,7 +288,12 @@ instance MonadFix (IOSim s) where mfix f = IOSim $ oneShot $ \k -> Fix f k +instance Alternative (IOSim s) where+ empty = throwIO (mkUserError "mzero")+ (<|>) !a b = a `catch` \(_ :: IOError) -> b +instance MonadPlus (IOSim s)+ instance Functor (STM s) where {-# INLINE fmap #-} fmap f = \d -> STM $ oneShot $ \k -> unSTM d (k . f)@@ -630,8 +638,9 @@ -- | Lift an 'StrictST.ST' computation to 'IOSim'. ----- Note: you can use 'MonadST' to lift 'StrictST.ST' computations, this is just+-- Note: you can use 'MonadST' to lift 'StrictST.ST' computations, this is -- a more convenient function just for 'IOSim'.+-- liftST :: StrictST.ST s a -> IOSim s a liftST action = IOSim $ oneShot $ \k -> LiftST action k @@ -816,7 +825,7 @@ -- ^ Return value of the main thread. | MainException !Time !(Labelled IOSimThreadId) SomeException ![Labelled IOSimThreadId] -- ^ Exception thrown by the main thread.- | Deadlock !Time ![Labelled IOSimThreadId]+ | Deadlock !Time ![Labelled IOSimThreadId] -- ^ Deadlock discovered in the simulation. Deadlocks are discovered if -- simply the simulation cannot do any progress in a given time slot and -- there's no event which would advance the time.@@ -824,6 +833,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> deriving (Show, Functor) ppSimResult :: Show a@@ -860,7 +870,7 @@ tidWidth "" thLabelWidth- "" + "" "Deadlock" ("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]") Loop -> "<<io-sim-por: step execution exceded explorationStepTimelimit>>"@@ -874,6 +884,12 @@ -- | Pretty print simulation trace. --+-- Note: this is not a streaming function, it will evaluate the whole trace+-- before printing it. If you need to print a very large trace, you might want+-- to use+--+-- @'Trace.ppTrace' show ('ppSimEvent' 0 0 0)@+-- ppTrace :: Show a => SimTrace a -> String ppTrace tr = Trace.ppTrace (ppSimResult timeWidth tidWidth labelWidth)@@ -1047,8 +1063,6 @@ | EventTimerCreated TimeoutId TVarId Time -- ^ a new 'Timeout' created (via `newTimeout`)- | EventTimerUpdated TimeoutId Time- -- ^ a 'Timeout' was updated (via `updateTimeout`) | EventTimerCancelled TimeoutId -- ^ a 'Timeout' was cancelled (via `cancelTimeout`) | EventTimerFired TimeoutId@@ -1085,6 +1099,8 @@ | EventPerformAction StepId -- ^ /IOSimPOR/ event: perform action of the given step | EventReschedule ScheduleControl+ -- ^ /IOSimPOR/ event: reschedule a thread following the given+ -- `ScheduleControl` | EventEffect VectorClock Effect -- ^ /IOSimPOR/ event: executed effect; Useful for debugging IOSimPOR or@@ -1153,10 +1169,6 @@ show timer, " ", show tvarId, " ", show t ]- EventTimerUpdated timer t ->- concat [ "TimerUpdated ",- show timer, " ",- show t ] EventTimerCancelled timer -> "TimerCancelled " ++ show timer EventTimerFired timer -> "TimerFired " ++ show timer EventThreadStatus tid tid' ->
src/Control/Monad/IOSimPOR/Internal.hs view
@@ -49,44 +49,42 @@ , ScheduleMod (..) ) where -import Prelude hiding (read)+import Prelude hiding (read) -import Data.Dynamic-import Data.Foldable (foldlM, traverse_)-import qualified Data.List as List-import qualified Data.List.Trace as Trace-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Maybe (mapMaybe)-import Data.Ord-import Data.OrdPSQ (OrdPSQ)-import qualified Data.OrdPSQ as PSQ-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Time (UTCTime (..), fromGregorian)+import Data.Dynamic+import Data.Foldable (foldlM, traverse_)+import Data.List qualified as List+import Data.List.Trace qualified as Trace+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (mapMaybe)+import Data.Ord+import Data.OrdPSQ (OrdPSQ)+import Data.OrdPSQ qualified as PSQ+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Time (UTCTime (..), fromGregorian) -import Control.Exception (NonTermination (..),- assert, throw)-import Control.Monad (join, when)-import Control.Monad.ST.Lazy-import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)-import Data.STRef.Lazy+import Control.Exception (NonTermination (..), assert, throw)+import Control.Monad (join, when)+import Control.Monad.ST.Lazy+import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)+import Data.STRef.Lazy -import Control.Concurrent.Class.MonadSTM.TMVar-import Control.Concurrent.Class.MonadSTM.TVar hiding (TVar)-import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)-import Control.Monad.Class.MonadSTM hiding (STM)-import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))-import Control.Monad.Class.MonadThrow as MonadThrow-import Control.Monad.Class.MonadTime-import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))+import Control.Concurrent.Class.MonadSTM.TMVar+import Control.Concurrent.Class.MonadSTM.TVar hiding (TVar)+import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)+import Control.Monad.Class.MonadSTM hiding (STM)+import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))+import Control.Monad.Class.MonadThrow as MonadThrow+import Control.Monad.Class.MonadTime+import Control.Monad.Class.MonadTimer.SI (TimeoutState (..)) -import Control.Monad.IOSim.InternalTypes-import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent),- Trace (SimTrace))-import Control.Monad.IOSim.Types (SimEvent)-import Control.Monad.IOSimPOR.Timeout (unsafeTimeout)-import Control.Monad.IOSimPOR.Types+import Control.Monad.IOSim.InternalTypes+import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent), Trace (SimTrace))+import Control.Monad.IOSim.Types (SimEvent)+import Control.Monad.IOSimPOR.Timeout (unsafeTimeout)+import Control.Monad.IOSimPOR.Types -- -- Simulation interpreter@@ -1729,10 +1727,10 @@ updateRaces :: Thread s a -> SimState s a -> Races updateRaces thread@Thread { threadId = tid } SimState{ control, threads, races = races@Races { activeRaces } } =- let + let newStep@Step{ stepEffect = newEffect } = currentStep thread - concurrent0 = + concurrent0 = Map.keysSet (Map.filter (\t -> not (isThreadDone t) && threadId t `Set.notMember` effectForks newEffect
src/Control/Monad/IOSimPOR/QuickCheckUtils.hs view
@@ -4,9 +4,9 @@ module Control.Monad.IOSimPOR.QuickCheckUtils where -import Control.Monad.ST.Lazy-import Test.QuickCheck.Gen-import Test.QuickCheck.Property+import Control.Monad.ST.Lazy+import Test.QuickCheck.Gen+import Test.QuickCheck.Property -- We also need a version of conjoin that is sequential, but does not -- label its result as an IO property unless one of its arguments
src/Control/Monad/IOSimPOR/Timeout.hs view
@@ -9,14 +9,13 @@ -- enabled, +RTS -T -RTS). Thus this can be used more reliably to -- limit computation time. -import Control.Concurrent-import Control.Exception (Exception (..), asyncExceptionFromException,- asyncExceptionToException, bracket, handleJust,- uninterruptibleMask_)-import Control.Monad-import Data.Unique (Unique, newUnique)-import GHC.Stats-import System.IO.Unsafe+import Control.Concurrent+import Control.Exception (Exception (..), asyncExceptionFromException,+ asyncExceptionToException, bracket, handleJust, uninterruptibleMask_)+import Control.Monad+import Data.Unique (Unique, newUnique)+import GHC.Stats+import System.IO.Unsafe -- An internal type that is thrown as a dynamic exception to
src/Control/Monad/IOSimPOR/Types.hs view
@@ -24,11 +24,11 @@ , noRaces ) where -import qualified Data.List as List-import Data.Set (Set)-import qualified Data.Set as Set+import Data.List qualified as List+import Data.Set (Set)+import Data.Set qualified as Set -import Control.Monad.IOSim.CommonTypes+import Control.Monad.IOSim.CommonTypes -- -- Effects
src/Data/Deque/Strict.hs view
@@ -4,9 +4,9 @@ -- module Data.Deque.Strict where -import Prelude hiding (head, init, tail)-import Data.Foldable (foldl', foldr')-import qualified Data.List as List+import Data.Foldable (foldl', foldr')+import Data.List qualified as List+import Prelude hiding (head, init, tail) data Deque a = Deque ![a] ![a]
src/Data/List/Trace.hs view
@@ -12,15 +12,15 @@ , length ) where -import Prelude hiding (filter, head, length, tail)+import Prelude hiding (filter, head, length, tail) -import Control.Applicative (Alternative (..))-import Control.Monad (MonadPlus (..))-import Control.Monad.Fix (MonadFix (..), fix)-import Data.Bifoldable-import Data.Bifunctor-import Data.Bitraversable-import Data.Functor.Classes+import Control.Applicative (Alternative (..))+import Control.Monad (MonadPlus (..))+import Control.Monad.Fix (MonadFix (..), fix)+import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import Data.Functor.Classes -- | A 'cons' list with polymorphic 'nil'. --
test/Main.hs view
@@ -1,10 +1,10 @@ module Main (main) where -import Test.Tasty+import Test.Tasty -import qualified Test.Control.Concurrent.Class.MonadMVar (tests)-import qualified Test.Control.Monad.IOSim (tests)-import qualified Test.Control.Monad.IOSimPOR (tests)+import Test.Control.Concurrent.Class.MonadMVar qualified (tests)+import Test.Control.Monad.IOSim qualified (tests)+import Test.Control.Monad.IOSimPOR qualified (tests) main :: IO () main = defaultMain tests
test/Test/Control/Concurrent/Class/MonadMVar.hs view
@@ -5,23 +5,23 @@ module Test.Control.Concurrent.Class.MonadMVar where -import Control.Concurrent.Class.MonadMVar-import Control.Monad.Class.MonadAsync-import Control.Monad.Class.MonadFork-import Control.Monad.Class.MonadTime.SI-import Control.Monad.Class.MonadTimer.SI-import Data.Bifoldable (bifoldMap)-import Data.Foldable (traverse_)-import Data.Functor (void, ($>))-import Data.Maybe (isNothing)-import Data.Monoid (All (..))+import Control.Concurrent.Class.MonadMVar+import Control.Monad.Class.MonadAsync+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer.SI+import Data.Bifoldable (bifoldMap)+import Data.Foldable (traverse_)+import Data.Functor (void, ($>))+import Data.Maybe (isNothing)+import Data.Monoid (All (..)) -import Control.Monad.IOSim+import Control.Monad.IOSim -import Test.QuickCheck-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck (testProperty) tests :: TestTree tests =
test/Test/Control/Monad/IOSim.hs view
@@ -22,33 +22,33 @@ , singleTimeoutExperiment ) where -import Data.Either (isLeft)-import Data.Fixed (Micro)-import Data.Foldable (foldl')-import Data.Functor (($>))-import Data.Time.Clock (picosecondsToDiffTime)+import Data.Either (isLeft)+import Data.Fixed (Micro)+import Data.Foldable (foldl')+import Data.Functor (($>))+import Data.Time.Clock (picosecondsToDiffTime) -import Control.Exception (ArithException (..), AsyncException)-import Control.Monad-import Control.Monad.Fix-import System.IO.Error (ioeGetErrorString, isUserError)+import Control.Exception (ArithException (..), AsyncException)+import Control.Monad+import Control.Monad.Fix+import System.IO.Error (ioeGetErrorString, isUserError) -import Control.Concurrent.Class.MonadSTM.Strict-import qualified Control.Concurrent.Class.MonadSTM.TVar as LazySTM-import Control.Monad.Class.MonadAsync-import Control.Monad.Class.MonadFork-import Control.Monad.Class.MonadSay-import Control.Monad.Class.MonadThrow-import Control.Monad.Class.MonadTime.SI-import Control.Monad.Class.MonadTimer.SI-import Control.Monad.IOSim+import Control.Concurrent.Class.MonadSTM.Strict+import Control.Concurrent.Class.MonadSTM.TVar qualified as LazySTM+import Control.Monad.Class.MonadAsync+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadSay+import Control.Monad.Class.MonadThrow+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer.SI+import Control.Monad.IOSim -import Test.Control.Monad.Utils-import Test.Control.Monad.STM+import Test.Control.Monad.STM+import Test.Control.Monad.Utils -import Test.QuickCheck-import Test.Tasty hiding (after)-import Test.Tasty.QuickCheck+import Test.QuickCheck+import Test.Tasty hiding (after)+import Test.Tasty.QuickCheck tests :: TestTree tests =@@ -176,6 +176,12 @@ , testProperty "registerDelayCancellable (IO impl)" prop_registerDelayCancellable_IO ]+ , testGroup "MonadSTM"+ [ testGroup "flushTQueue"+ [ testProperty "empties the queue" prop_flushTQueueEmpties+ , testProperty "maintains FIFO order" prop_flushTQueueOrder+ ]+ ] ] --@@ -995,7 +1001,7 @@ :: TimeoutDuration -> ActionDuration -> Property-prop_timeout intendedTimeoutDuration intendedActionDuration = +prop_timeout intendedTimeoutDuration intendedActionDuration = runSimOrThrow (withSanityCheck <$> singleTimeoutExperiment intendedTimeoutDuration@@ -1077,7 +1083,7 @@ threadDelay (delay / 2) killThread tid threadDelay 1- return $ property True + return $ property True unit_timeouts_and_async_exceptions_2 :: Property@@ -1098,7 +1104,7 @@ threadDelay (delay / 2) killThread tid threadDelay 1- return $ property True + return $ property True unit_timeouts_and_async_exceptions_3 :: Property@@ -1119,7 +1125,7 @@ threadDelay (delay / 2) killThread tid threadDelay 1- return $ property True + return $ property True -- | Verify that a thread blocked on `threadDelay` is not unblocked by an STM@@ -1289,7 +1295,7 @@ prop_registerDelayCancellable :: (forall s. DiffTime -> IOSim s (STM (IOSim s) TimeoutState, IOSim s ()))- -- ^ implementation + -- ^ implementation -> DelayWithCancel -> Property prop_registerDelayCancellable registerDelayCancellableImpl@@ -1347,6 +1353,33 @@ readTimeout cancelTimeout awaitTimeout++-- | Test that 'flushTQueue' empties the queue.+prop_flushTQueueEmpties :: Property+prop_flushTQueueEmpties =+ ioProperty emptyQueueAfterFlush+ .&&. runSimOrThrow emptyQueueAfterFlush++emptyQueueAfterFlush :: MonadSTM m => m Bool+emptyQueueAfterFlush = do+ q <- newTQueueIO+ atomically $ do+ writeTQueue q (1 :: Int)+ _ <- flushTQueue q+ isEmptyTQueue q++-- | Test that 'flushTQueue' returns values in FIFO order.+prop_flushTQueueOrder :: [Int] -> Property+prop_flushTQueueOrder entries =+ ioProperty (writeAndFlushQueue entries >>= \actual -> pure $ actual === entries)+ .&&. runSimOrThrow (writeAndFlushQueue entries) === entries++writeAndFlushQueue :: MonadSTM m => [Int] -> m [Int]+writeAndFlushQueue entries =+ atomically $ do+ q <- newTQueue+ forM_ entries $ writeTQueue q+ flushTQueue q -- -- Utils
test/Test/Control/Monad/IOSimPOR.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-}@@ -10,45 +10,44 @@ module Test.Control.Monad.IOSimPOR (tests) where -import Data.Fixed (Micro)-import Data.Foldable (foldl', traverse_)-import Data.Functor (($>))-import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.STRef.Lazy+import Data.Fixed (Micro)+import Data.Foldable (foldl', traverse_)+import Data.Functor (($>))+import Data.List qualified as List+import Data.Map (Map)+import Data.Map qualified as Map+import Data.STRef.Lazy -import System.Exit-import System.IO.Error (ioeGetErrorString, isUserError)+import System.Exit+import System.IO.Error (ioeGetErrorString, isUserError) -import Control.Exception (ArithException (..), AsyncException)-import Control.Monad-import Control.Monad.Fix-import Control.Monad.ST.Lazy (ST, runST)+import Control.Exception (ArithException (..), AsyncException)+import Control.Monad+import Control.Monad.Fix+import Control.Monad.ST.Lazy (ST, runST) -import Control.Concurrent.Class.MonadSTM-import Control.Monad.Class.MonadAsync-import Control.Monad.Class.MonadFork-import Control.Monad.Class.MonadSay-import Control.Monad.Class.MonadTest-import Control.Monad.Class.MonadThrow-import Control.Monad.Class.MonadTime.SI-import Control.Monad.Class.MonadTimer.SI-import Control.Monad.IOSim+import Control.Concurrent.Class.MonadSTM+import Control.Monad.Class.MonadAsync+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadSay+import Control.Monad.Class.MonadTest+import Control.Monad.Class.MonadThrow+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer.SI+import Control.Monad.IOSim -import GHC.Generics+import GHC.Generics -import Test.Control.Monad.IOSim (TimeoutDuration, ActionDuration,- WithSanityCheck (..), ignoreSanityCheck,- isSanityCheckIgnored, singleTimeoutExperiment,- withSanityCheck)-import Test.Control.Monad.Utils-import Test.Control.Monad.STM+import Test.Control.Monad.IOSim (ActionDuration, TimeoutDuration,+ WithSanityCheck (..), ignoreSanityCheck, isSanityCheckIgnored,+ singleTimeoutExperiment, withSanityCheck)+import Test.Control.Monad.STM+import Test.Control.Monad.Utils -import Test.QuickCheck-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.QuickCheck-import qualified Data.List.Trace as Trace+import Data.List.Trace qualified as Trace+import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck tests :: TestTree tests =@@ -339,7 +338,7 @@ Left (FailureInternal msg) -> counterexample msg False Left x -> counterexample (ppTrace trace)- $ counterexample (show x) True + $ counterexample (show x) True -- NOTE: This property needs to be executed sequentially, otherwise it fails -- undeterministically, which `exploreSimTraceST` does.@@ -899,7 +898,7 @@ :: TimeoutDuration -> ActionDuration -> Property-prop_timeout intendedTimeoutDuration intendedActionDuration = +prop_timeout intendedTimeoutDuration intendedActionDuration = exploreSimTrace id experiment $ \_ trace -> case traceResult False trace of Right a -> a@@ -990,7 +989,7 @@ threadDelay (delay / 2) killThread tid threadDelay 1- return $ property True + return $ property True unit_timeouts_and_async_exceptions_2 :: Property@@ -1012,7 +1011,7 @@ threadDelay (delay / 2) killThread tid threadDelay 1- return $ property True + return $ property True unit_timeouts_and_async_exceptions_3 :: Property@@ -1034,7 +1033,7 @@ threadDelay (delay / 2) killThread tid threadDelay 1- return $ property True + return $ property True -- -- MonadMask properties
test/Test/Control/Monad/STM.hs view
@@ -21,19 +21,19 @@ -- module Test.Control.Monad.STM where -import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe, maybeToList)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Type.Equality-import Prelude hiding (exp)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, maybeToList)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Type.Equality+import Prelude hiding (exp) -import Control.Concurrent.Class.MonadSTM.TVar as STM-import Control.Monad.Class.MonadSTM as STM-import Control.Monad.Class.MonadThrow+import Control.Concurrent.Class.MonadSTM.TVar as STM+import Control.Monad.Class.MonadSTM as STM+import Control.Monad.Class.MonadThrow -import Test.QuickCheck+import Test.QuickCheck -- | The type level structure of types in our STM 'Term's. This is kept simple,
test/Test/Control/Monad/Utils.hs view
@@ -4,23 +4,23 @@ module Test.Control.Monad.Utils where -import Data.Array-import Data.Fixed (Fixed (..), Micro)-import Data.Function (on)-import Data.Graph-import Data.List (sortBy)+import Data.Array+import Data.Fixed (Fixed (..), Micro)+import Data.Function (on)+import Data.Graph+import Data.List (sortBy) -import Control.Monad+import Control.Monad -import Control.Monad.Class.MonadFork-import Control.Concurrent.Class.MonadSTM.Strict-import Control.Monad.Class.MonadThrow-import Control.Monad.Class.MonadTimer.SI-import Control.Monad.IOSim+import Control.Concurrent.Class.MonadSTM.Strict+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadThrow+import Control.Monad.Class.MonadTimer.SI+import Control.Monad.IOSim -import Test.Control.Monad.STM+import Test.Control.Monad.STM -import Test.QuickCheck+import Test.QuickCheck -- -- Read/Write graph