simulation: Export MonadSTM via STMCompat

Author: wenkokke

.hlint.yaml

@@ -32,6 +32,10 @@
         - "Control.Monad.Class.MonadTime.SI"
       within: "TimeCompat"
       message: "Use TimeCompat instead"
+    # Ensure that MonadSTM is imported from STMCompat
+    - name: "Control.Concurrent.Class.MonadSTM"
+      within: "STMCompat"
+      message: "Use STMCompat instead"
     # Ensure that Ouroboros.Network primitives are imported from PraosProtocol.Common hierarchy
     - name: "Ouroboros.Network.AnchoredFragment"
       within: "PraosProtocol.Common.AnchoredFragment"

simulation/ouroboros-leios-sim.cabal

@@ -85,7 +85,7 @@ library
     Sample
     SimRelay
     SimRelayP2P
-    STMUtils
+    STMCompat
     SimTCPLinks
     SimTypes
     TimeCompat

simulation/src/ChanMux.hs

@@ -26,28 +26,14 @@ import qualified Control.Category as Cat
 import Control.Concurrent.Class.MonadMVar (
   MonadMVar (MVar, newMVar, withMVar),
  )
-import Control.Concurrent.Class.MonadSTM (
-  MonadSTM (
-    TQueue,
-    TVar,
-    atomically,
-    modifyTVar,
-    newTQueueIO,
-    newTVarIO,
-    readTQueue,
-    readTVar,
-    readTVarIO,
-    writeTQueue,
-    writeTVar
-  ),
- )
 import Control.Monad (forever)
 import Control.Monad.Class.MonadAsync (MonadAsync)
 import Control.Monad.Class.MonadFork (MonadFork (forkIO))
 import Control.Tracer (Contravariant (contramap), Tracer)
 import Data.Array (Array, listArray, (!))
 import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn)
 import Data.Maybe (fromJust)
+import STMCompat
 import TimeCompat
 
 class MuxBundle bundle where

simulation/src/ChanTCP.hs

@@ -12,22 +12,6 @@ module ChanTCP (
 ) where
 
 import Chan (Chan (..))
-import Control.Concurrent.Class.MonadSTM (
-  MonadSTM (
-    TMVar,
-    TVar,
-    atomically,
-    modifyTVar',
-    newEmptyTMVarIO,
-    newTVarIO,
-    putTMVar,
-    readTMVar,
-    readTVar,
-    retry,
-    takeTMVar,
-    writeTVar
-  ),
- )
 import Control.Exception (assert)
 import Control.Monad (when)
 import Control.Monad.Class.MonadAsync (MonadAsync (async))
@@ -48,6 +32,7 @@ import ModelTCP (
   initTcpState,
   saneTcpState,
  )
+import STMCompat
 import TimeCompat
 
 -- | In the scope of a two party connection, there are just two peers. These

simulation/src/LeiosProtocol/Relay.hs

@@ -26,7 +26,6 @@ module LeiosProtocol.Relay where
 
 import Chan
 import ChanDriver (ProtocolMessage, chanDriver)
-import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
 import Control.DeepSeq (NFData)
 import Control.Exception (Exception, assert, throw)
 import Control.Monad (forM_, join, unless, void, when)
@@ -67,7 +66,7 @@ import qualified Network.TypedProtocol.Peer.Client as TC
 import qualified Network.TypedProtocol.Peer.Server as TS
 import NoThunks.Class (NoThunks)
 import Quiet (Quiet (..))
-import STMUtils
+import STMCompat
 
 data BlockingStyle
   = StBlocking

simulation/src/LeiosProtocol/Short/Generate.hs

@@ -9,9 +9,6 @@
 
 module LeiosProtocol.Short.Generate where
 
-import Control.Concurrent.Class.MonadSTM (
-  MonadSTM (..),
- )
 import Control.Exception (assert)
 import Control.Monad (forM)
 import Control.Monad.State (
@@ -25,6 +22,7 @@ import Data.Bifunctor (Bifunctor (..))
 import Data.Kind (Type)
 import LeiosProtocol.Common
 import LeiosProtocol.Short hiding (Stage (..))
+import STMCompat
 import System.Random (StdGen, uniformR)
 
 --------------------------------------------------------------------------------

simulation/src/LeiosProtocol/Short/Node.hs

@@ -13,7 +13,6 @@ module LeiosProtocol.Short.Node where
 import ChanMux
 import Control.Category ((>>>))
 import Control.Concurrent.Class.MonadMVar
-import Control.Concurrent.Class.MonadSTM
 import Control.Exception (assert)
 import Control.Monad (forever, guard, when)
 import Control.Monad.Class.MonadAsync
@@ -44,7 +43,7 @@ import PraosProtocol.BlockFetch (
  )
 import qualified PraosProtocol.Common.Chain as Chain
 import qualified PraosProtocol.PraosNode as PraosNode
-import STMUtils
+import STMCompat
 import System.Random
 
 --------------------------------------------------------------

simulation/src/LeiosProtocol/SimTestRelay.hs

@@ -14,22 +14,6 @@ import Chan
 import ChanMux
 import ChanTCP
 import Control.Category ((>>>))
-import Control.Concurrent.Class.MonadSTM (
-  MonadSTM (
-    STM,
-    TQueue,
-    TVar,
-    atomically,
-    modifyTVar',
-    newTQueueIO,
-    newTVarIO,
-    readTQueue,
-    readTVar,
-    retry,
-    writeTQueue,
-    writeTVar
-  ),
- )
 import Control.Exception (assert)
 import Control.Monad (forever, when)
 import Control.Monad.Class.MonadAsync (
@@ -52,7 +36,7 @@ import qualified Data.Set as Set
 import LeiosProtocol.Relay
 import LeiosProtocol.RelayBuffer (RelayBuffer)
 import qualified LeiosProtocol.RelayBuffer as RB
-import STMUtils
+import STMCompat
 import SimTCPLinks (labelDirToLabelLink, selectTimedEvents, simTracer)
 import SimTypes
 import System.Random (StdGen, uniform, uniformR)

simulation/src/PraosProtocol/BlockFetch.hs

@@ -24,9 +24,6 @@ module PraosProtocol.BlockFetch where
 
 import Chan (Chan)
 import ChanDriver (ProtocolMessage, chanDriver)
-import Control.Concurrent.Class.MonadSTM (
-  MonadSTM (..),
- )
 import Control.Exception (assert)
 import Control.Monad (forM, forever, guard, join, unless, void, when, (<=<))
 import Control.Tracer (Contravariant (contramap), Tracer, traceWith)
@@ -53,7 +50,7 @@ import Numeric.Natural (Natural)
 import PraosProtocol.Common
 import qualified PraosProtocol.Common.AnchoredFragment as AnchoredFragment
 import qualified PraosProtocol.Common.Chain as Chain
-import STMUtils
+import STMCompat
 
 data BlockFetchState (body :: Type)
   = StIdle

simulation/src/PraosProtocol/BlockGeneration.hs

@@ -6,14 +6,14 @@ module PraosProtocol.BlockGeneration where
 
 import Cardano.Slotting.Slot (WithOrigin (..))
 import ChanTCP (Bytes)
-import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
 import Control.Monad (forever)
 import Control.Tracer
 import Data.ByteString as BS
 import Data.ByteString.Char8 as BS8
 import Data.Word (Word64)
 import PraosProtocol.Common
 import qualified PraosProtocol.Common.Chain as Chain
+import STMCompat
 import System.Random (StdGen, uniformR)
 
 -- | Returns a block that can extend the chain.

simulation/src/PraosProtocol/ChainSync.hs

@@ -16,7 +16,6 @@ module PraosProtocol.ChainSync where
 
 import Chan (Chan)
 import ChanDriver (ProtocolMessage, chanDriver)
-import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
 import Control.Exception (assert)
 import Control.Monad (void)
 import Control.Tracer (Tracer, traceWith)
@@ -33,6 +32,7 @@ import qualified Network.TypedProtocol.Peer.Client as TC
 import qualified Network.TypedProtocol.Peer.Server as TS
 import PraosProtocol.Common
 import qualified PraosProtocol.Common.Chain as Chain
+import STMCompat
 
 --------------------------------
 ---- ChainSync

simulation/src/PraosProtocol/PraosNode.hs

@@ -9,7 +9,6 @@ module PraosProtocol.PraosNode (
 where
 
 import ChanMux
-import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
 import Control.Monad.Class.MonadAsync (Concurrently (..), MonadAsync (..))
 import Control.Tracer (Tracer)
 import Data.ByteString (ByteString)
@@ -23,7 +22,7 @@ import PraosProtocol.BlockGeneration
 import PraosProtocol.ChainSync (ChainConsumerState (..), ChainSyncMessage, runChainConsumer, runChainProducer)
 import PraosProtocol.Common
 import qualified PraosProtocol.Common.Chain as Chain (Chain (..))
-import STMUtils
+import STMCompat
 
 data Praos body f = Praos
   { protocolChainSync :: f ChainSyncMessage

simulation/src/PraosProtocol/SimBlockFetch.hs

@@ -5,7 +5,6 @@ module PraosProtocol.SimBlockFetch where
 import Chan (Chan)
 import ChanDriver (ProtocolMessage)
 import ChanTCP
-import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
 import Control.Monad.Class.MonadAsync (
   MonadAsync (..),
   mapConcurrently_,
@@ -23,7 +22,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import PraosProtocol.BlockFetch
 import PraosProtocol.Common hiding (Point)
-import STMUtils
+import STMCompat
 import SimTCPLinks
 import SimTypes
 

simulation/src/PraosProtocol/SimChainSync.hs

@@ -9,13 +9,12 @@ import ChanTCP (
   TcpEvent,
   newConnectionTCP,
  )
-import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
 import Control.Monad.Class.MonadAsync (
   MonadAsync (concurrently_),
  )
 import Control.Monad.IOSim as IOSim (IOSim, runSimTrace)
 import Control.Tracer as Tracer (
-  Contravariant (contramap),
+  Contravariant (..),
   Tracer (Tracer),
   traceWith,
  )
@@ -32,6 +31,7 @@ import PraosProtocol.ChainSync (
  )
 import PraosProtocol.Common hiding (Point)
 import qualified PraosProtocol.Common.Chain as Chain
+import STMCompat
 import SimTCPLinks (
   labelDirToLabelLink,
   mkTcpConnProps,

simulation/src/PraosProtocol/SimPraos.hs

@@ -10,12 +10,10 @@ module PraosProtocol.SimPraos where
 
 import ChanMux
 import ChanTCP
-import Control.Monad.Class.MonadAsync (
-  MonadAsync (concurrently_),
- )
+import Control.Monad.Class.MonadAsync (MonadAsync (..))
 import Control.Monad.IOSim as IOSim (IOSim, runSimTrace)
 import Control.Tracer as Tracer (
-  Contravariant (contramap),
+  Contravariant (..),
   Tracer,
   traceWith,
  )
@@ -25,7 +23,6 @@ import qualified Data.Map.Strict as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import PraosProtocol.Common hiding (Point)
-import PraosProtocol.Common.Chain (Chain (..))
 import PraosProtocol.PraosNode (PraosMessage, runPraosNode)
 import SimTCPLinks
 import SimTypes

simulation/src/RelayProtocol.hs

@@ -26,18 +26,6 @@ module RelayProtocol (
   relayClient,
 ) where
 
-import Control.Concurrent.Class.MonadSTM (
-  MonadSTM (
-    STM,
-    TVar,
-    atomically,
-    modifyTVar',
-    newTVarIO,
-    readTVar,
-    readTVarIO,
-    retry
-  ),
- )
 import Control.Exception (assert)
 import Control.Monad (when)
 import Data.FingerTree (FingerTree)
@@ -50,6 +38,7 @@ import qualified Data.Map.Strict as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Word (Word64)
+import STMCompat
 import TimeCompat
 
 import Chan (Chan (readChan, writeChan))

simulation/src/STMUtils.hs simulation/src/STMCompat.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module STMUtils (
+module STMCompat (
+  MonadSTM (..),
   ReadOnly,
   asReadOnly,
   readReadOnlyTVar,

simulation/src/SimRelay.hs

@@ -10,20 +10,6 @@
 
 module SimRelay where
 
-import Control.Concurrent.Class.MonadSTM (
-  MonadSTM (
-    STM,
-    TQueue,
-    atomically,
-    newTQueueIO,
-    newTVarIO,
-    readTQueue,
-    readTVar,
-    retry,
-    writeTQueue,
-    writeTVar
-  ),
- )
 import Control.Monad (forever)
 import Control.Monad.Class.MonadAsync (
   Concurrently (Concurrently, runConcurrently),
@@ -40,6 +26,7 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
+import STMCompat
 import System.Random (StdGen, uniform, uniformR)
 
 import Chan

simulation/src/SimTCPLinks.hs

@@ -6,9 +6,6 @@ module SimTCPLinks where
 
 import Chan
 import ChanTCP
-import Control.Concurrent.Class.MonadSTM (
-  MonadSTM (atomically, newTQueueIO, readTQueue, writeTQueue),
- )
 import Control.Monad (replicateM_)
 import Control.Monad.Class.MonadAsync (
   Concurrently (Concurrently, runConcurrently),
@@ -30,6 +27,7 @@ import Control.Tracer as Tracer (
 import Data.Bifoldable (Bifoldable (bifoldr))
 import Data.Dynamic (Typeable, fromDynamic)
 import ModelTCP
+import STMCompat
 import SimTypes
 import TimeCompat