simulation: Enforce consistent use of imports using HLint

.github/workflows/ci.yaml

@@ -117,6 +117,22 @@ jobs:
             exit 1
           fi
 
+  hlint-check:
+    name: Check Haskell sources with HLint
+    runs-on: ubuntu-22.04
+    steps:
+      - name: 📥 Checkout repository
+        uses: actions/checkout@v4
+
+      - name: "Set up HLint"
+        uses: haskell-actions/hlint-setup@v2
+
+      - name: "Run HLint"
+        uses: haskell-actions/hlint-run@v2
+        with:
+          path: simulation/
+          fail-on: warning
+
   fourmolu-check:
     name: Check Haskell sources with fourmolu
     runs-on: ubuntu-22.04

.hlint.yaml

@@ -0,0 +1,89 @@
+# HLint configuration file
+# https://github.com/ndmitchell/hlint
+##########################
+
+# This file contains a template configuration file, which is typically
+# placed as .hlint.yaml in the root of your project
+
+# Specify additional command line arguments
+#
+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
+
+# Control which extensions/flags/modules/functions can be used
+#
+# - extensions:
+#   - default: false # all extension are banned by default
+#   - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
+#   - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
+#
+# - flags:
+#   - {name: -w, within: []} # -w is allowed nowhere
+#
+# - modules:
+#   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
+#   - {name: Control.Arrow, within: []} # Certain modules are banned entirely
+#
+# - functions:
+#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
+- modules:
+    # Ensure that MonadDelay is imported from TimeCompat
+    - name:
+        - "Control.Monad.Class.MonadTime"
+        - "Control.Monad.Class.MonadTime.SI"
+      within: "TimeCompat"
+      message: "Use TimeCompat instead"
+    # Ensure that Ouroboros.Network primitives are imported from PraosProtocol.Common hierarchy
+    - name: "Ouroboros.Network.AnchoredFragment"
+      within: "PraosProtocol.Common.AnchoredFragment"
+      message: "Use PraosProtocol.Common.AnchoredFragment instead"
+    - name: "Ouroboros.Network.Mock.Chain"
+      within: "PraosProtocol.Common.Chain"
+      message: "Use PraosProtocol.Common.Chain instead"
+    - name: "Ouroboros.Network.Block"
+      within: "PraosProtocol.Common.ConcreteBlock"
+      message: "Use PraosProtocol.Common.ConcreteBlock instead"
+    - name: "Ouroboros.Network.*"
+      within:
+        - "PraosProtocol.Common"
+        - "PraosProtocol.Common.ConcreteBlock"
+      message: "Use PraosProtocol.Common instead"
+    # Ensure that PraosProtocol.Common hierarchy is only used from PraosProtocol
+    - name: "PraosProtocol.Common"
+      within:
+        - "PraosProtocol.**"
+        - "LeiosProtocol.Common"
+# Add custom hints for this project
+#
+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
+
+# The hints are named by the string they display in warning messages.
+# For example, if you see a warning starting like
+#
+# Main.hs:116:51: Warning: Redundant ==
+#
+# You can refer to that hint with `{name: Redundant ==}` (see below).
+
+# Turn on hints that are off by default
+#
+# Ban "module X(module X) where", to require a real export list
+# - warn: {name: Use explicit module export list}
+#
+# Replace a $ b $ c with a . b $ c
+# - group: {name: dollar, enabled: true}
+#
+# Generalise map to fmap, ++ to <>
+# - group: {name: generalise, enabled: true}
+#
+# Warn on use of partial functions
+# - group: {name: partial, enabled: true}
+
+# Ignore some builtin hints
+# - ignore: {name: Use let}
+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
+
+# Define some custom infix operators
+# - fixity: infixr 3 ~^#^~
+
+# To generate a suitable file for HLint do:
+# $ hlint --default > .hlint.yaml

simulation/ouroboros-leios-sim.cabal

@@ -67,10 +67,6 @@ library
     PraosProtocol.BlockFetch
     PraosProtocol.BlockGeneration
     PraosProtocol.ChainSync
-    PraosProtocol.Common
-    PraosProtocol.Common.AnchoredFragment
-    PraosProtocol.Common.Chain
-    PraosProtocol.ConcreteBlock
     PraosProtocol.ExamplesPraosP2P
     PraosProtocol.PraosNode
     PraosProtocol.SimBlockFetch
@@ -81,10 +77,15 @@ library
     PraosProtocol.VizSimChainSync
     PraosProtocol.VizSimPraos
     PraosProtocol.VizSimPraosP2P
+    PraosProtocol.Common
+    PraosProtocol.Common.AnchoredFragment
+    PraosProtocol.Common.Chain
+    PraosProtocol.Common.ConcreteBlock
     RelayProtocol
     Sample
     SimRelay
     SimRelayP2P
+    STMUtils
     SimTCPLinks
     SimTypes
     TimeCompat

simulation/src/ChanTCP.hs

@@ -31,14 +31,6 @@ import Control.Concurrent.Class.MonadSTM (
 import Control.Exception (assert)
 import Control.Monad (when)
 import Control.Monad.Class.MonadAsync (MonadAsync (async))
-import Control.Monad.Class.MonadTime.SI (
-  DiffTime,
-  MonadMonotonicTime (..),
-  MonadTime,
-  Time,
-  diffTime,
- )
-import Control.Monad.Class.MonadTimer (MonadDelay)
 import Control.Tracer as Tracer (
   Contravariant (contramap),
   Tracer,
@@ -56,7 +48,7 @@ import ModelTCP (
   initTcpState,
   saneTcpState,
  )
-import TimeCompat (threadDelaySI)
+import TimeCompat
 
 -- | In the scope of a two party connection, there are just two peers. These
 -- can be maped to a wider scope peer identity via contra-trace.

simulation/src/ExamplesTCP.hs

@@ -2,14 +2,14 @@
 
 module ExamplesTCP where
 
-import Control.Monad.Class.MonadTime.SI (DiffTime, Time)
 import Data.Functor.Contravariant (Contravariant (contramap))
 import Data.Word (Word8)
 import qualified Graphics.Rendering.Chart.Easy as Chart
 import ModelTCP
 import PlotTCP
 import SimTCPLinks
 import System.Random (mkStdGen, random)
+import TimeCompat
 import Viz
 import VizChart
 import VizSim

simulation/src/LeiosProtocol/Common.hs

@@ -9,8 +9,6 @@
 
 module LeiosProtocol.Common (
   module PraosProtocol.Common,
-  module Block,
-  module TimeCompat,
   RankingBlockHeader,
   RankingBlockBody (..),
   RankingBlock,
@@ -41,27 +39,9 @@ import Data.Map (Map)
 import Data.Word (Word64, Word8)
 import GHC.Generics
 import GHC.Records
-import Ouroboros.Network.Block as Block
-import PraosProtocol.Common (
-  ChainHash (..),
-  MessageSize (..),
-  PraosConfig (..),
-  ReadOnly,
-  SlotConfig (..),
-  TakeOnly,
-  asReadOnly,
-  asTakeOnly,
-  kilobytes,
-  readReadOnlyTVar,
-  readReadOnlyTVarIO,
-  slotConfigFromNow,
-  slotTime,
-  takeTakeOnlyTMVar,
-  tryTakeTakeOnlyTMVar,
- )
-import qualified PraosProtocol.Common as Praos
+import PraosProtocol.Common hiding (Block, BlockHeader)
+import qualified PraosProtocol.Common as Praos (Block, BlockHeader)
 import SimTypes
-import TimeCompat
 
 {-
   Note [size of blocks/messages]: we add a `size` field to most

simulation/src/LeiosProtocol/Relay.hs

@@ -50,6 +50,7 @@ import Data.Type.Equality ((:~:) (Refl))
 import Data.Unit.Strict (forceElemsToWHNF)
 import Data.Word (Word16)
 import GHC.Generics (Generic)
+import LeiosProtocol.Common
 import LeiosProtocol.RelayBuffer (RelayBuffer)
 import qualified LeiosProtocol.RelayBuffer as RB
 import Network.TypedProtocol (
@@ -65,8 +66,8 @@ import Network.TypedProtocol (
 import qualified Network.TypedProtocol.Peer.Client as TC
 import qualified Network.TypedProtocol.Peer.Server as TS
 import NoThunks.Class (NoThunks)
-import PraosProtocol.Common
 import Quiet (Quiet (..))
+import STMUtils
 
 data BlockingStyle
   = StBlocking

simulation/src/LeiosProtocol/Short/Generate.hs

@@ -25,7 +25,6 @@ import Data.Bifunctor (Bifunctor (..))
 import Data.Kind (Type)
 import LeiosProtocol.Common
 import LeiosProtocol.Short hiding (Stage (..))
-import PraosProtocol.Common (CPUTask (CPUTask), mkPartialBlock)
 import System.Random (StdGen, uniformR)
 
 --------------------------------------------------------------------------------

simulation/src/LeiosProtocol/Short/Node.hs

@@ -37,10 +37,14 @@ import LeiosProtocol.Short.Generate
 import qualified LeiosProtocol.Short.Generate as Generate
 import ModelTCP
 import Numeric.Natural (Natural)
-import PraosProtocol.BlockFetch
-import PraosProtocol.Common
-import PraosProtocol.Common.Chain (dropUntil, headAnchor, headHash)
+import PraosProtocol.BlockFetch (
+  BlockFetchControllerState (blocksVar),
+  addProducedBlock,
+  processWaiting,
+ )
+import qualified PraosProtocol.Common.Chain as Chain
 import qualified PraosProtocol.PraosNode as PraosNode
+import STMUtils
 import System.Random
 
 --------------------------------------------------------------
@@ -486,7 +490,7 @@ generator tracer cfg st = do
       case x of
         SomeAction Generate.Base rb0 -> do
           rb <- atomically $ do
-            ha <- headAnchor <$> PraosNode.preferredChain st.praosState
+            ha <- Chain.headAnchor <$> PraosNode.preferredChain st.praosState
             let rb = fixupBlock ha rb0
             addProducedBlock st.praosState.blockFetchControllerState rb
             return rb
@@ -534,7 +538,7 @@ mkBuffersView cfg st = BuffersView{..}
   newIBData = do
     ledgerState <- readTVar st.ledgerStateVar
     referenceRankingBlock <-
-      headHash . dropUntil (flip Map.member ledgerState . blockHash)
+      Chain.headHash . Chain.dropUntil (flip Map.member ledgerState . blockHash)
         <$> PraosNode.preferredChain st.praosState
     let txsPayload = cfg.inputBlockPayload
     return $ NewInputBlockData{referenceRankingBlock, txsPayload}

simulation/src/LeiosProtocol/Short/Sim.hs

@@ -26,8 +26,6 @@ import qualified Data.Set as Set
 import LeiosProtocol.Common hiding (Point)
 import LeiosProtocol.Short
 import LeiosProtocol.Short.Node
-import PraosProtocol.Common (defaultPraosConfig)
-import PraosProtocol.Common.Chain (Chain (..))
 import SimTCPLinks
 import SimTypes
 import System.Random (mkStdGen)

simulation/src/LeiosProtocol/Short/SimP2P.hs

@@ -21,12 +21,11 @@ import ChanTCP
 import Control.Monad (forever)
 import Control.Monad.Class.MonadFork (MonadFork (forkIO))
 import qualified Data.Map.Strict as M
+import LeiosProtocol.Common
 import LeiosProtocol.Short
 import LeiosProtocol.Short.Node
 import LeiosProtocol.Short.Sim
 import P2P (P2PTopography (..))
-import PraosProtocol.Common
-import PraosProtocol.Common.Chain (Chain (..))
 import SimTCPLinks (labelDirToLabelLink, mkTcpConnProps, selectTimedEvents, simTracer)
 import SimTypes
 

simulation/src/LeiosProtocol/Short/VizSim.hs

@@ -32,7 +32,6 @@ import LeiosProtocol.Short.Sim (LeiosEvent (..), LeiosTrace, exampleTrace1)
 import ModelTCP
 import Network.TypedProtocol
 import P2P (linkPathLatenciesSquared)
-import PraosProtocol.Common hiding (Point)
 import PraosProtocol.PraosNode (PraosMessage (..))
 import qualified PraosProtocol.VizSimPraos as VizSimPraos
 import SimTypes
@@ -184,7 +183,7 @@ accumNodeCpuUsage (Time now) (LeiosEventNode (LabelNode nid (LeiosNodeEventCPU t
   Map.insertWith ILMap.union nid (ILMap.singleton (ClosedInterval now (now + cpuTaskDuration task)) 1)
 accumNodeCpuUsage _ _ = id
 
-type ChainsMap = IntMap (Chain (Block RankingBlockBody))
+type ChainsMap = IntMap (Chain RankingBlock)
 
 accumChains :: Time -> LeiosEvent -> ChainsMap -> ChainsMap
 accumChains _ (LeiosEventNode (LabelNode nid (PraosNodeEvent (PraosNodeEventNewTip ch)))) = IMap.insert (coerce nid) ch

simulation/src/LeiosProtocol/Short/VizSimP2P.hs

@@ -9,26 +9,24 @@
 
 module LeiosProtocol.Short.VizSimP2P where
 
+import ChanDriver
+import Control.Arrow ((&&&))
 import Data.Array.Unboxed (Ix, UArray, accumArray, (!))
+import Data.Bifunctor (second)
 import qualified Data.Colour.SRGB as Colour
+import Data.Hashable (hash)
+import Data.List (foldl', intercalate, sortOn)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (catMaybes, fromMaybe, maybeToList)
+import Data.Monoid (Any)
+import Diagrams ((#))
 import qualified Diagrams.Backend.Cairo as Dia
 import qualified Diagrams.Backend.Cairo.Internal as Dia
 import qualified Diagrams.Core as Dia
-import qualified Diagrams.TwoD as Dia
-import qualified Graphics.Rendering.Cairo as Cairo
-import qualified Graphics.Rendering.Chart.Easy as Chart
-
-import ChanDriver
-import Control.Arrow ((&&&))
-import Data.Bifunctor (second)
-import Data.Hashable (hash)
-import Data.List (foldl', intercalate, sortOn)
-import Data.Monoid
-import Diagrams ((#))
 import qualified Diagrams.Prelude as Dia
 import qualified Diagrams.TwoD.Adjust as Dia
+import qualified Graphics.Rendering.Cairo as Cairo
+import qualified Graphics.Rendering.Chart.Easy as Chart
 import LeiosProtocol.Common hiding (Point)
 import LeiosProtocol.Relay
 import LeiosProtocol.Short
@@ -51,7 +49,6 @@ import ModelTCP (TcpMsgForecast (..))
 import Network.TypedProtocol
 import P2P
 import PraosProtocol.BlockFetch (Message (..))
-import PraosProtocol.Common (BlockHeader, FullTip (FullTip), blockHeaderColorAsBody)
 import PraosProtocol.PraosNode (PraosMessage (..))
 import SimTypes (Point (..), WorldShape (..))
 import System.Random (uniformR)
@@ -106,7 +103,7 @@ data MsgTag = RB | IB | EB | VT
 
 data LeiosP2PSimVizConfig
   = LeiosP2PSimVizConfig
-  { nodeMessageColor :: BlockHeader -> (Double, Double, Double)
+  { nodeMessageColor :: RankingBlockHeader -> (Double, Double, Double)
   , ibColor :: InputBlockHeader -> (Double, Double, Double)
   , ebColor :: EndorseBlock -> (Double, Double, Double)
   , voteColor :: VoteMsg -> (Double, Double, Double)
@@ -655,7 +652,7 @@ defaultVizConfig stageLength =
   relayMessageColor f (ProtocolMessage (SomeMessage msg)) = case msg of
     MsgRespondBodies bodies -> Just $ blendColors $ map (f . snd) bodies
     _otherwise -> Nothing
-  testNodeMessageColor :: BlockHeader -> (Double, Double, Double)
+  testNodeMessageColor :: RankingBlockHeader -> (Double, Double, Double)
   testNodeMessageColor = blockHeaderColorAsBody
   -- alternating cold and warm colours for visual contrast.
   palettes =