DocuGenerator (Markdown)

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

@@ -28,10 +28,10 @@ configureTracers config (Documented documented) tracers = do
     mapM_ (configureTrace Optimize) tracers
   where
     configureTrace c (Trace tr) =
-      T.traceWith tr (emptyLoggingContext, Just c, fst (head documented))
+      T.traceWith tr (emptyLoggingContext, Just c, dmPrototype (head documented))
     configureAllTrace c (Trace tr) =
       mapM
-        ((\ m -> T.traceWith tr (emptyLoggingContext, Just c, m)) . fst)
+        ((\ m -> T.traceWith tr (emptyLoggingContext, Just c, m)) . dmPrototype)
         documented
 
 -- | Take a selector function, and a function from trace to trace with

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

@@ -5,27 +5,33 @@
 
 module Cardano.Logging.DocuGenerator where
 
-
-import           Data.Text (Text)
-
 import           Cardano.Logging.Trace
 import           Cardano.Logging.Types
 import           Control.Monad.IO.Class (MonadIO, liftIO)
 import qualified Control.Tracer as T
-import           Data.IORef (IORef, modifyIORef, newIORef, writeIORef)
+import           Data.Aeson.Text (encodeToLazyText)
+import           Data.IORef (IORef, modifyIORef, newIORef, readIORef,
+                     writeIORef)
+import           Data.List (intersperse, nub, sortBy)
 import qualified Data.Map as Map
+import           Data.Text (Text)
+import           Data.Text.Internal.Builder (toLazyText)
+import           Data.Text.Lazy (toStrict)
+import           Data.Text.Lazy.Builder (Builder, fromString, fromText,
+                     singleton)
 
 documentTracers :: MonadIO m => Documented a -> [Trace m a] -> m DocCollector
 documentTracers (Documented documented) tracers = do
-    let docIdx = zip documented [1..]
+    let docIdx = zip documented [0..]
     coll <- fmap DocCollector (liftIO $ newIORef Map.empty)
     mapM_ (docTrace docIdx coll) tracers
     pure coll
   where
     docTrace docIdx docColl (Trace tr) =
       mapM_
-        (\ ((m,mdText), idx) -> do
-          T.traceWith tr (emptyLoggingContext, Just (Document idx mdText docColl), m))
+        (\ (DocMsg {..}, idx) -> do
+          T.traceWith tr (emptyLoggingContext {lcNamespace = [dmName]},
+                          Just (Document idx dmMarkdown docColl), dmPrototype))
         docIdx
 
 docIt :: MonadIO m =>
@@ -54,3 +60,136 @@ docIt backend logFormat (LoggingContext {..},
                         Just e  -> e
                         Nothing -> emptyLogDoc mdText))
         docMap)
+
+documentMarkdown :: (LogFormatting a, MonadIO m) =>
+     Documented a
+  -> [Trace m a]
+  -> m Text
+documentMarkdown (Documented documented) tracers = do
+    DocCollector docRef <- documentTracers (Documented documented) tracers
+    items <- fmap Map.toList (liftIO (readIORef docRef))
+    let sortedItems = sortBy
+                        (\ (_,l) (_,r) -> compare (ldNamespace l) (ldNamespace r))
+                        items
+        builders     = map documentItem sortedItems
+    pure $ toStrict
+            $ toLazyText
+              $ mconcat
+                $ intersperse (fromText "\n\n") builders
+  where
+    documentItem :: (Int, LogDoc) -> Builder
+    documentItem (idx, ld@LogDoc {..}) = mconcat $ intersperse (fromText "\n\n")
+      [ namespacesBuilder (nub ldNamespace)
+      , representationBuilder (documented `listIndex` idx)
+      , propertiesBuilder ld
+      , backendsBuilder (nub ldBackends)
+      , betweenLines (fromText ldDoc)
+      ]
+
+    namespacesBuilder :: [Namespace] -> Builder
+    namespacesBuilder [ns] = namespaceBuilder ns
+    namespacesBuilder []   = fromText "__Warning__: Namespace missing"
+    namespacesBuilder nsl  =
+      mconcat (intersperse (singleton '\n')(map namespaceBuilder nsl))
+        <> fromText "Warning: Mutiple Namespaces"
+
+    namespaceBuilder :: Namespace -> Builder
+    namespaceBuilder ns = fromText "### " <>
+      mconcat (intersperse (singleton '.') (map fromText ns))
+
+    representationBuilder :: LogFormatting a => Maybe (DocMsg a) -> Builder
+    representationBuilder Nothing = mempty
+    representationBuilder (Just DocMsg {..}) = mconcat
+      $ intersperse (singleton '\n')
+        [case forHuman dmPrototype of
+          "" -> mempty
+          t  -> fromText "For human : " <> asCode (fromText t)
+        , let r1 = forMachine DBrief dmPrototype
+              r2 = forMachine DRegular dmPrototype
+              r3 = forMachine DDetailed dmPrototype
+          in if r1 == mempty && r2 == mempty && r3 == mempty
+            then mempty
+              else if r1 == r2 && r2 == r3
+                then fromText "For machine : "
+                      <> asCode (fromText (toStrict (encodeToLazyText r1)))
+                else if r1 == r2
+                  then fromText "For machine regular: "
+                        <> asCode (fromText (toStrict (encodeToLazyText r2)))
+                        <> fromText "\nFor machine detailed: "
+                        <> asCode (fromText (toStrict (encodeToLazyText r3)))
+                  else if r2 == r3
+                    then fromText "For machine brief: "
+                          <> asCode (fromText (toStrict (encodeToLazyText r1)))
+                          <> fromText "\nFor machine regular: "
+                          <> asCode (fromText (toStrict (encodeToLazyText r2)))
+                    else fromText "For machine brief: "
+                          <> asCode (fromText (toStrict (encodeToLazyText r1)))
+                          <> fromText "\nFor machine regular: "
+                          <> asCode (fromText (toStrict (encodeToLazyText r2)))
+                          <> fromText "\nFor machine detailed: "
+                          <> asCode (fromText (toStrict (encodeToLazyText r3)))
+        , case asMetrics dmPrototype of
+            [] -> mempty
+            l -> mconcat
+                  (intersperse (singleton '\n')
+                    (map
+                      (\case
+                        (IntM mbT i) -> fromText "Integer metrics: "
+                          <> case mbT of
+                              Nothing -> mempty
+                              Just n -> asCode (fromText n <> singleton ' '
+                                        <> fromString (show i))
+                        (DoubleM mbT i) -> fromText "Double metrics: "
+                          <> case mbT of
+                              Nothing -> mempty
+                              Just n -> asCode (fromText n <> singleton ' '
+                                        <> fromString (show i)))
+                      l))
+        ]
+
+    propertiesBuilder :: LogDoc -> Builder
+    propertiesBuilder LogDoc {..} =
+        case nub ldSeverity of
+          []  -> fromText "Severity:   " <> asCode (fromString (show Info))
+          [s] -> fromText "Severity:   " <> asCode (fromString (show s))
+          l   -> fromText "Severities: "
+                  <> mconcat (intersperse (singleton ',')
+                        (map (asCode . fromString . show) l))
+      <>
+        case nub ldPrivacy of
+          []  -> fromText " Privacy:    " <> asCode (fromString (show Public))
+          [p] -> fromText " Privacy:    " <> asCode (fromString (show p))
+          l   -> fromText " Privacies:  "
+                  <> mconcat (intersperse (singleton ',')
+                        (map (asCode . fromString . show) l))
+      <>
+        case nub ldDetails of
+          []  -> fromText " Details:    " <> asCode (fromString (show DRegular))
+          [d] -> fromText " Details:    " <> asCode (fromString (show d))
+          l   -> fromText " Details:    "
+                  <> mconcat (intersperse (singleton ',')
+                        (map (asCode . fromString . show) l))
+
+    backendsBuilder :: [(Backend, LogFormat)] -> Builder
+    backendsBuilder [] = fromText "No backends found"
+    backendsBuilder l  = fromText "Backends: "
+                          <> mconcat (intersperse (fromText ", ")
+                                (map backendFormatToText l))
+
+    backendFormatToText :: (Backend, LogFormat) -> Builder
+    backendFormatToText (be,lf) = asCode (fromString (show be))
+                            <> fromText " Format: "
+                            <> asCode (fromString (show lf))
+
+
+asCode :: Builder -> Builder
+asCode b = singleton '`' <> b <> singleton '`'
+
+betweenLines :: Builder -> Builder
+betweenLines b = fromText "\n***\n" <> b <> fromText "\n***\n"
+
+
+listIndex :: [a] -> Int -> Maybe a
+listIndex l i = if i >= length l
+                  then Nothing
+                  else Just (l !! i)

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

@@ -53,7 +53,13 @@ data Metric
 -- for all constructors. Because it is not enforced by the type system, it is very
 -- important to provide a complete list, as the prototypes are used as well for configuration.
 -- If you don't want to add an item for documentation enter an empty text.
-newtype Documented a = Documented [(a,Text)]
+newtype Documented a = Documented [DocMsg a]
+
+data DocMsg a = DocMsg {
+    dmPrototype :: a
+  , dmName      :: Text
+  , dmMarkdown  :: Text
+}
 
 -------------------------------------------------------------------
 -- A unique identifier for every message, composed of text

trace-dispatcher/test/Examples/Aggregation.hs

@@ -32,7 +32,7 @@ instance LogFormatting BaseStats where
 
 baseStatsDocumented :: Documented Double
 baseStatsDocumented =
-  Documented [(0.0,"Measure"), (0.0,"Sum")]
+  Documented [DocMsg 0.0 "Measure" "Measure", DocMsg 0.0 "Sum" "Sum"]
 
 emptyStats :: BaseStats
 emptyStats = BaseStats 0.0 100000000.0 (-100000000.0) 0 0.0

trace-dispatcher/test/Examples/Configuration.hs

@@ -24,7 +24,7 @@ instance LogFormatting TestMessage where
            ]
 
 testMessageDocumented = Documented [
-  (TestMessage "dummy", "just a text")
+  DocMsg (TestMessage "dummy") "text" "just a text"
   ]
 
 tracer1 :: MonadIO m => m (Trace m TestMessage)

trace-dispatcher/test/Examples/Documentation.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Examples.Documentation where
+
+import           Control.Monad (liftM)
+import           Control.Monad.IO.Class
+import           Data.IORef (readIORef)
+import           Data.Map
+import qualified Data.Text.IO as T
+import           Katip
+import           Katip.Scribes.Handle (ioLogEnv)
+
+import           Cardano.Logging
+import           Data.Text (Text)
+import           Examples.TestObjects
+
+tracer1 :: (LogFormatting (TraceForgeEvent blk), MonadIO m) =>
+  m (Trace m (TraceForgeEvent blk))
+tracer1  = stdoutHumanKatipTracer
+
+tracer2 :: (LogFormatting (TraceForgeEvent blk), MonadIO m) =>
+  m (Trace m (TraceForgeEvent blk))
+tracer2  = stdoutJsonKatipTracer
+
+docTracer :: IO ()
+docTracer = do
+  t1 <- fmap (withSeverityTraceForgeEvent
+                . appendName "node"
+                . appendName "cardano") tracer1
+  t2 <-fmap (withSeverityTraceForgeEvent
+                . appendName "node"
+                . appendName "cardano") tracer2
+  t <- documentMarkdown traceForgeEventDocu [t1, t2]
+  T.writeFile "/home/yupanqui/IOHK/Testdocu.md" t

trace-dispatcher/test/Examples/EKG.hs

@@ -10,7 +10,7 @@ instance LogFormatting Int where
   asMetrics i = [IntM Nothing (fromIntegral i)]
 
 countDocumented :: Documented Int
-countDocumented = Documented [(0,"count")]
+countDocumented = Documented [DocMsg 0 "count" "count"]
 
 testEKG :: IO ()
 testEKG = do

trace-dispatcher/test/Examples/Routing.hs

@@ -3,10 +3,14 @@ module Examples.Routing where
 
 import           Control.Monad (liftM)
 import           Control.Monad.IO.Class
+import           Data.IORef (readIORef)
+import           Data.Map
+import qualified Data.Text.IO as T
 import           Katip
 import           Katip.Scribes.Handle (ioLogEnv)
 
 import           Cardano.Logging
+import           Data.Text (Text)
 import           Examples.TestObjects
 
 tracer1 :: (LogFormatting (TraceForgeEvent blk), MonadIO m) =>

trace-dispatcher/test/Examples/TestObjects.hs

@@ -111,8 +111,7 @@ instance Show LogBlock => LogFormatting (TraceForgeEvent LogBlock) where
       (unBlockNo immutableTipBlkNo)
   forHuman (TraceBlockFromFuture currentSlot tipSlot) = pack $
     printf
-      "Couldn't forge block because tip %u of slot %u is in the future. \
-      \ Current slot %u"
+      "Couldn't forge block because tip %u of slot %u is in the future."
       (unSlotNo tipSlot)
       (unSlotNo currentSlot)
 
@@ -144,38 +143,44 @@ instance Show LogBlock => LogFormatting (TraceForgeEvent LogBlock) where
 
 traceForgeEventDocu :: Documented (TraceForgeEvent LogBlock)
 traceForgeEventDocu = Documented [
-    (TraceStartLeadershipCheck (SlotNo 1),
+    DocMsg
+      (TraceStartLeadershipCheck (SlotNo 1))
+      "StartLeadershipCheck"
       "Start of the leadership check\n\
-      \\n\
-      \We record the current slot number.")
-  , (TraceSlotIsImmutable (SlotNo 1) (Point Origin) (BlockNo 1),
+        \\n\
+        \We record the current slot number."
+  , DocMsg
+      (TraceSlotIsImmutable (SlotNo 1) (Point Origin) (BlockNo 1))
+      "SlotIsImmutable"
       "Leadership check failed: the tip of the ImmutableDB inhabits the\n\
-      \current slot\n\
-      \\n\
-      \This might happen in two cases.\n\
-      \\n\
-      \1. the clock moved backwards, on restart we ignored everything from the\n\
-      \   VolatileDB since it's all in the future, and now the tip of the\n\
-      \   ImmutableDB points to a block produced in the same slot we're trying\n\
-      \   to produce a block in\n\
+        \current slot\n\
+        \\n\
+        \This might happen in two cases.\n\
+        \\n\
+        \1. the clock moved backwards, on restart we ignored everything from the\n\
+        \   VolatileDB since it's all in the future, and now the tip of the\n\
+        \   ImmutableDB points to a block produced in the same slot we're trying\n\
+        \   to produce a block in\n\
+        \\n\
+        \2. k = 0 and we already adopted a block from another leader of the same\n\
+        \   slot.\n\
+        \\n\
+        \We record both the current slot number as well as the tip of the\n\
+        \ImmutableDB.\n\
+        \\n\
+        \See also <https://github.com/input-output-hk/ouroboros-network/issues/1462>"
+  , DocMsg
+    (TraceBlockFromFuture (SlotNo 1) (SlotNo 1))
+    "LeadershipCheckFailed"
+    "Leadership check failed: the current chain contains a block from a slot\n\
+      \/after/ the current slot\n\
       \\n\
-      \2. k = 0 and we already adopted a block from another leader of the same\n\
-      \   slot.\n\
+      \This can only happen if the system is under heavy load.\n\
       \\n\
-      \We record both the current slot number as well as the tip of the\n\
-      \ImmutableDB.\n\
+      \We record both the current slot number as well as the slot number of the\n\
+      \block at the tip of the chain.\n\
       \\n\
-      \See also <https://github.com/input-output-hk/ouroboros-network/issues/1462>")
-  , (TraceBlockFromFuture (SlotNo 1) (SlotNo 1),
-    "Leadership check failed: the current chain contains a block from a slot\n\
-    \/after/ the current slot\n\
-    \\n\
-    \This can only happen if the system is under heavy load.\n\
-    \\n\
-    \We record both the current slot number as well as the slot number of the\n\
-    \block at the tip of the chain.\n\
-    \\n\
-    \See also <https://github.com/input-output-hk/ouroboros-network/issues/1462>")
+      \See also <https://github.com/input-output-hk/ouroboros-network/issues/1462>"
   ]
 
 withSeverityTraceForgeEvent :: Monad m =>

trace-dispatcher/test/Main.hs

@@ -1,8 +1,10 @@
 module Main where
 
 import           Cardano.Logging
+import           Data.Text (Text)
 import           Examples.Aggregation
 import           Examples.Configuration
+import           Examples.Documentation
 import           Examples.EKG
 import           Examples.FrequencyLimiting
 import           Examples.Routing
@@ -12,10 +14,11 @@ import           Examples.Trivial
 
 main :: IO ()
 main = do
-    test1
-    test2
-    testAggregation
-    testRouting
-    testConfig
+    -- test1
+    -- test2
+    -- testAggregation
+    -- testRouting
+    -- testConfig
     -- testEKG
     -- testLimiting
+    docTracer

trace-dispatcher/trace-dispatcher.cabal

@@ -48,6 +48,7 @@ executable trace-dispatcher-examples
                       Examples.EKG
                       Examples.Configuration
                       Examples.FrequencyLimiting
+                      Examples.Documentation
     hs-source-dirs:   test
     default-language: Haskell2010
     default-extensions:  OverloadedStrings