fix several NoThunks issues:

fraser-iohk · fraser-iohk · commit d72c567ce7a0 · 2024-07-09T17:33:08.000+01:00
- cdbLoE -&gt; !cdbLoE

- swap String for Text in Fuse

- tblcForecastRange :: Maybe SlotNo -&gt; tblcForecastRange :: !(StrictMaybe SlotNo)
- tblcHardForkParams :: EraParams -&gt; tblcHardForkParams :: !EraParams

- use `newUncheckedTVarM` in Test.Consensus.BlockChainTime.Simple

- LoEEnabled a -&gt; LoEEnabled !a

- newState -&gt; !newState in LeakyBucket

- add bangs to all fields of TestBlockWith

- csLatestSlot :: Maybe (WithOrigin SlotNo) -&gt; csLatestSlot :: !(StrictMaybe (WithOrigin SlotNo))
diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
@@ -275,6 +275,7 @@ test-suite consensus-test
     bytestring,
     cardano-crypto-class,
     cardano-slotting:{cardano-slotting, testlib},
+    cardano-strict-containers,
     containers,
     contra-tracer,
     directory,
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs
@@ -18,6 +18,7 @@ import           Data.List.NonEmpty (nonEmpty)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           Data.Semigroup (Endo (..))
 import           Data.Set (Set, (\\))
 import qualified Data.Set as Set
@@ -141,7 +142,7 @@ prop_densityDisconnectStatic =
     mkState frag =
       ChainSyncState {
         csCandidate = frag,
-        csLatestSlot = Just (AF.headSlot frag),
+        csLatestSlot = SJust (AF.headSlot frag),
         csIdling = False
       }
     gen = do
@@ -377,7 +378,7 @@ evolveBranches EvolvingPeers {k, sgen, peers = initialPeers, fullTree} =
             ChainSyncState {
               csCandidate,
               csIdling = False,
-              csLatestSlot = Just (AF.headSlot csCandidate)
+              csLatestSlot = SJust (AF.headSlot csCandidate)
             }
         -- Run GDD.
         (loeFrag, suffixes) = sharedCandidatePrefix curChain candidates
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Config.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Config.hs
@@ -5,6 +5,7 @@ module Test.Consensus.PeerSimulator.Config (defaultCfg) where
 import           Cardano.Crypto.DSIGN (SignKeyDSIGN (..), VerKeyDSIGN (..))
 import           Cardano.Slotting.Time (SlotLength, slotLengthFromSec)
 import qualified Data.Map.Strict as Map
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           Ouroboros.Consensus.Config (SecurityParam, TopLevelConfig (..),
                      emptyCheckpointsMap)
 import           Ouroboros.Consensus.HardFork.History
@@ -39,7 +40,7 @@ defaultCfg secParam (ForecastRange sfor) sgen = TopLevelConfig {
       , (CoreId (CoreNodeId 1), VerKeyMockDSIGN 1)
       ]
     }
-  , topLevelConfigLedger      = TestBlockLedgerConfig eraParams (Just $ fromIntegral sfor)
+  , topLevelConfigLedger      = TestBlockLedgerConfig eraParams (SJust (fromIntegral sfor))
   , topLevelConfigBlock       = TestBlockConfig numCoreNodes
   , topLevelConfigCodec       = TestBlockCodecConfig
   , topLevelConfigStorage     = TestBlockStorageConfig
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs
@@ -37,7 +37,7 @@ module Ouroboros.Consensus.Genesis.Governor (
 import           Control.Monad (guard)
 import           Control.Tracer (Tracer, traceWith)
 import           Data.Containers.ListUtils (nubOrd)
-import           Data.Foldable (for_)
+import           Data.Foldable (for_, toList)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (maybeToList)
@@ -212,7 +212,7 @@ densityDisconnect (GenesisWindow sgen) (SecurityParam k) states candidateSuffixe
       state <- maybeToList (states Map.!? peer)
       -- Skip peers that haven't sent any headers yet.
       -- They should be disconnected by timeouts instead.
-      latestSlot <- maybeToList (csLatestSlot state)
+      latestSlot <- toList (csLatestSlot state)
       let candidateSuffix = candidateSuffixes Map.! peer
 
           idling = csIdling state
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
@@ -80,6 +80,7 @@ import           Data.Kind (Type)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           Data.Proxy
 import           Data.Typeable
 import           Data.Word (Word64)
@@ -349,7 +350,7 @@ bracketChainSyncClient
               csvSetCandidate =
               modifyTVar csHandleState . \ c s -> s {csCandidate = c}
             , csvSetLatestSlot =
-              modifyTVar csHandleState . \ ls s -> s {csLatestSlot = Just $! ls}
+              modifyTVar csHandleState . \ ls s -> s {csLatestSlot = SJust ls}
             , csvIdling = Idling {
                 idlingStart = atomically $ modifyTVar csHandleState $ \ s -> s {csIdling = True}
               , idlingStop = atomically $ modifyTVar csHandleState $ \ s -> s {csIdling = False}
@@ -365,7 +366,7 @@ bracketChainSyncClient
     mkChainSyncClientHandleState =
       newTVarIO ChainSyncState {
           csCandidate = AF.Empty AF.AnchorGenesis
-        , csLatestSlot = Nothing
+        , csLatestSlot = SNothing
         , csIdling = False
         }
 
@@ -1001,7 +1002,7 @@ findIntersectionTop cfgEnv dynEnv intEnv =
                 map castPoint
               $ AF.selectPoints (map fromIntegral offsets) ourFrag
 
-            uis = UnknownIntersectionState {
+            !uis = UnknownIntersectionState {
                 ourFrag               = ourFrag
               , ourHeaderStateHistory = ourHeaderStateHistory
               , uBestBlockNo
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs
@@ -167,6 +167,7 @@ import           Data.List (sortOn)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (catMaybes, fromMaybe)
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block (HasHeader (getHeaderFields), Header,
                      Point (..), castPoint, pointSlot, succWithOrigin)
@@ -587,7 +588,7 @@ processJumpResult context jumpResult =
     updateChainSyncState handle jump = do
       let fragment = jTheirFragment jump
       modifyTVar (cschState handle) $ \csState ->
-        csState {csCandidate = fragment, csLatestSlot = Just (AF.headSlot fragment) }
+        csState {csCandidate = fragment, csLatestSlot = SJust (AF.headSlot fragment) }
       writeTVar (cschJumpInfo handle) $ Just jump
 
     mkGoodJumpInfo :: Maybe (JumpInfo blk) -> JumpInfo blk -> JumpInfo blk
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs
@@ -21,6 +21,7 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State (
 
 import           Cardano.Slotting.Slot (SlotNo, WithOrigin)
 import           Data.Function (on)
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           Data.Typeable (Proxy (..), typeRep)
 import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block (HasHeader, Header, Point)
@@ -56,7 +57,7 @@ data ChainSyncState blk = ChainSyncState {
     -- processing it further, and the latest slot may refer to a header beyond
     -- the forecast horizon while the candidate fragment isn't extended yet, to
     -- signal to GDD that the density is known up to this slot.
-  , csLatestSlot :: !(Maybe (WithOrigin SlotNo))
+  , csLatestSlot :: !(StrictMaybe (WithOrigin SlotNo))
   }
   deriving stock (Generic)
 
@@ -131,15 +132,15 @@ data ChainSyncJumpingState m blk
     -- honest, but the goal of the algorithm is to eventually have an honest,
     -- alert peer as dynamo.
     Dynamo
-      (DynamoInitState blk)
+      !(DynamoInitState blk)
       -- | The last slot at which we triggered jumps for the jumpers.
       !(WithOrigin SlotNo)
   | -- | The objector, of which there is at most one, also runs normal
     -- ChainSync. It is a former jumper that disagreed with the dynamo. When
     -- that happened, we spun it up to let normal ChainSync and Genesis decide
     -- which one to disconnect from.
     Objector
-      ObjectorInitState
+      !ObjectorInitState
       -- | The youngest point where the objector agrees with the dynamo.
       !(JumpInfo blk)
       -- | The point where the objector dissented with the dynamo when it was a
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
@@ -887,7 +887,7 @@ data LoE a =
   -- When the selection's tip is @k@ blocks after the earliest intersection of
   -- of all candidate fragments, ChainSel will not add new blocks to the
   -- selection.
-  LoEEnabled a
+  LoEEnabled !a
   deriving (Eq, Show, Generic, NoThunks, Functor, Foldable, Traversable)
 
 type GetLoEFragment m blk = LoE (m (AnchoredFragment (Header blk)))
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
@@ -268,7 +268,7 @@ data ChainDbEnv m blk = CDB
     -- The number of blocks from the future is bounded by the number of
     -- upstream peers multiplied by the max clock skew divided by the slot
     -- length.
-  , cdbLoE             :: LoE (m (AnchoredFragment (Header blk)))
+  , cdbLoE             :: !(LoE (m (AnchoredFragment (Header blk))))
     -- ^ Configure the Limit on Eagerness. If this is 'LoEEnabled', it contains
     -- an action that returns the LoE fragment, which indicates the latest rollback
     -- point, i.e. we are not allowed to select a chain from which we could not
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs
@@ -97,6 +97,7 @@ import           Data.List.NonEmpty (NonEmpty (..), (<|))
 import           Data.Maybe (fromMaybe)
 import           Data.Set (Set)
 import qualified Data.Set as Set
+import           Data.Text (Text)
 import           Data.Void
 import           Data.Word (Word64)
 import           GHC.Generics (Generic)
@@ -414,11 +415,11 @@ electric :: m a -> Electric m a
 electric = Electric
 
 -- | A simple semaphore, though instead of blocking a fatal exception is thrown.
-data Fuse m = Fuse !String !(StrictMVar m ()) deriving (Generic)
+data Fuse m = Fuse !Text !(StrictMVar m ()) deriving (Generic)
 
 deriving instance NoThunks (StrictMVar m ()) => NoThunks (Fuse m)
 
-newFuse :: MonadMVar m => String -> m (Fuse m)
+newFuse :: MonadMVar m => Text -> m (Fuse m)
 newFuse name = Fuse name <$> newMVar ()
 
 -- | Put full load on the 'Fuse' while the 'Electric' is running.
@@ -446,6 +447,6 @@ withFuse (Fuse name m) (Electric io) = do
   pure a
 
 -- | Too much electrical load was put on the 'Fuse', see 'withFuse'.
-newtype FuseBlownException  = FuseBlownException  String
+newtype FuseBlownException = FuseBlownException Text
  deriving (Show)
  deriving anyclass (Exception)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/LeakyBucket.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/LeakyBucket.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns         #-}
 {-# LANGUAGE DeriveAnyClass       #-}
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE FlexibleContexts     #-}
@@ -257,7 +258,7 @@ snapshotFill bucket toAdd = do
         levelFilled = min capacity (levelLeaked + toAdd)
         overflew = levelLeaked + toAdd > capacity
         newLevel = if not overflew || fillOnOverflow then levelFilled else levelLeaked
-        newState = State {time = newTime, level = newLevel, paused, config}
+        !newState = State {time = newTime, level = newLevel, paused, config}
     writeTVar bucket newState
     pure (newState, if overflew then Overflew else DidNotOverflow)
 
diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs
@@ -98,6 +98,7 @@ import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
+import           Data.Maybe.Strict (StrictMaybe (..), strictMaybeToMaybe)
 import           Data.Proxy
 import           Data.Time.Calendar (fromGregorian)
 import           Data.Time.Clock (UTCTime (..))
@@ -213,17 +214,17 @@ data Validity = Valid | Invalid
 -- instance. See the former class for more details.
 --
 data TestBlockWith ptype = TestBlockWith {
-      tbHash    :: TestHash
-    , tbSlot    :: SlotNo
+      tbHash    :: !TestHash
+    , tbSlot    :: !SlotNo
       -- ^ We store a separate 'Block.SlotNo', as slots can have gaps between
       -- them, unlike block numbers.
       --
       -- Note that when generating a 'TestBlock', you must make sure that
       -- blocks with the same 'TestHash' have the same slot number.
-    , tbValid   :: Validity
+    , tbValid   :: !Validity
       -- ^ Note that when generating a 'TestBlock', you must make sure that
       -- blocks with the same 'TestHash' have the same value for 'tbValid'.
-    , tbPayload :: ptype
+    , tbPayload :: !ptype
     }
   deriving stock    (Show, Eq, Ord, Generic)
   deriving anyclass (Serialise, NoThunks, ToExpr)
@@ -547,16 +548,16 @@ testInitExtLedgerWithState st = ExtLedgerState {
     }
 
 data TestBlockLedgerConfig = TestBlockLedgerConfig {
-  tblcHardForkParams :: HardFork.EraParams,
+  tblcHardForkParams :: !HardFork.EraParams,
   -- | `Nothing` means an infinite forecast range.
   -- Instead of SlotNo, it should be something like "SlotRange"
-  tblcForecastRange  :: Maybe SlotNo
+  tblcForecastRange  :: !(StrictMaybe SlotNo)
 }
   deriving (Show, Eq, Generic)
   deriving anyclass (NoThunks)
 
 testBlockLedgerConfigFrom :: HardFork.EraParams -> TestBlockLedgerConfig
-testBlockLedgerConfigFrom eraParams = TestBlockLedgerConfig eraParams Nothing
+testBlockLedgerConfigFrom eraParams = TestBlockLedgerConfig eraParams SNothing
 
 type instance LedgerCfg (LedgerState (TestBlockWith ptype)) = TestBlockLedgerConfig
 
@@ -592,7 +593,7 @@ instance (PayloadSemantics ptype) => ValidateEnvelope (TestBlockWith ptype) wher
 instance (PayloadSemantics ptype) => LedgerSupportsProtocol (TestBlockWith ptype) where
   protocolLedgerView   _ _  = ()
   ledgerViewForecastAt cfg state =
-    constantForecastInRange (tblcForecastRange cfg) () (getTipSlot state)
+    constantForecastInRange (strictMaybeToMaybe (tblcForecastRange cfg)) () (getTipSlot state)
 
 singleNodeTestConfigWith ::
      CodecConfig (TestBlockWith ptype)
@@ -624,7 +625,7 @@ singleNodeTestConfigWith codecConfig storageConfig k genesisWindow = TopLevelCon
     ledgerCfgParams :: TestBlockLedgerConfig
     ledgerCfgParams = TestBlockLedgerConfig {
       tblcHardForkParams = HardFork.defaultEraParams k slotLength,
-      tblcForecastRange = Nothing
+      tblcForecastRange = SNothing
     }
 
     _eraParams :: HardFork.EraParams
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs
@@ -335,7 +335,7 @@ testOverrideDelay systemStart slotLength maxClockRewind numSlots = do
                       maxClockRewind)
       (\_btime   -> pure ())
       $ \btime   -> do
-      slotsVar <- newTVarIO []
+      slotsVar <- uncheckedNewTVarM []
       withWatcher
         "testOverrideDelay"
         ( knownSlotWatcher btime $ \slotNo -> do
