Documentation generation.

cardano-node/src/Cardano/TraceDispatcher/ConsensusTracer/Combinators.hs

@@ -235,11 +235,13 @@ severityMempool ::
   -> SeverityS
 severityMempool _ = Info
 
+-- TODO: not working with undefines because of bang patterns
 namesForMempool :: TraceEventMempool blk -> [Text]
-namesForMempool TraceMempoolAddedTx {}            = ["AddedTx"]
-namesForMempool TraceMempoolRejectedTx {}         = ["RejectedTx"]
-namesForMempool TraceMempoolRemoveTxs {}          = ["RemoveTxs"]
-namesForMempool TraceMempoolManuallyRemovedTxs {} = ["ManuallyRemovedTxs"]
+-- namesForMempool (TraceMempoolAddedTx _ _ _)            = ["AddedTx"]
+-- namesForMempool TraceMempoolRejectedTx {}         = ["RejectedTx"]
+-- namesForMempool TraceMempoolRemoveTxs {}          = ["RemoveTxs"]
+-- namesForMempool TraceMempoolManuallyRemovedTxs {} = ["ManuallyRemovedTxs"]
+namesForMempool _            = []
 
 severityForge :: TraceLabelCreds (TraceForgeEvent blk) -> SeverityS
 severityForge (TraceLabelCreds _t e) = severityForge' e

cardano-node/src/Cardano/TraceDispatcher/ConsensusTracer/Docu.hs

@@ -37,7 +37,7 @@ import           Ouroboros.Consensus.Forecast (OutsideForecastRange)
 
 import           Ouroboros.Network.Block
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
-import           Ouroboros.Network.BlockFetch.Decision (FetchDecision)
+import           Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline(..))
 import           Ouroboros.Network.BlockFetch.DeltaQ
                      (PeerFetchInFlightLimits (..))
 import           Ouroboros.Network.Mux (ControlMessage)
@@ -49,12 +49,16 @@ import           Cardano.TraceDispatcher.OrphanInstances.Consensus ()
 import           Cardano.TraceDispatcher.OrphanInstances.Network ()
 import           Cardano.TraceDispatcher.OrphanInstances.Shelley ()
 
+
 protoHeader :: Header blk
 protoHeader = undefined
 
 protoPoint :: Point blk
 protoPoint = undefined
 
+protoPointH :: Point (Header blk)
+protoPointH = undefined
+
 protoOurTipBlock :: Our (Tip blk)
 protoOurTipBlock = undefined
 
@@ -67,7 +71,7 @@ protoChainSyncClientException = undefined
 protoChainSyncClientResult :: ChainSyncClientResult
 protoChainSyncClientResult = undefined
 
-protoChainUpdate :: ChainUpdate block a
+protoChainUpdate :: ChainUpdate blk a
 protoChainUpdate = undefined
 
 protoTip :: Tip blk
@@ -77,21 +81,21 @@ protoRemotePeer :: remotePeer
 protoRemotePeer = undefined
 
 protoFetchDecline :: FetchDecision [Point (Header blk)]
-protoFetchDecline = Left undefined
+protoFetchDecline = Left FetchDeclineChainNotPlausible
 
 protoFetchResult :: FetchDecision [Point (Header blk)]
-protoFetchResult = Right undefined
+protoFetchResult = Right [protoPointH]
 
-protoFetchRequest :: BlockFetch.FetchRequest header
+protoFetchRequest :: BlockFetch.FetchRequest (Header blk)
 protoFetchRequest = undefined
 
-protoPeerFetchInFlight :: BlockFetch.PeerFetchInFlight h
+protoPeerFetchInFlight :: BlockFetch.PeerFetchInFlight (Header blk)
 protoPeerFetchInFlight = undefined
 
 protoPeerFetchInFlightLimits :: PeerFetchInFlightLimits
 protoPeerFetchInFlightLimits = PeerFetchInFlightLimits 10 10
 
-protoPeerFetchStatus :: BlockFetch.PeerFetchStatus header
+protoPeerFetchStatus :: BlockFetch.PeerFetchStatus (Header blk)
 protoPeerFetchStatus = undefined
 
 protoChainRange :: BlockFetch.ChainRange (Point header)
@@ -109,15 +113,15 @@ protoTx = undefined
 protoTxId :: txId
 protoTxId = undefined
 
+protoGenTxId :: GenTxId txId
+protoGenTxId = undefined
+
 protoControlMessage :: ControlMessage
 protoControlMessage = undefined
 
 protoGenTx :: GenTx blk
 protoGenTx = undefined
 
-protoGenTxId :: GenTxId blk
-protoGenTxId = undefined
-
 protoMempoolSize :: MempoolSize
 protoMempoolSize = undefined
 
@@ -212,7 +216,7 @@ docBlockFetchDecision = Documented [
 
 
 docBlockFetchClient ::
-  Documented (BlockFetch.TraceLabelPeer remotePeer (BlockFetch.TraceFetchClientState header))
+  Documented (BlockFetch.TraceLabelPeer remotePeer (BlockFetch.TraceFetchClientState (Header blk)))
 docBlockFetchClient = Documented [
     DocMsg
       (BlockFetch.TraceLabelPeer protoRemotePeer
@@ -249,7 +253,7 @@ docBlockFetchClient = Documented [
     DocMsg
       (BlockFetch.TraceLabelPeer protoRemotePeer
         (BlockFetch.CompletedBlockFetch
-          protoPoint
+          protoPointH
           protoPeerFetchInFlight
           protoPeerFetchInFlightLimits
           protoPeerFetchStatus
@@ -332,7 +336,7 @@ docTxInbound = Documented [
     "TODO"
   ]
 
-docTxOutbound ::
+docTxOutbound :: forall remotePeer txid tx.
   Documented (BlockFetch.TraceLabelPeer remotePeer
     (TraceTxSubmissionOutbound txid tx))
 docTxOutbound = Documented [
@@ -386,7 +390,7 @@ docMempool = Documented [
       "Transactions that have been manually removed from the Mempool."
   ]
 
-docForge :: forall blk. Documented (TraceLabelCreds (TraceForgeEvent blk))
+docForge :: Documented (TraceLabelCreds (TraceForgeEvent blk))
 docForge = Documented [
     DocMsg
       (TraceLabelCreds protoTxt

cardano-node/src/Cardano/TraceDispatcher/ConsensusTracer/Formatting.hs

@@ -3,8 +3,8 @@
 {-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE DataKinds #-}
 
 {-# OPTIONS_GHC -Wno-orphans  #-}
 
@@ -26,8 +26,8 @@ import           Cardano.TraceDispatcher.Render
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Cardano.Block
-import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTxId,
-                     HasTxId)
+import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr,
+                     GenTxId, HasTxId)
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Mempool.API (MempoolSize (..),
                      TraceEventMempool (..))

cardano-node/src/Cardano/TraceDispatcher/Tracers.hs

@@ -219,7 +219,6 @@ mempoolTracer trBase = do
     pure $ withNamesAppended namesForMempool
             $ withSeverity severityMempool trNs
 
-
 forgeTracer ::
   (  HasTxId (GenTx blk)
   ,  LedgerSupportsProtocol blk
@@ -237,24 +236,29 @@ forgeTracer trBase = do
     pure $ withNamesAppended namesForForge
             $ withSeverity severityForge trNs
 
-docTracers :: forall remotePeer.
+docTracers :: forall blk remotePeer.
   ( Show remotePeer
-  , Show (GenTx ByronBlock)
-  , Show (ApplyTxErr ByronBlock)
-  , LogFormatting (ApplyTxErr ByronBlock)
-  , LogFormatting (GenTx ByronBlock)
-  , LogFormatting (CannotForge ByronBlock)
-  , LogFormatting (ForgeStateUpdateError ByronBlock)
-  , LogFormatting (ChainDB.InvalidBlockReason ByronBlock)
-  , ToJSON (GenTxId ByronBlock)
-  , HasTxId (GenTx ByronBlock)
-  , LedgerSupportsProtocol ByronBlock
-  , Consensus.SerialiseNodeToNodeConstraints ByronBlock
-  , Show (ForgeStateUpdateError ByronBlock)
-  , Show (CannotForge ByronBlock)
+  , Show (GenTx blk)
+  , Show (ApplyTxErr blk)
+  , Show (Header blk)
+  , LogFormatting (ApplyTxErr blk)
+  , LogFormatting (GenTx blk)
+  , LogFormatting (CannotForge blk)
+  , LogFormatting (ForgeStateUpdateError blk)
+  , LogFormatting (ChainDB.InvalidBlockReason blk)
+  , LogFormatting (LedgerUpdate blk)
+  , LogFormatting (LedgerWarning blk)
+  , LogFormatting (Header blk)
+  , ToJSON (GenTxId blk)
+  , HasTxId (GenTx blk)
+  , LedgerSupportsProtocol blk
+  , InspectLedger blk
+  , Consensus.SerialiseNodeToNodeConstraints blk
+  , Show (ForgeStateUpdateError blk)
+  , Show (CannotForge blk)
   )
-  => IO ()
-docTracers = do
+  => Proxy blk -> IO ()
+docTracers _ = do
   trBase <- standardTracer Nothing
 
   cdbmTr <- chainDBMachineTracer trBase
@@ -271,63 +275,64 @@ docTracers = do
 
   cdbmTrDoc    <- documentMarkdown
               (docChainDBTraceEvent :: Documented
-                (ChainDB.TraceEvent ByronBlock))
+                (ChainDB.TraceEvent blk))
               [cdbmTr]
   cscTrDoc    <- documentMarkdown
               (docChainSyncClientEvent :: Documented
-                (TraceChainSyncClientEvent ByronBlock))
+                (TraceChainSyncClientEvent blk))
               [cscTr]
   csshTrDoc    <- documentMarkdown
               (docChainSyncServerEvent :: Documented
-                (TraceChainSyncServerEvent ByronBlock))
+                (TraceChainSyncServerEvent blk))
               [csshTr]
   cssbTrDoc    <- documentMarkdown
               (docChainSyncServerEvent :: Documented
-                (TraceChainSyncServerEvent ByronBlock))
+                (TraceChainSyncServerEvent blk))
               [cssbTr]
-  _bfdTrDoc    <- documentMarkdown
+  bfdTrDoc    <- documentMarkdown
               (docBlockFetchDecision :: Documented
-                [BlockFetch.TraceLabelPeer remotePeer (FetchDecision [Point (Header ByronBlock)])])
+                [BlockFetch.TraceLabelPeer remotePeer (FetchDecision [Point (Header blk)])])
               [bfdTr]
   bfsTrDoc    <- documentMarkdown
               (docBlockFetchServer :: Documented
-                (TraceBlockFetchServerEvent ByronBlock))
+                (TraceBlockFetchServerEvent blk))
               [bfsTr]
   txiTrDoc    <- documentMarkdown
               (docTxInbound :: Documented
                 (BlockFetch.TraceLabelPeer remotePeer
-                  (TraceTxSubmissionInbound (GenTxId ByronBlock) (GenTx ByronBlock))))
+                  (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))))
               [txiTr]
   txoTrDoc    <- documentMarkdown
               (docTxOutbound :: Documented
                 (BlockFetch.TraceLabelPeer remotePeer
-                  (TraceTxSubmissionOutbound (GenTxId ByronBlock) (GenTx ByronBlock))))
+                  (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))))
               [txoTr]
   ltxsTrDoc    <- documentMarkdown
               (docLocalTxSubmissionServer :: Documented
-                (TraceLocalTxSubmissionServerEvent ByronBlock))
+                (TraceLocalTxSubmissionServerEvent blk))
               [ltxsTr]
-  _mpTrDoc    <- documentMarkdown
+  mpTrDoc    <- documentMarkdown
               (docMempool :: Documented
-                (TraceEventMempool ByronBlock))
+                (TraceEventMempool blk))
               [mpTr]
   fTrDoc    <- documentMarkdown
               (docForge :: Documented
-                (Consensus.TraceLabelCreds (Consensus.TraceForgeEvent ByronBlock)))
+                (Consensus.TraceLabelCreds (Consensus.TraceForgeEvent blk)))
               [fTr]
   let bl = cdbmTrDoc
-         ++ cscTrDoc
-         ++ csshTrDoc
-         ++ cssbTrDoc
-        -- ++ bfdTrDoc
-         ++ bfsTrDoc
-         ++ txiTrDoc
-         ++ txoTrDoc
-         ++ ltxsTrDoc
---         ++ mpTrDoc
-         ++ fTrDoc
-
-  T.writeFile "/home/yupanqui/IOHK/CardanoLogging.md" (buildersToText bl)
+          ++ cscTrDoc
+          ++ csshTrDoc
+          ++ cssbTrDoc
+          ++ bfdTrDoc
+          ++ bfsTrDoc
+          ++ txiTrDoc
+          ++ txoTrDoc
+          ++ ltxsTrDoc
+          ++ mpTrDoc
+          ++ fTrDoc
+  res <- buildersToText bl
+  T.writeFile "/home/yupanqui/IOHK/CardanoLogging.md" res
+  pure ()
 
 -- | Tracers for all system components.
 --

trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs

@@ -21,6 +21,7 @@ import           Data.Text.Internal.Builder (toLazyText)
 import           Data.Text.Lazy (toStrict)
 import           Data.Text.Lazy.Builder (Builder, fromString, fromText,
                      singleton)
+import           Data.Time (getZonedTime)
 
 documentTracers :: MonadIO m => Documented a -> [Trace m a] -> m DocCollector
 documentTracers (Documented documented) tracers = do
@@ -63,12 +64,17 @@ docIt backend formattedMessage (LoggingContext {..},
                         Nothing -> emptyLogDoc mdText))
         docMap)
 
-buildersToText :: [(Namespace, Builder)] -> Text
-buildersToText builderList =
+buildersToText :: [(Namespace, Builder)] -> IO Text
+buildersToText builderList = do
+  time <- getZonedTime
+--  tz   <- getTimeZone
   let sortedBuilders = sortBy (\ (l,_) (r,_) -> compare l r) builderList
-  in toStrict $ toLazyText
-      $ mconcat
-        $ intersperse (fromText "\n\n") (map snd sortedBuilders)
+      num = length builderList
+      content = mconcat $ intersperse (fromText "\n\n") (map snd sortedBuilders)
+      numbers = fromString $ "\n\n" <> show num <> " log messages."
+      ts      = fromString $ "\nGenerated at "
+                  <> show time <> "."
+  pure $ toStrict $ toLazyText (content <> numbers <> ts)
 
 documentMarkdown :: ({-LogFormatting a,-} MonadIO m) =>
      Documented a

trace-dispatcher/src/Cardano/Logging/Types.hs

@@ -6,8 +6,6 @@
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE TypeSynonymInstances       #-}
 
-
-
 module Cardano.Logging.Types (
     LogFormatting(..)
   , Metric(..)
@@ -64,21 +62,6 @@ class LogFormatting a where
   asMetrics :: a -> [Metric]
   asMetrics _v = []
 
-instance LogFormatting Double where
-  forMachine d _ = mkObject [ "val" .= A.String ((pack . show) d)]
-  forHuman d     = (pack . show) d
-  asMetrics d    = [DoubleM Nothing d]
-
-instance LogFormatting Int where
-  forMachine i _ = mkObject [ "val" .= A.String ((pack . show) i)]
-  forHuman i     = (pack . show) i
-  asMetrics i    = [IntM Nothing (fromIntegral i)]
-
-instance LogFormatting Integer where
-  forMachine i _ = mkObject [ "val" .= A.String ((pack . show) i)]
-  forHuman i     = (pack . show) i
-  asMetrics i    = [IntM Nothing i]
-
 data Metric
   -- | An integer metric.
   -- If a text is given it is appended as last element to the namespace
@@ -264,6 +247,21 @@ instance LogFormatting b => LogFormatting (Folding a b) where
   forHuman (Folding b)     =  forHuman b
   asMetrics (Folding b)    =  asMetrics b
 
+instance LogFormatting Double where
+  forMachine d _ = mkObject [ "val" .= A.String ((pack . show) d)]
+  forHuman d     = (pack . show) d
+  asMetrics d    = [DoubleM Nothing d]
+
+instance LogFormatting Int where
+  forMachine i _ = mkObject [ "val" .= A.String ((pack . show) i)]
+  forHuman i     = (pack . show) i
+  asMetrics i    = [IntM Nothing (fromIntegral i)]
+
+instance LogFormatting Integer where
+  forMachine i _ = mkObject [ "val" .= A.String ((pack . show) i)]
+  forHuman i     = (pack . show) i
+  asMetrics i    = [IntM Nothing i]
+
 instance A.ToJSON DetailLevel where
     toEncoding = A.genericToEncoding A.defaultOptions
 

trace-dispatcher/test/Examples/Documentation.hs

@@ -18,4 +18,5 @@ docTracer = do
   let t2 = withSeverityTraceForgeEvent
                 (appendName "node" t2')
   bl <- documentMarkdown traceForgeEventDocu [t1, t2]
-  T.writeFile "/home/yupanqui/IOHK/Testdocu.md" (buildersToText bl)
+  res <- buildersToText bl
+  T.writeFile "/home/yupanqui/IOHK/Testdocu.md" res