Enable warnings and fix them all

cardano-byron-proxy.cabal

@@ -15,16 +15,16 @@ extra-source-files:  ChangeLog.md
 cabal-version:       >=1.10
 
 library
-  exposed-modules:     Ouroboros.Byron.Proxy.DB,
-                       Ouroboros.Byron.Proxy.Pool,
-                       Ouroboros.Byron.Proxy.Main,
+  exposed-modules:     Ouroboros.Byron.Proxy.DB
+                       Ouroboros.Byron.Proxy.Pool
+                       Ouroboros.Byron.Proxy.Main
 
-                       Ouroboros.Byron.Proxy.Index.Sqlite,
-                       Ouroboros.Byron.Proxy.Index.Types,
+                       Ouroboros.Byron.Proxy.Index.Sqlite
+                       Ouroboros.Byron.Proxy.Index.Types
 
-                       Ouroboros.Byron.Proxy.ChainSync.Client,
-                       Ouroboros.Byron.Proxy.ChainSync.Server,
-                       Ouroboros.Byron.Proxy.ChainSync.Types,
+                       Ouroboros.Byron.Proxy.ChainSync.Client
+                       Ouroboros.Byron.Proxy.ChainSync.Server
+                       Ouroboros.Byron.Proxy.ChainSync.Types
 
                        Ouroboros.Byron.Proxy.Network.Protocol
   -- other-modules:
@@ -66,8 +66,13 @@ library
                        unliftio-core
   hs-source-dirs:      src/lib
   default-language:    Haskell2010
-  ghc-options:         -fwarn-incomplete-patterns
+  ghc-options:         -Wall
+                       -Wcompat
+                       -fwarn-redundant-constraints
+                       -fwarn-incomplete-patterns
                        -fwarn-unused-imports
+                       -Wincomplete-record-updates
+                       -Wincomplete-uni-patterns
 
 executable cardano-byron-proxy
   main-is:             Main.hs
@@ -113,12 +118,18 @@ executable cardano-byron-proxy
   -- -threaded is needed or else the diffusion layer will crash, due to a use
   -- of registerDelay
   ghc-options:         -threaded
+                       -Wall
+                       -Wcompat
+                       -fwarn-redundant-constraints
                        -fwarn-incomplete-patterns
                        -fwarn-unused-imports
+                       -Wincomplete-record-updates
+                       -Wincomplete-uni-patterns
 
 executable validator
   main-is:             Validator.hs
   other-modules:       Logging
+                       Orphans
   -- other-extensions:
   build-depends:       base,
                        cardano-byron-proxy,
@@ -143,5 +154,10 @@ executable validator
   -- -threaded is needed or else the diffusion layer will crash, due to a use
   -- of registerDelay
   ghc-options:         -threaded
+                       -Wall
+                       -Wcompat
+                       -fwarn-redundant-constraints
                        -fwarn-incomplete-patterns
                        -fwarn-unused-imports
+                       -Wincomplete-record-updates
+                       -Wincomplete-uni-patterns

src/exec/Byron.hs

@@ -161,8 +161,8 @@ announce tracer mHashOfLatest db bp = do
     DB.TipEBB   _ _ _     -> pure mHashOfLatest
     -- Main blocks must be decoded to CSL blocks.
     DB.TipBlock _   bytes -> case CSL.decodeFull bytes of
-      Left txt                               -> error "announce: could not decode block"
-      Right (Left (ebb :: CSL.GenesisBlock)) -> error "announce: ebb where block expected"
+      Left _txt                               -> error "announce: could not decode block"
+      Right (Left (_ebb :: CSL.GenesisBlock)) -> error "announce: ebb where block expected"
       Right (Right (blk :: CSL.MainBlock))   -> do
         let header = blk ^. CSL.gbHeader
             hash   = Just (CSL.headerHash header)

src/exec/DB.hs

@@ -55,7 +55,7 @@ withDB dbOptions tracer k = do
       fsMountPoint = MountPoint (dbFilePath dbOptions)
       fs :: HasFS IO HandleIO
       fs = ioHasFS fsMountPoint
-      getEpochSize epoch = pure $ Immutable.EpochSize $
+      getEpochSize _epoch = pure $ Immutable.EpochSize $
         fromIntegral (Cardano.unEpochSlots (slotsPerEpoch dbOptions))
   epochInfo <- Immutable.newEpochInfo getEpochSize
   let openImmutableDB = Immutable.openDB

src/exec/Orphans.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Orphans where
 

src/exec/Shelley/Client.hs

@@ -80,8 +80,8 @@ runClient options tracer epochSlots db = do
           }
           where
           hhash = case Binary.decodeFullAnnotatedBytes (Text.pack "Block or boundary") (Cardano.fromCBORABlockOrBoundary epochSlots) bytes of
-            Left cborError -> error "failed to decode block"
-            Right blk -> case blk of
+            Left _cborError -> error "failed to decode block"
+            Right block -> case block of
               Cardano.ABOBBoundary _ -> error "Corrupt DB: expected block but got EBB"
               Cardano.ABOBBlock blk  -> Cardano.blockHashAnnotated blk
       case mPoint of

src/exec/Validator.hs

@@ -30,10 +30,7 @@ import Ouroboros.Byron.Proxy.ChainSync.Types as ChainSync (Block)
 import Ouroboros.Network.Socket
 import Ouroboros.Byron.Proxy.Network.Protocol
 
--- For orphan instances
-import qualified Control.Monad.Class.MonadThrow as NonStandard
-import qualified Control.Monad.Catch as Standard
-
+import Orphans ()
 import qualified Logging
 
 -- | Assumes there will never be a roll back. Validates each block that
@@ -69,7 +66,7 @@ clientFold tracer genesisConfig stopCondition cvs = Client.Fold $ pure $ Client.
       Right cvs' -> do
         maybeStop <- lift $ stopCondition block
         case maybeStop of
-          Just t -> pure $ Client.Stop ()
+          Just _ -> pure $ Client.Stop ()
           Nothing -> Client.runFold $ clientFold tracer genesisConfig stopCondition cvs'
   )
   (\_ _ -> error "got rollback")
@@ -169,17 +166,3 @@ main = do
       (initiatorVersions epochSlots client)
       (Just addrInfoLocal)
       addrInfoRemote
-
--- Orphan, forced upon me because of the IO sim stuff.
--- Required because we use ResourceT in the chain sync server, and `runPeer`
--- demands this non-standard `MonadThrow`. That could be fixed by returning
--- the failure reason rather than throwing it...
-
-instance NonStandard.MonadThrow (ResourceT IO) where
-  throwM = Standard.throwM
-  -- There's a default definition fo this which requires
-  -- NonStandard.MonadCatch (ResourceT IO). To avoid having to give those,
-  -- we'll just use the standard definition.
-  -- NB: it's weird huh? This implementation uses the _standard_ MonadMask
-  -- constraint, but the non-standard one is not defined.
-  bracket = Standard.bracket

src/lib/Ouroboros/Byron/Proxy/ChainSync/Server.hs

@@ -227,7 +227,7 @@ chainSyncServerIdle epochSlots err poll db ss = case ss of
                     pure Nothing
                   -- EBBs come out of the DB with their hash so we can just
                   -- compare on that.
-                  DB.NextEBB epoch hash bytes iterator' -> do
+                  DB.NextEBB _epoch hash _bytes iterator' -> do
                     -- DB guarantees that `hash = pointHash point`.
                     pure $ Just (pointSlot point, hash, iterator', releaseKey)
                   -- The DB does not check that the hash matches, if the item is
@@ -303,7 +303,7 @@ chainSyncServerIdle epochSlots err poll db ss = case ss of
               Left cborError -> lift $ err cborError
               Right ablk -> case Binary.unAnnotated ablk of
                 Cardano.ABOBBlock _ -> error "Corrupt DB: block where EBB expected"
-                Cardano.ABOBBoundary ebb -> do
+                Cardano.ABOBBoundary _ebb -> do
                   dbTip <- lift $ DB.readTip db
                   tipPoint' <- lift $ pickBetterTip epochSlots err tipPoint dbTip
                   let ss' = KnownTip tipPoint' (Just (Point slot hash)) (Just (iterator', releaseKey))

src/lib/Ouroboros/Byron/Proxy/DB.hs

@@ -67,7 +67,7 @@ epochFileParser epochSlots hasFS =
        (cborEpochFileParser' hasFS decoder hashOfEBB)
   where
   takeSlot :: Cardano.ABlockOrBoundary a -> SlotNo
-  takeSlot blk = case blk of
+  takeSlot block = case block of
     Cardano.ABOBBlock    blk -> SlotNo $ Cardano.unSlotNumber (Cardano.blockSlot blk)
     Cardano.ABOBBoundary ebb -> SlotNo $ Cardano.boundaryEpoch ebb * Cardano.unEpochSlots epochSlots
   decoder :: forall s . CBOR.Decoder s (Cardano.ABlockOrBoundary ByteSpan)
@@ -147,8 +147,8 @@ conduitFromIterator
   :: ( Monad m )
   => Iterator m
   -> ConduitT () DBRead m ()
-conduitFromIterator iterator = do
-  step <- lift $ next iterator
+conduitFromIterator iter = do
+  step <- lift $ next iter
   case step of
     Done -> pure ()
     NextBlock slot bytes iterator' -> do
@@ -254,7 +254,7 @@ dbAppendImpl
   -> IndexWrite m
   -> ImmutableDB Cardano.HeaderHash m
   -> DBAppend m
-dbAppendImpl err tracer epochSlots iwrite idb = DBAppend $ \blockToWrite -> do
+dbAppendImpl _err tracer epochSlots iwrite idb = DBAppend $ \blockToWrite -> do
   -- Must serialise as a `Block` rather than a `MainBlock` or `GenesisBlock`,
   -- because the epoch file parser needs to be able to discriminate them.
   let builder = case blockToWrite of
@@ -263,7 +263,7 @@ dbAppendImpl err tracer epochSlots iwrite idb = DBAppend $ \blockToWrite -> do
         CardanoBlockToWrite (Annotated _ bytes) ->
           Builder.byteString bytes
   slotNo <- case blockToWrite of
-    LegacyBlockToWrite b@(Left ebb) -> do
+    LegacyBlockToWrite (Left ebb) -> do
       -- Write the index first, so that if something goes wrong with the
       -- `appendEBB` to the `ImmutableDB`, the transaction will quit and the
       -- index/db will remain consistent.
@@ -273,7 +273,7 @@ dbAppendImpl err tracer epochSlots iwrite idb = DBAppend $ \blockToWrite -> do
       Index.updateTip iwrite hash epoch Index.EBBSlot
       Immutable.appendEBB idb epoch (coerceHashFromLegacy hash) builder
       pure slot
-    LegacyBlockToWrite b@(Right blk) -> do
+    LegacyBlockToWrite (Right blk) -> do
       let hash = CSL.headerHash blk
           (epoch, SlotNo wslot) = blockEpochAndRelativeSlot blk
           slot = SlotNo $ unEpochNo epoch * Cardano.unEpochSlots epochSlots + wslot
@@ -317,7 +317,7 @@ readFromImpl
   -> ImmutableDB Cardano.HeaderHash m
   -> Point
   -> m (IteratorResource m)
-readFromImpl err epochSlots idx idb point = case point of
+readFromImpl _err epochSlots idx idb point = case point of
   FromGenesis -> iteratorFromSlot Nothing
   -- Slot is given: just take an iterator from the `ImmutableDB`.
   FromPoint slot hash -> iteratorFromSlot (Just (slot, hash))
@@ -361,7 +361,7 @@ readTipImpl
   -> Index m
   -> ImmutableDB Cardano.HeaderHash m
   -> m Tip
-readTipImpl err epochSlots idx idb = do
+readTipImpl _err epochSlots _idx idb = do
   tip <- Immutable.getTip idb
   case tip of
     -- Empty DB. Hm...

src/lib/Ouroboros/Byron/Proxy/Main.hs

@@ -171,22 +171,22 @@ deriving instance Show Atom
 -- make and deposit an `Atom` into a queue.
 
 sendAtomToByron :: Diffusion IO -> Atom -> IO ()
-sendAtomToByron diffusion atom = case atom of
+sendAtomToByron diff atom = case atom of
 
-  Transaction tx -> void $ sendTx diffusion (getTxMsgContents tx)
+  Transaction tx -> void $ sendTx diff (getTxMsgContents tx)
 
-  UpdateProposal (up, uvs) -> sendUpdateProposal diffusion (hash up) up uvs
-  UpdateVote uv            -> sendVote diffusion uv
+  UpdateProposal (up, uvs) -> sendUpdateProposal diff (hash up) up uvs
+  UpdateVote uv            -> sendVote diff uv
 
-  Opening (MCOpening sid opening)      -> sendSscOpening diffusion sid opening
-  Shares (MCShares sid shares)         -> sendSscShares diffusion sid shares
-  VssCertificate (MCVssCertificate vc) -> sendSscCert diffusion (getCertId vc) vc
-  Commitment (MCCommitment commitment) -> sendSscCommitment diffusion sid commitment
+  Opening (MCOpening sid opening)      -> sendSscOpening diff sid opening
+  Shares (MCShares sid shares)         -> sendSscShares diff sid shares
+  VssCertificate (MCVssCertificate vc) -> sendSscCert diff (getCertId vc) vc
+  Commitment (MCCommitment commitment) -> sendSscCommitment diff sid commitment
     where
     (pk, _, _) = commitment
     sid = addressHash pk
 
-  Delegation psk -> sendPskHeavy diffusion psk
+  Delegation psk -> sendPskHeavy diff psk
 
 -- | Information about the best tip from the Byron network.
 data BestTip tip = BestTip
@@ -254,11 +254,11 @@ bbsStreamBlocks db onErr hh k = bracket (DB.readFrom db (DB.FromHash hh)) DB.clo
       Nothing -> pure ()
       Just (DB.ReadEBB slot _ bytes) -> case decodeFull bytes of
         Left err -> lift $ onErr slot err
-        Right (Right blk :: Block) -> lift $ onErr slot "block where EBB expected"
+        Right (Right _blk :: Block) -> lift $ onErr slot "block where EBB expected"
         Right (Left ebb  :: Block) -> yield (Left ebb)  >> decode
       Just (DB.ReadBlock slot bytes) -> case decodeFull bytes of
         Left err -> lift $ onErr slot err
-        Right (Left ebb  :: Block) -> lift $ onErr slot "EBB where block expected"
+        Right (Left _ebb  :: Block) -> lift $ onErr slot "EBB where block expected"
         Right (Right blk :: Block) -> yield (Right blk) >> decode
 
 bbsGetSerializedBlock
@@ -417,7 +417,7 @@ withByronProxy
   -> DB IO
   -> (ByronProxy -> IO t)
   -> IO t
-withByronProxy trace bpc db k =
+withByronProxy trace bpc db act =
   -- Create pools for all relayed data.
   -- TODO what about for delegation certificates?
   withPool (bpcPoolRoundInterval bpc) $ \(txPool :: TxPool) ->
@@ -441,10 +441,10 @@ withByronProxy trace bpc db k =
     atomSendQueue :: TBQueue Atom <- newTBQueueIO (bpcSendQueueSize bpc)
 
     let byronProxy :: Diffusion IO -> ByronProxy
-        byronProxy diffusion = ByronProxy
+        byronProxy diff = ByronProxy
           { bestTip = takeBestTip
-          , downloadChain = streamBlocks diffusion
-          , announceChain = announceBlockHeader diffusion
+          , downloadChain = streamBlocks diff
+          , announceChain = announceBlockHeader diff
           , recvAtom = readTBQueue atomRecvQueue
           , sendAtom = writeTBQueue atomSendQueue
           }
@@ -453,10 +453,10 @@ withByronProxy trace bpc db k =
         takeBestTip = readTVar tipsTVar
 
         sendingThread :: forall x . Diffusion IO -> IO x
-        sendingThread diffusion = do
+        sendingThread diff = do
           atom <- atomically $ readTBQueue atomSendQueue
-          sendAtomToByron diffusion atom
-          sendingThread diffusion
+          sendAtomToByron diff atom
+          sendingThread diff
 
         blockDecodeError :: forall x . SlotNo -> Text -> IO x
         blockDecodeError slot text = throwIO $ MalformedBlock slot text
@@ -539,7 +539,7 @@ withByronProxy trace bpc db k =
                 DB.TipGenesis -> do
                   traceWith trace (Error, "getTip: empty database")
                   throwIO $ EmptyDatabaseError
-                DB.TipEBB slot hash bytes -> case decodeFull bytes of
+                DB.TipEBB slot _hash bytes -> case decodeFull bytes of
                   Left cborError -> do
                     traceWith trace (Error, "getTip: malformed EBB")
                     throwIO $ MalformedBlock slot cborError
@@ -551,7 +551,7 @@ withByronProxy trace bpc db k =
                   Left cborError -> do
                     traceWith trace (Error, "getTip: malformed block")
                     throwIO $ MalformedBlock slot cborError
-                  Right (Left ebb) -> do
+                  Right (Left _ebb) -> do
                     traceWith trace (Error, "getTip: EBB where block expected")
                     throwIO $ MalformedBlock slot "EBB where block expected"
                   Right (Right blk :: Block) -> pure $ Right blk
@@ -583,4 +583,4 @@ withByronProxy trace bpc db k =
 
     diffusionLayerFull fdconf networkConfig Nothing mkLogic $ \diffusionLayer -> do
       runDiffusionLayer diffusionLayer $ withAsync (sendingThread (diffusion diffusionLayer)) $
-        \_ -> k (byronProxy (diffusion diffusionLayer))
+        \_ -> act (byronProxy (diffusion diffusionLayer))

src/lib/Ouroboros/Byron/Proxy/Network/Protocol.hs

@@ -67,10 +67,10 @@ instance MiniProtocolLimits Ptcl where
   maximumIngressQueue = const 0xffffffff
 
 initiatorVersions
-  :: ( Monad m, MonadST m, MonadUnliftIO m, MonadThrow m, MonadThrow (ResourceT m) )
+  :: ( MonadST m, MonadUnliftIO m, MonadThrow (ResourceT m) )
   => Cardano.EpochSlots -- ^ Needed for the codec, sadly
   -> ChainSyncClient Block Point (ResourceT m) ()
-  -> Versions VNumber (CodecCBORTerm Text) (MuxApplication InitiatorApp Ptcl m LBS.ByteString () Void)
+  -> Versions VNumber (CodecCBORTerm Text) (MuxApplication 'InitiatorApp Ptcl m LBS.ByteString () Void)
 initiatorVersions epochSlots client = Versions $ Map.fromList
   [ (VNumber 0, Sigma () (Version clientMuxApp unitCodecCBORTerm))
   ]
@@ -81,10 +81,10 @@ initiatorVersions epochSlots client = Versions $ Map.fromList
     PtclChainSync -> runResourceT $ runPeer nullTracer codec (hoistChannel lift channel) clientPeer
 
 responderVersions
-  :: ( Monad m, MonadST m, MonadUnliftIO m, MonadThrow m, MonadThrow (ResourceT m) )
+  :: ( MonadST m, MonadUnliftIO m, MonadThrow (ResourceT m) )
   => Cardano.EpochSlots -- ^ Needed for the codec; must match that of the initiator.
   -> ChainSyncServer Block Point (ResourceT m) ()
-  -> Versions VNumber (CodecCBORTerm Text) (MuxApplication ResponderApp Ptcl m LBS.ByteString Void ())
+  -> Versions VNumber (CodecCBORTerm Text) (MuxApplication 'ResponderApp Ptcl m LBS.ByteString Void ())
 responderVersions epochSlots server = Versions $ Map.fromList
   [ (VNumber 0, Sigma () (Version serverMuxApp unitCodecCBORTerm))
   ]

stack.yaml

@@ -123,6 +123,8 @@ extra-deps:
   - ekg-wai-0.1.0.3
   - lzma-clib-5.2.2
 
+ghc-options:
+  cardano-byron-proxy:     -Wall -Werror -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-patterns -fwarn-unused-imports -Wincomplete-record-updates -Wincomplete-uni-patterns
 
 nix:
   shell-file: nix/stack-shell.nix