io-sim 1.1.0.0 → 1.2.0.0

raw patch · 5 files changed

+107/−33 lines, 5 filesdep +deepseqdep ~io-classesdep ~si-timersdep ~strict-stmPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependency ranges changed: io-classes, si-timers, strict-stm

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• io-sim.cabal +8/−9
• src/Control/Monad/IOSim.hs +64/−23
• src/Control/Monad/IOSim/CommonTypes.hs +11/−1
• src/Control/Monad/IOSim/Types.hs +8/−0

@@ -1,5 +1,21 @@ # Revsion history of io-sim +## 1.2.0.0++### Breaking changes++* `selectTraceEvents`, `selectTraceEvents'` catpure time of events.+* Added select function which capture the time of the trace events:+  - `selectTraceEventsDynamicWithTime`+  - `selectTraceEventsDynamicWithTime'`+  - `selectTraceEventsSayWithTime`+  - `selectTraceEventsSayWithTime'`++### Non breaking changes++* Provide `MonadInspectMVar` instance for `IOSim`.+- Added NFData & NoThunks instances for `ThreadId`+ ## 1.1.0.0  ### Non breaking changes

@@ -1,22 +1,20 @@ cabal-version:       3.0 name:                io-sim-version:             1.1.0.0+version:             1.2.0.0 synopsis:            A pure simulator for monadic concurrency with STM. description:   A pure simulator monad with support of concurency (base, async), stm,   synchronous and asynchronous exceptions, timeouts & delays, dynamic traces,   and more. license:             Apache-2.0-license-files:-  LICENSE-  NOTICE+license-files:       LICENSE NOTICE copyright:           2022-2023 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 build-type:          Simple-extra-source-files:  CHANGELOG.md-                     README.md+extra-doc-files:     CHANGELOG.md README.md+bug-reports:         https://github.com/input-output-hk/io-sim/issues tested-with:         GHC == { 8.10, 9.2, 9.4, 9.6 }  flag asserts@@ -77,14 +75,15 @@                        ScopedTypeVariables,                        TypeFamilies   build-depends:       base              >=4.9 && <4.19,-                       io-classes       ^>=1.1,+                       io-classes       ^>=1.2,                        exceptions        >=0.10,                        containers,+                       deepseq,                        nothunks,                        parallel,                        psqueues          >=0.2 && <0.3,-                       strict-stm        >=1.0 && <1.2,-                       si-timers         >=1.0 && <1.2,+                       strict-stm       ^>=1.2,+                       si-timers        ^>=1.2,                        time              >=1.9.1 && <1.13,                        quiet,                        QuickCheck,

@@ -2,6 +2,7 @@ {-# LANGUAGE NamedFieldPuns      #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}  {-# OPTIONS_GHC -Wno-name-shadowing #-} module Control.Monad.IOSim@@ -58,9 +59,13 @@   , selectTraceEvents   , selectTraceEvents'   , selectTraceEventsDynamic+  , selectTraceEventsDynamicWithTime   , selectTraceEventsDynamic'+  , selectTraceEventsDynamicWithTime'   , selectTraceEventsSay+  , selectTraceEventsSayWithTime   , selectTraceEventsSay'+  , selectTraceEventsSayWithTime'   , selectTraceRaces     -- *** trace selectors   , traceSelectTraceEvents@@ -108,7 +113,7 @@   selectTraceEvents-    :: (SimEventType -> Maybe b)+    :: (Time -> SimEventType -> Maybe b)     -> SimTrace a     -> [b] selectTraceEvents fn =@@ -124,7 +129,7 @@     . traceSelectTraceEvents fn  selectTraceEvents'-    :: (SimEventType -> Maybe b)+    :: (Time ->  SimEventType -> Maybe b)     -> SimTrace a     -> [b] selectTraceEvents' fn =@@ -177,20 +182,38 @@ selectTraceEventsDynamic :: forall a b. Typeable b => SimTrace a -> [b] selectTraceEventsDynamic = selectTraceEvents fn   where-    fn :: SimEventType -> Maybe b-    fn (EventLog dyn) = fromDynamic dyn-    fn _              = Nothing+    fn :: Time -> SimEventType -> Maybe b+    fn _ (EventLog dyn) = fromDynamic dyn+    fn _ _              = Nothing +-- | Like 'selectTraceEventsDynamic' but also captures time of the trace event.+--+selectTraceEventsDynamicWithTime :: forall a b. Typeable b => SimTrace a -> [(Time, b)]+selectTraceEventsDynamicWithTime = selectTraceEvents fn+  where+    fn :: Time -> SimEventType -> Maybe (Time, b)+    fn t (EventLog dyn) = (t,) <$> fromDynamic dyn+    fn _ _              = Nothing+ -- | Like 'selectTraceEventsDynamic' but returns partial trace if an exception -- is found in it. -- selectTraceEventsDynamic' :: forall a b. Typeable b => SimTrace a -> [b] selectTraceEventsDynamic' = selectTraceEvents' fn   where-    fn :: SimEventType -> Maybe b-    fn (EventLog dyn) = fromDynamic dyn-    fn _              = Nothing+    fn :: Time -> SimEventType -> Maybe b+    fn _ (EventLog dyn) = fromDynamic dyn+    fn _ _              = Nothing +-- | Like `selectTraceEventsDynamic'` but also captures time of the trace event.+--+selectTraceEventsDynamicWithTime' :: forall a b. Typeable b => SimTrace a -> [(Time, b)]+selectTraceEventsDynamicWithTime' = selectTraceEvents' fn+  where+    fn :: Time -> SimEventType -> Maybe (Time, b)+    fn t (EventLog dyn) = (t,) <$> fromDynamic dyn+    fn _ _              = Nothing+ -- | Get a trace of 'EventSay'. -- -- For convenience, this throws exceptions for abnormal sim termination.@@ -198,20 +221,38 @@ selectTraceEventsSay :: SimTrace a -> [String] selectTraceEventsSay = selectTraceEvents fn   where-    fn :: SimEventType -> Maybe String-    fn (EventSay s) = Just s-    fn _            = Nothing+    fn :: Time -> SimEventType -> Maybe String+    fn _ (EventSay s) = Just s+    fn _ _            = Nothing +-- | Like 'selectTraceEventsSay' but also captures time of the trace event.+--+selectTraceEventsSayWithTime :: SimTrace a -> [(Time, String)]+selectTraceEventsSayWithTime = selectTraceEvents fn+  where+    fn :: Time -> SimEventType -> Maybe (Time, String)+    fn t (EventSay s) = Just (t, s)+    fn _ _            = Nothing+ -- | Like 'selectTraceEventsSay' but return partial trace if an exception is -- found in it. -- selectTraceEventsSay' :: SimTrace a -> [String] selectTraceEventsSay' = selectTraceEvents' fn   where-    fn :: SimEventType -> Maybe String-    fn (EventSay s) = Just s-    fn _            = Nothing+    fn :: Time -> SimEventType -> Maybe String+    fn _ (EventSay s) = Just s+    fn _ _            = Nothing +-- | Like `selectTraceEventsSay'` but also captures time of the trace event.+--+selectTraceEventsSayWithTime' :: SimTrace a -> [(Time, String)]+selectTraceEventsSayWithTime' = selectTraceEvents' fn+  where+    fn :: Time -> SimEventType -> Maybe (Time, String)+    fn t (EventSay s) = Just (t, s)+    fn _ _            = Nothing+ -- | Print all 'EventSay' to the console. -- -- For convenience, this throws exceptions for abnormal sim termination.@@ -223,7 +264,7 @@ -- | The most general select function.  It is a _total_ function. -- traceSelectTraceEvents-    :: (SimEventType -> Maybe b)+    :: (Time -> SimEventType -> Maybe b)     -> SimTrace a     -> Trace (SimResult a) b traceSelectTraceEvents fn = bifoldr ( \ v _acc -> Nil v )@@ -231,11 +272,11 @@                                      -> case eventCtx of                                           SimRacesFound _ -> acc                                           SimEvent{} ->-                                            case fn (seType eventCtx) of+                                            case fn (seTime eventCtx) (seType eventCtx) of                                               Nothing -> acc                                               Just b  -> Cons b acc                                           SimPOREvent{} ->-                                            case fn (seType eventCtx) of+                                            case fn (seTime eventCtx) (seType eventCtx) of                                               Nothing -> acc                                               Just b  -> Cons b acc                                     )@@ -247,9 +288,9 @@                               => SimTrace a -> Trace (SimResult a) b traceSelectTraceEventsDynamic = traceSelectTraceEvents fn   where-    fn :: SimEventType -> Maybe b-    fn (EventLog dyn) = fromDynamic dyn-    fn _              = Nothing+    fn :: Time -> SimEventType -> Maybe b+    fn _ (EventLog dyn) = fromDynamic dyn+    fn _ _              = Nothing   -- | Select say events.  It is a _total_ function.@@ -257,9 +298,9 @@ traceSelectTraceEventsSay :: forall a.  SimTrace a -> Trace (SimResult a) String traceSelectTraceEventsSay = traceSelectTraceEvents fn   where-    fn :: SimEventType -> Maybe String-    fn (EventSay s) = Just s-    fn _            = Nothing+    fn :: Time -> SimEventType -> Maybe String+    fn _ (EventSay s) = Just s+    fn _ _            = Nothing  -- | Simulation terminated a failure. --

@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveAnyClass             #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables        #-}@@ -6,12 +9,16 @@ -- module Control.Monad.IOSim.CommonTypes where +import           Control.DeepSeq (NFData (..)) import           Control.Monad.Class.MonadSTM (TraceValue) import           Control.Monad.ST.Lazy +import           NoThunks.Class+ import           Data.Map (Map) import           Data.STRef.Lazy import           Data.Set (Set)+import           GHC.Generics   -- | A thread id.@@ -23,7 +30,10 @@ -- data ThreadId = RacyThreadId [Int]               | ThreadId     [Int]    -- non racy threads have higher priority-  deriving (Eq, Ord, Show)+  deriving stock    (Eq, Ord, Show, Generic)+  deriving anyclass NFData+  deriving anyclass NoThunks+  childThreadId :: ThreadId -> Int -> ThreadId childThreadId (RacyThreadId is) i = RacyThreadId (is ++ [i])

@@ -567,6 +567,14 @@   tryReadMVar  = tryReadMVarDefault   isEmptyMVar  = isEmptyMVarDefault +instance MonadInspectMVar (IOSim s) where+  type InspectMVarMonad (IOSim s) = ST s+  inspectMVar p (MVar tvar) = do+      st <- inspectTVar p tvar+      case st of+        MVarEmpty _ _ -> pure Nothing+        MVarFull x _  -> pure (Just x)+ data Async s a = Async !ThreadId (STM s (Either SomeException a))  instance Eq (Async s a) where