simulation: Run fourmolu and HLint (#110)

simulation/src/ChanDriver.hs

@@ -1,7 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes #-}
@@ -10,6 +8,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
 
 module ChanDriver where
 

simulation/src/ChanMux.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTSyntax #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -21,21 +20,34 @@ module ChanMux (
   newConnectionBundleTCP,
 ) where
 
-import Data.Array
-import Data.Dynamic
-import Data.Maybe
-
-import Control.Concurrent.Class.MonadMVar
-import Control.Concurrent.Class.MonadSTM
-import Control.Monad
-import Control.Monad.Class.MonadAsync
-import Control.Monad.Class.MonadFork
-import Control.Monad.Class.MonadTimer
-import Control.Tracer
-
 import Chan
 import ChanTCP
 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 TimeCompat
 
 class MuxBundle bundle where
@@ -146,7 +158,7 @@ demuxer bearer queues =
     BearerMsg i msg <- readChan bearer
     case queues ! i of
       RecvQueue convert queue ->
-        atomically $ writeTQueue queue $! (convert msg)
+        atomically $ writeTQueue queue $! convert msg
 
 newConnectionBundleTCP ::
   forall bundle m.

simulation/src/ChanTCP.hs

@@ -11,6 +11,7 @@ module ChanTCP (
   TcpConnProps (..),
 ) where
 
+import Chan (Chan (..))
 import Control.Concurrent.Class.MonadSTM (
   MonadSTM (
     TMVar,
@@ -45,8 +46,6 @@ import Control.Tracer as Tracer (
  )
 import Data.PQueue.Prio.Min (MinPQueue)
 import qualified Data.PQueue.Prio.Min as PQ
-
-import Chan (Chan (..))
 import ModelTCP (
   Bytes,
   TcpConnProps (..),

simulation/src/ExamplesRelay.hs

@@ -1,11 +1,10 @@
 module ExamplesRelay where
 
 import Data.Word (Word8)
-import System.Random (mkStdGen, uniform)
-
 import RelayProtocol
 import SimRelay
 import SimTCPLinks (kilobytes, mkTcpConnProps)
+import System.Random (mkStdGen, uniform)
 import Viz
 import VizSimRelay
 

simulation/src/ExamplesRelayP2P.hs

@@ -4,14 +4,13 @@ module ExamplesRelayP2P where
 
 import Data.Functor.Contravariant (Contravariant (contramap))
 import Data.Word (Word8)
-import System.Random (mkStdGen, uniform)
-
 import P2P (P2PTopographyCharacteristics (..), genArbitraryP2PTopography)
 import RelayProtocol
 import SimRelay
 import SimRelayP2P
 import SimTCPLinks (kilobytes, mkTcpConnProps)
 import SimTypes
+import System.Random (mkStdGen, uniform)
 import Viz
 import VizSimRelay (relaySimVizModel)
 import VizSimRelayP2P

simulation/src/ExamplesTCP.hs

@@ -6,11 +6,10 @@ 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 System.Random (mkStdGen, random)
-
 import ModelTCP
 import PlotTCP
 import SimTCPLinks
+import System.Random (mkStdGen, random)
 import Viz
 import VizChart
 import VizSim

simulation/src/LeiosProtocol/Common.hs

@@ -2,13 +2,9 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE NoFieldSelectors #-}
 
 module LeiosProtocol.Common (
@@ -191,7 +187,7 @@ data VoteMsg = VoteMsg
   }
   deriving stock (Eq, Show)
 
-data Certificate = Certificate
+newtype Certificate = Certificate
   { votes :: Map VoteId Word64
   }
   deriving stock (Show, Eq, Generic)

simulation/src/LeiosProtocol/Relay.hs

@@ -882,7 +882,7 @@ relayConsumerPipelined config sst =
           buffer4 =
             forceElemsToWHNF $
               buffer3
-                <> Map.fromList (zip live (repeat Nothing))
+                <> Map.fromList (map (,Nothing) live)
 
       -- if lst.window has duplicated ids, we might submit duplicated blocks.
       unless (null bodiesToSubmit) $ do
@@ -927,7 +927,7 @@ relayConsumerPipelined config sst =
 
       availableIdsU =
         Map.filterWithKey
-          (\txid _ -> notElem txid lst.window)
+          (\txid _ -> txid `notElem` lst.window)
           idsMap
 
       available' = lst.available <> Map.intersection availableIdsMp availableIdsU
@@ -958,7 +958,7 @@ relayConsumerPipelined config sst =
         forceElemsToWHNF $
           Foldable.foldl'
             ( \m txid ->
-                if elem txid window''
+                if txid `elem` window''
                   then m
                   else Map.delete txid m
             )

simulation/src/LeiosProtocol/Short.hs

@@ -1,12 +1,8 @@
-{-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE NoFieldSelectors #-}
 
 module LeiosProtocol.Short where
@@ -15,7 +11,12 @@ import Control.Exception (assert)
 import Control.Monad (guard)
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
-import Data.Maybe
+import Data.Maybe (
+  fromMaybe,
+  isNothing,
+  mapMaybe,
+  maybeToList,
+ )
 import LeiosProtocol.Common
 import ModelTCP
 import Prelude hiding (id)
@@ -151,9 +152,9 @@ stageRange cfg = stageRange' cfg.sliceLength
 stageRange' :: Int -> Stage -> SlotNo -> Stage -> Maybe (SlotNo, SlotNo)
 stageRange' l s0 slot s = slice l slot (fromEnum s0 - fromEnum s)
 
-stageRange'_prop :: Int -> SlotNo -> Bool
-stageRange'_prop l slot =
-  and [fromMaybe False $ (slot `inRange`) <$> stageRange' l stage slot stage | stage <- stages]
+prop_stageRange' :: Int -> SlotNo -> Bool
+prop_stageRange' l slot =
+  and [Just True == ((slot `inRange`) <$> stageRange' l stage slot stage) | stage <- stages]
     && and [contiguous $ mapMaybe (stageRange' l stage slot) stages | stage <- stages]
  where
   stages = [minBound .. maxBound]
@@ -176,12 +177,12 @@ isStage cfg stage slot = fromEnum slot >= cfg.sliceLength * fromEnum stage
 ----------------------------------------------------------------------------------------------
 
 mkRankingBlockBody :: LeiosConfig -> NodeId -> Maybe (EndorseBlockId, Certificate) -> Bytes -> RankingBlockBody
-mkRankingBlockBody cfg nodeId ebs payload = assert (isNothing ebs || messageSizeBytes rb >= segmentSize) $ rb
+mkRankingBlockBody cfg nodeId ebs payload = assert (isNothing ebs || messageSizeBytes rb >= segmentSize) rb
  where
   rb =
     fixSize cfg $
       RankingBlockBody
-        { endorseBlocks = maybe [] (: []) ebs
+        { endorseBlocks = maybeToList ebs
         , payload
         , nodeId
         , size = 0
@@ -199,7 +200,7 @@ mkInputBlockHeader cfg id slot subSlot producer rankingBlock =
   fixSize cfg $ InputBlockHeader{size = 0, ..}
 
 mkInputBlock :: LeiosConfig -> InputBlockHeader -> Bytes -> InputBlock
-mkInputBlock _cfg header bodySize = assert (messageSizeBytes ib >= segmentSize) $ ib
+mkInputBlock _cfg header bodySize = assert (messageSizeBytes ib >= segmentSize) ib
  where
   ib = InputBlock{header, body = InputBlockBody{id = header.id, size = bodySize, slot = header.slot}}
 
@@ -236,11 +237,11 @@ data NewInputBlockData = NewInputBlockData
   , txsPayload :: Bytes
   }
 
-data InputBlocksSnapshot = InputBlocksSnapshot
+newtype InputBlocksSnapshot = InputBlocksSnapshot
   { validInputBlocks :: InputBlocksQuery -> [InputBlockId]
   }
 
-data EndorseBlocksSnapshot = EndorseBlocksSnapshot
+newtype EndorseBlocksSnapshot = EndorseBlocksSnapshot
   { validEndorseBlocks :: (SlotNo, SlotNo) -> [EndorseBlock]
   }
 
@@ -301,7 +302,7 @@ shouldVoteOnEB cfg slot buffers = cond
     assumptions =
       null eb.endorseBlocksEarlierStage
         && null eb.endorseBlocksEarlierPipeline
-        && eb.slot `inRange` (fromMaybe (error "impossible") $ stageRange cfg Vote slot Endorse)
+        && eb.slot `inRange` fromMaybe (error "impossible") (stageRange cfg Vote slot Endorse)
     -- A. all referenced IBs have been received by the end of the Endorse stage,
     -- C. all referenced IBs validate (wrt. script execution), and,
     -- D. only IBs from this pipeline’s Propose stage are referenced (and not from other pipelines).

simulation/src/LeiosProtocol/Short/Generate.hs

@@ -5,25 +5,34 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE NoFieldSelectors #-}
 
 module LeiosProtocol.Short.Generate where
 
-import Control.Monad.State
-
 import Control.Concurrent.Class.MonadSTM (
   MonadSTM (..),
  )
 import Control.Exception (assert)
 import Control.Monad (forM)
-import Data.Bifunctor
-import Data.Kind
-import Data.Maybe (fromMaybe)
+import Control.Monad.State (
+  MonadState (get, put),
+  MonadTrans (lift),
+  StateT (runStateT),
+  gets,
+  runState,
+ )
+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
+import System.Random (StdGen, uniformR)
+
+--------------------------------------------------------------------------------
+
+{-# ANN module ("HLint: ignore Use <$>" :: String) #-}
+
+--------------------------------------------------------------------------------
 
 data BuffersView m = BuffersView
   { newRBData :: STM m NewRankingBlockData
@@ -58,9 +67,9 @@ mkScheduler rng0 rates = do
   rngVar <- newTVarIO rng0
   let sched slot = atomically $ do
         rng <- readTVar rngVar
-        let (acts, rng1) = flip runState rng . fmap concat . mapM sampleRates $ (rates slot)
+        let (acts, rng1) = flip runState rng . fmap concat . mapM sampleRates $ rates slot
         writeTVar rngVar rng1
-        return $ acts
+        return acts
   return sched
 
 -- | @waitNextSlot cfg targetSlot@ waits until the beginning of
@@ -105,23 +114,23 @@ blockGenerator BlockGeneratorConfig{..} = go (0, 0)
   execute slot (SomeRole r, wins) = assert (wins >= 1) $ second (SomeAction r) <$> execute' slot r wins
   execute' :: SlotNo -> Role a -> Word64 -> StateT Int m ([CPUTask], a)
   execute' slot Base _wins = do
-    rbData <- lift $ atomically $ buffers.newRBData
+    rbData <- lift $ atomically buffers.newRBData
     let meb = rbData.freshestCertifiedEB
-    let !task = CPUTask $ fromMaybe 0 $ leios.delays.certificateCreation . snd <$> meb
+    let !task = CPUTask $ maybe 0 (leios.delays.certificateCreation . snd) meb
     let body = mkRankingBlockBody leios nodeId meb rbData.txsPayload
     let !rb = mkPartialBlock slot body
     return ([task], rb)
   execute' slot Propose wins =
     ([],) <$> do
-      ibData <- lift $ atomically $ buffers.newIBData
+      ibData <- lift $ atomically buffers.newIBData
       forM [toEnum $ fromIntegral sub | sub <- [0 .. wins - 1]] $ \sub -> do
         i <- nextBlkId InputBlockId
         let header = mkInputBlockHeader leios i slot sub nodeId ibData.referenceRankingBlock
         return $! mkInputBlock leios header ibData.txsPayload
   execute' slot Endorse _wins =
     ([],) <$> do
       i <- nextBlkId EndorseBlockId
-      ibs <- lift $ atomically $ buffers.ibs
+      ibs <- lift $ atomically buffers.ibs
       return $! mkEndorseBlock leios i slot nodeId $ inputBlocksToEndorse leios slot ibs
   execute' slot Vote votes =
     ([],) <$> do