Improved formatting. Switch to prettyprinter library. Tracing.

IntersectMBO · Jul 21, 2021 · 08ea636 · 08ea636
1 parent fc46e19
commit 08ea636
Show file tree

Hide file tree

Showing 9 changed files with 104 additions and 7 deletions.
diff --git a/.gitmodules b/.gitmodules
@@ -0,0 +1,6 @@
+[submodule "optparse-applicative"]
+	path = optparse-applicative
+	url = git@github.com:input-output-hk/optparse-applicative.git
+[submodule "criterion"]
+	path = criterion
+	url = git@github.com:input-output-hk/criterion.git
diff --git a/cabal.project b/cabal.project
@@ -12,6 +12,8 @@ packages:
     nix/workbench/cardano-topology
     bench/tx-generator
     nix/workbench/locli
+    optparse-applicative
+    criterion
 
 package cardano-api
   ghc-options: -Werror

diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal
@@ -92,6 +92,8 @@ library
                         Cardano.CLI.Mary.RenderValue
                         Cardano.CLI.Mary.ValueParser
 
+                        Cardano.CLI.Render
+
                         Cardano.CLI.TopHandler
 
   other-modules:        Paths_cardano_cli
@@ -133,6 +135,7 @@ library
                       , ouroboros-network
                       , parsec
                       , plutus-ledger-api
+                      , prettyprinter
                       , shelley-spec-ledger
                       , small-steps
                       , split

diff --git a/cardano-cli/src/Cardano/CLI/Parsers.hs b/cardano-cli/src/Cardano/CLI/Parsers.hs
@@ -1,17 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Cardano.CLI.Parsers
   ( opts
   , pref
   ) where
 
 import           Cardano.Prelude
-import           Prelude (String)
-
-import           Options.Applicative
-import qualified Options.Applicative as Opt
-
+import           Data.Function (id)
 import           Cardano.CLI.Byron.Parsers (backwardsCompatibilityCommands, parseByronCommands)
 import           Cardano.CLI.Run (ClientCommand (..))
 import           Cardano.CLI.Shelley.Parsers (parseShelleyCommands)
+import           Options.Applicative
+import           Options.Applicative.Help.Ann
+import           Options.Applicative.Help.Types (helpText)
+import           Prelude (String)
+import           Prettyprinter
+import           Prettyprinter.Render.Util.SimpleDocTree
+
+import qualified Data.Text as T
+import qualified Options.Applicative as Opt
 
 command' :: String -> String -> Parser a -> Mod CommandFields a
 command' c descr p =
@@ -29,7 +36,25 @@ opts =
     )
 
 pref :: ParserPrefs
-pref = Opt.prefs showHelpOnEmpty
+pref = Opt.prefs $ mempty
+  <> showHelpOnEmpty
+  <> helpHangUsageOverflow 10
+  <> helpRenderHelp customRenderHelp
+
+-- | Convert a help text to 'String'.
+customRenderHelp :: Int -> ParserHelp -> String
+customRenderHelp cols
+  = T.unpack
+  . ("<html>\n" <>)
+  . ("<body>\n" <>)
+  . ("<pre>\n" <>)
+  . (<> "\n</html>")
+  . (<> "\n</body>")
+  . (<> "\n</pre>")
+  . renderSimplyDecorated id (\(AnnTrace _ name) x -> "<span name=" <> show name <> ">" <> x <> "</span>")
+  . treeForm
+  . layoutSmart (LayoutOptions (AvailablePerLine cols 1.0))
+  . helpText
 
 parseClientCommand :: Parser ClientCommand
 parseClientCommand =

diff --git a/cardano-cli/src/Cardano/CLI/Render.hs b/cardano-cli/src/Cardano/CLI/Render.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Cardano.CLI.Render
+  ( renderHtmlShowS
+  ) where
+
+import Data.Function
+import Data.Ord
+import Options.Applicative.Help.Ann
+import Prettyprinter
+import Prettyprinter.Render.Util.Panic
+import Text.Show
+
+import qualified Data.List as L
+import qualified Data.Text as T
+
+renderOpenAnn :: Ann -> ShowS
+renderOpenAnn ann = case ann of
+  AnnTrace _ s -> id
+    . ("<span trace=" <>)
+    . (show s <>)
+    . (">" <>)
+
+renderCloseAnn :: Ann -> ShowS
+renderCloseAnn ann = case ann of
+  AnnTrace _ _ -> id
+    . (<> "</span>")
+
+-- | Render a 'SimpleDocStream' to a 'ShowS', useful to write 'Show' instances
+-- based on the prettyprinter.
+--
+-- @
+-- instance 'Show' MyType where
+--     'showsPrec' _ = 'renderHtmlShowS' . 'layoutPretty' 'defaultLayoutOptions' . 'pretty'
+-- @
+renderHtmlShowS :: SimpleDocStream Ann -> ShowS
+renderHtmlShowS ds = id
+  . ("<html>\n" <>)
+  . ("<body>\n" <>)
+  . ("<pre>\n" <>)
+  . (<> "\n</pre>")
+  . (<> "\n</body>")
+  . (<> "\n</html>")
+  . go [] ds
+  where
+    go :: [Ann] -> SimpleDocStream Ann -> ShowS
+    go anns sds = case sds of
+      SFail           -> panicUncaughtFail
+      SEmpty          -> id
+      SChar c x       -> showChar c . go anns x
+      SText _l t x    -> showString (T.unpack t) . go anns x
+      SLine i x       -> showString ('\n' : L.replicate i ' ') . go anns x
+      SAnnPush ann x  -> onLevel ann (renderOpenAnn ann) . go (ann:anns) x
+      SAnnPop x       -> case anns of
+        (a:as) -> go as x . onLevel a (renderCloseAnn a)
+        [] -> go [] x
+    onLevel :: Ann -> ShowS -> ShowS
+    onLevel (AnnTrace n _) f = if n >= 2 then f else id
diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs
@@ -282,4 +282,4 @@ parserHelpOptions = fromMaybe mempty . OptI.unChunk . OptI.fullDesc (Opt.prefs m
 -- | Render the help pretty document.
 renderHelpDoc :: Int -> OptI.Doc -> String
 renderHelpDoc cols =
-  (`OptI.displayS` "") . OptI.renderPretty 1.0 cols
+  (`OptI.renderShowS` "") . OptI.layoutPretty (OptI.LayoutOptions (OptI.AvailablePerLine cols 1.0))
diff --git a/criterion b/criterion
diff --git a/moo.html b/moo.html
@@ -0,0 +1 @@
+zsh: command not found: transaction
diff --git a/optparse-applicative b/optparse-applicative