From 3ca29ebc8e5827858c59bb3e540f2b996b29f373 Mon Sep 17 00:00:00 2001 From: Wen Kokke Date: Wed, 18 Dec 2024 14:15:31 +0000 Subject: [PATCH 1/3] simulation: Import Data.Time via TimeCompat --- .hlint.yaml | 4 ++++ simulation/src/PraosProtocol/Common/ConcreteBlock.hs | 8 ++++++-- simulation/src/TimeCompat.hs | 11 +++++++++++ simulation/src/Viz.hs | 3 +-- 4 files changed, 22 insertions(+), 4 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 3f9d7b9c..e6421200 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -32,6 +32,10 @@ - "Control.Monad.Class.MonadTime.SI" within: "TimeCompat" message: "Use TimeCompat instead" + # Ensure that Time and DiffTime are imported from TimeCompat + - name: "Data.Time.**" + within: "TimeCompat" + message: "Use TimeCompat instead" # Ensure that MonadSTM is imported from STMCompat - name: "Control.Concurrent.Class.MonadSTM" within: "STMCompat" diff --git a/simulation/src/PraosProtocol/Common/ConcreteBlock.hs b/simulation/src/PraosProtocol/Common/ConcreteBlock.hs index 717ff23a..2e310686 100644 --- a/simulation/src/PraosProtocol/Common/ConcreteBlock.hs +++ b/simulation/src/PraosProtocol/Common/ConcreteBlock.hs @@ -62,8 +62,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) @@ -74,6 +72,12 @@ import PraosProtocol.Common.AnchoredFragment (Anchor (..), AnchoredFragment) import PraosProtocol.Common.AnchoredFragment qualified as AnchoredFragment import PraosProtocol.Common.Chain (Chain) import PraosProtocol.Common.Chain qualified as Chain +import TimeCompat ( + UTCTime (..), + addUTCTime, + fromGregorian, + secondsToNominalDiffTime, + ) {------------------------------------------------------------------------------- Concrete block shape used currently in the network layer diff --git a/simulation/src/TimeCompat.hs b/simulation/src/TimeCompat.hs index a9663554..2e0ddbe0 100644 --- a/simulation/src/TimeCompat.hs +++ b/simulation/src/TimeCompat.hs @@ -8,6 +8,10 @@ module TimeCompat ( threadDelayNDT, threadDelaySI, MonadDelay, + fromGregorian, + UTCTime (..), + secondsToNominalDiffTime, + formatDiffTime, -- Int-as-Micros API Microseconds (..), threadDelayMS, @@ -16,6 +20,13 @@ module TimeCompat ( import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer (MonadDelay (..)) +import Data.Time (defaultTimeLocale, formatTime) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..), secondsToNominalDiffTime) + +formatDiffTime :: String -> (DiffTime -> String) +formatDiffTime = formatTime defaultTimeLocale + newtype Microseconds = Microseconds {getMicroseconds :: Int} deriving newtype (Eq, Ord, Show, Enum, Num, Real, Integral) diff --git a/simulation/src/Viz.hs b/simulation/src/Viz.hs index fe6aa75e..c2c20b5e 100644 --- a/simulation/src/Viz.hs +++ b/simulation/src/Viz.hs @@ -14,7 +14,6 @@ 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 @@ -711,7 +710,7 @@ layoutLabelTime = Cairo.setFontSize 20 Cairo.setSourceRGB 0 0 0 Cairo.showText $ - Time.formatTime Time.defaultTimeLocale "Time (sec): %-2Es" t + formatDiffTime "Time (sec): %-2Es" t layoutLabel :: Int -> String -> Layout (VizRender model) layoutLabel size label = From e2d4ee827e126b6f1a28afa8454aaf48cf63703a Mon Sep 17 00:00:00 2001 From: Wen Kokke Date: Wed, 18 Dec 2024 15:30:25 +0000 Subject: [PATCH 2/3] Restrict available Time API to a minimum --- .hlint.yaml | 7 +- .../src/PraosProtocol/Common/ConcreteBlock.hs | 34 --------- simulation/src/TimeCompat.hs | 73 +++++++++---------- simulation/src/Viz.hs | 4 +- 4 files changed, 41 insertions(+), 77 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index e6421200..0eaeced6 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -28,12 +28,11 @@ - modules: # Ensure that MonadDelay is imported from TimeCompat - name: + - "Data.Time.**" - "Control.Monad.Class.MonadTime" - "Control.Monad.Class.MonadTime.SI" - within: "TimeCompat" - message: "Use TimeCompat instead" - # Ensure that Time and DiffTime are imported from TimeCompat - - name: "Data.Time.**" + - "Control.Monad.Class.MonadTimer" + - "Control.Monad.Class.MonadTimer.SI" within: "TimeCompat" message: "Use TimeCompat instead" # Ensure that MonadSTM is imported from STMCompat diff --git a/simulation/src/PraosProtocol/Common/ConcreteBlock.hs b/simulation/src/PraosProtocol/Common/ConcreteBlock.hs index 2e310686..fbd7dc29 100644 --- a/simulation/src/PraosProtocol/Common/ConcreteBlock.hs +++ b/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, @@ -72,12 +69,6 @@ import PraosProtocol.Common.AnchoredFragment (Anchor (..), AnchoredFragment) import PraosProtocol.Common.AnchoredFragment qualified as AnchoredFragment import PraosProtocol.Common.Chain (Chain) import PraosProtocol.Common.Chain qualified as Chain -import TimeCompat ( - UTCTime (..), - addUTCTime, - fromGregorian, - secondsToNominalDiffTime, - ) {------------------------------------------------------------------------------- Concrete block shape used currently in the network layer @@ -377,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 - } diff --git a/simulation/src/TimeCompat.hs b/simulation/src/TimeCompat.hs index 2e0ddbe0..90784f09 100644 --- a/simulation/src/TimeCompat.hs +++ b/simulation/src/TimeCompat.hs @@ -1,42 +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, - fromGregorian, - UTCTime (..), - secondsToNominalDiffTime, - formatDiffTime, - -- Int-as-Micros API - Microseconds (..), - threadDelayMS, -) where - -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer (MonadDelay (..)) - -import Data.Time (defaultTimeLocale, formatTime) -import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (UTCTime (..), secondsToNominalDiffTime) - -formatDiffTime :: String -> (DiffTime -> String) -formatDiffTime = formatTime defaultTimeLocale - -newtype Microseconds = Microseconds {getMicroseconds :: Int} - deriving newtype (Eq, Ord, Show, Enum, Num, Real, Integral) + threadDelayNDT, +) +where + +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) + +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) diff --git a/simulation/src/Viz.hs b/simulation/src/Viz.hs index c2c20b5e..b39b48d6 100644 --- a/simulation/src/Viz.hs +++ b/simulation/src/Viz.hs @@ -21,6 +21,7 @@ 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 ------------------------------------------------------------------------------ @@ -709,8 +710,7 @@ layoutLabelTime = Cairo.moveTo 5 20 Cairo.setFontSize 20 Cairo.setSourceRGB 0 0 0 - Cairo.showText $ - formatDiffTime "Time (sec): %-2Es" t + Cairo.showText (printf "Time (sec): %.4fs" (diffTimeToSeconds t) :: String) layoutLabel :: Int -> String -> Layout (VizRender model) layoutLabel size label = From e3e02f55627ed90bbb662b99d971b46f56e6a249 Mon Sep 17 00:00:00 2001 From: Wen Kokke Date: Wed, 18 Dec 2024 15:31:14 +0000 Subject: [PATCH 3/3] Tiny cleanup --- simulation/src/LeiosProtocol/Short/SimP2P.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/simulation/src/LeiosProtocol/Short/SimP2P.hs b/simulation/src/LeiosProtocol/Short/SimP2P.hs index 9a843f31..c8ae41fc 100644 --- a/simulation/src/LeiosProtocol/Short/SimP2P.hs +++ b/simulation/src/LeiosProtocol/Short/SimP2P.hs @@ -6,6 +6,10 @@ 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), @@ -13,14 +17,8 @@ import Control.Tracer as 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 @@ -28,6 +26,7 @@ import LeiosProtocol.Short.Sim import P2P (P2PTopography (..)) import SimTCPLinks (labelDirToLabelLink, mkTcpConnProps, selectTimedEvents, simTracer) import SimTypes +import System.Random (StdGen, split) traceLeiosP2P :: StdGen ->