Merge pull request #107 from input-output-hk/coot/selectors-with-time

io-sim: selector functions which capture time

Author: coot

io-sim/CHANGELOG.md

@@ -2,6 +2,15 @@
 
 ## next version
 
+### 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`.

io-sim/src/Control/Monad/IOSim.hs

@@ -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 @@ module Control.Monad.IOSim
   , selectTraceEvents
   , selectTraceEvents'
   , selectTraceEventsDynamic
+  , selectTraceEventsDynamicWithTime
   , selectTraceEventsDynamic'
+  , selectTraceEventsDynamicWithTime'
   , selectTraceEventsSay
+  , selectTraceEventsSayWithTime
   , selectTraceEventsSay'
+  , selectTraceEventsSayWithTime'
   , selectTraceRaces
     -- *** trace selectors
   , traceSelectTraceEvents
@@ -108,7 +113,7 @@ import           System.IO.Unsafe
 
 
 selectTraceEvents
-    :: (SimEventType -> Maybe b)
+    :: (Time -> SimEventType -> Maybe b)
     -> SimTrace a
     -> [b]
 selectTraceEvents fn =
@@ -124,7 +129,7 @@ selectTraceEvents fn =
     . traceSelectTraceEvents fn
 
 selectTraceEvents'
-    :: (SimEventType -> Maybe b)
+    :: (Time ->  SimEventType -> Maybe b)
     -> SimTrace a
     -> [b]
 selectTraceEvents' fn =
@@ -177,19 +182,37 @@ detachTraceRaces trace = unsafePerformIO $ do
 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'.
 --
@@ -198,19 +221,37 @@ selectTraceEventsDynamic' = selectTraceEvents' fn
 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.
 --
@@ -223,19 +264,19 @@ printTraceEventsSay = mapM_ print . selectTraceEventsSay
 -- | 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 )
                                     ( \ eventCtx acc
                                      -> 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,19 +288,19 @@ traceSelectTraceEventsDynamic :: forall a b. Typeable b
                               => 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.
 --
 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.
 --