simulation: Restrict available Time API (#114)

Author: wenkokke

.hlint.yaml

@@ -28,8 +28,11 @@
 - modules:
     # Ensure that MonadDelay is imported from TimeCompat
     - name:
+        - "Data.Time.**"
         - "Control.Monad.Class.MonadTime"
         - "Control.Monad.Class.MonadTime.SI"
+        - "Control.Monad.Class.MonadTimer"
+        - "Control.Monad.Class.MonadTimer.SI"
       within: "TimeCompat"
       message: "Use TimeCompat instead"
     # Ensure that MonadSTM is imported from STMCompat

simulation/src/LeiosProtocol/Short/SimP2P.hs

@@ -6,28 +6,27 @@
 
 module LeiosProtocol.Short.SimP2P where
 
+import ChanMux (newConnectionBundleTCP)
+import ChanTCP
+import Control.Monad (forever)
+import Control.Monad.Class.MonadFork (MonadFork (forkIO))
 import Control.Monad.IOSim as IOSim (IOSim, runSimTrace)
 import Control.Tracer as Tracer (
   Contravariant (contramap),
   Tracer,
   traceWith,
  )
 import Data.List (unfoldr)
-import qualified Data.Map.Strict as Map
-import System.Random (StdGen, split)
-
-import ChanMux (newConnectionBundleTCP)
-import ChanTCP
-import Control.Monad (forever)
-import Control.Monad.Class.MonadFork (MonadFork (forkIO))
 import qualified Data.Map.Strict as M
+import qualified Data.Map.Strict as Map
 import LeiosProtocol.Common
 import LeiosProtocol.Short
 import LeiosProtocol.Short.Node
 import LeiosProtocol.Short.Sim
 import P2P (P2PTopography (..))
 import SimTCPLinks (labelDirToLabelLink, mkTcpConnProps, selectTimedEvents, simTracer)
 import SimTypes
+import System.Random (StdGen, split)
 
 traceLeiosP2P ::
   StdGen ->

simulation/src/PraosProtocol/Common/ConcreteBlock.hs

@@ -31,9 +31,6 @@ module PraosProtocol.Common.ConcreteBlock (
   hashBody,
   IsBody,
 
-  -- * Converting slots to times
-  convertSlotToTimeForTestsAssumingNoHardFork,
-
   -- * Creating sample chains
   mkChain,
   mkChainSimple,
@@ -62,8 +59,6 @@ import Data.ByteString (ByteString)
 import Data.Function (fix)
 import Data.Hashable (Hashable (hash))
 import Data.String (IsString)
-import Data.Time.Calendar (fromGregorian)
-import Data.Time.Clock (UTCTime (..), addUTCTime, secondsToNominalDiffTime)
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
@@ -373,28 +368,3 @@ instance Serialise BlockBody where
   encode (BlockBody b) = encodeBytes b
 
   decode = BlockBody <$> decodeBytes
-
-{-------------------------------------------------------------------------------
-  Simple static time conversions, since no HardFork
--------------------------------------------------------------------------------}
-
--- | Arbitrarily but consistently converts slots UTCTimes.
---
--- It is only intended for use in tests. Notably it assumes a fixed system
--- start time, slot length, and the absence of a hard fork (ie no
--- HardForkCombinator). This is how it's available as a pure function.
-convertSlotToTimeForTestsAssumingNoHardFork :: SlotNo -> UTCTime
-convertSlotToTimeForTestsAssumingNoHardFork sl =
-  flip addUTCTime startTime $
-    --   ^^^ arbitrary start time for testing
-    secondsToNominalDiffTime $
-      fromIntegral $
-        unSlotNo sl * 10
- where
-  --   ^^^ arbitrary slot length for testing
-
-  startTime =
-    UTCTime
-      { utctDay = fromGregorian 2000 1 1
-      , utctDayTime = 0
-      }

simulation/src/TimeCompat.hs

@@ -1,31 +1,41 @@
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NumericUnderscores #-}
-
 module TimeCompat (
-  -- Legacy interfact
-  module Control.Monad.Class.MonadTime.SI,
-  threadDelayNDT,
+  DiffTime,
+  MonadTime (getCurrentTime),
+  MonadDelay (threadDelay),
+  MonadMonotonicTime (getMonotonicTime),
+  Time (Time),
+  UTCTime,
+  NominalDiffTime,
+  diffTimeToSeconds,
+  addTime,
+  addUTCTime,
+  diffTime,
+  diffUTCTime,
   threadDelaySI,
-  MonadDelay,
-  -- Int-as-Micros API
-  Microseconds (..),
-  threadDelayMS,
-) where
+  threadDelayNDT,
+)
+where
 
-import Control.Monad.Class.MonadTime.SI
-import Control.Monad.Class.MonadTimer (MonadDelay (..))
+import Control.Monad.Class.MonadTime.SI (
+  DiffTime,
+  MonadMonotonicTime (getMonotonicTime),
+  MonadTime (getCurrentTime),
+  NominalDiffTime,
+  Time (..),
+  UTCTime,
+  addTime,
+  addUTCTime,
+  diffTime,
+  diffUTCTime,
+ )
+import Control.Monad.Class.MonadTimer (MonadDelay (threadDelay))
+import Data.Time.Clock (diffTimeToPicoseconds)
 
-newtype Microseconds = Microseconds {getMicroseconds :: Int}
-  deriving newtype (Eq, Ord, Show, Enum, Num, Real, Integral)
+diffTimeToSeconds :: DiffTime -> Double
+diffTimeToSeconds = (* 1e-12) . fromIntegral . diffTimeToPicoseconds
 
-threadDelayMS :: MonadDelay m => Microseconds -> m ()
-threadDelayMS micros = threadDelay (getMicroseconds micros)
+threadDelaySI :: MonadDelay m => DiffTime -> m ()
+threadDelaySI = threadDelay . round . (* 1e6)
 
--- | Suspends the current thread for a given amount of time.
 threadDelayNDT :: MonadDelay m => NominalDiffTime -> m ()
-threadDelayNDT = threadDelay . round . (1_000_000 *)
-
--- | Suspends the current thread for a given amount of time.
-threadDelaySI :: MonadDelay m => DiffTime -> m ()
-threadDelaySI = threadDelay . round . (1_000_000 *)
+threadDelayNDT = threadDelay . round . (* 1e6)

simulation/src/Viz.hs

@@ -14,14 +14,14 @@ import Data.Functor.Contravariant (Contravariant (contramap))
 import Data.IORef (newIORef, readIORef, writeIORef)
 import Data.List (foldl1', mapAccumL, zip4)
 import Data.Ratio ((%))
-import qualified Data.Time as Time
 import Data.Tree as Tree (Tree (..))
 import qualified Graphics.Rendering.Cairo as Cairo
 import qualified Graphics.Rendering.Pango.Cairo as Pango
 import qualified Graphics.Rendering.Pango.Font as Pango
 import qualified Graphics.Rendering.Pango.Layout as Pango
 import Graphics.UI.Gtk (AttrOp ((:=)))
 import qualified Graphics.UI.Gtk as Gtk
+import Text.Printf (printf)
 import TimeCompat
 
 ------------------------------------------------------------------------------
@@ -710,8 +710,7 @@ layoutLabelTime =
     Cairo.moveTo 5 20
     Cairo.setFontSize 20
     Cairo.setSourceRGB 0 0 0
-    Cairo.showText $
-      Time.formatTime Time.defaultTimeLocale "Time (sec): %-2Es" t
+    Cairo.showText (printf "Time (sec): %.4fs" (diffTimeToSeconds t) :: String)
 
 layoutLabel :: Int -> String -> Layout (VizRender model)
 layoutLabel size label =