Allow customization of help info via introducing semantic Doc

src/Options/Applicative/Help/Chunk.hs

@@ -22,6 +22,14 @@ import Prelude
 
 import Options.Applicative.Help.Pretty
 
+-- TODO: What is the point of Chunk in this codebase? Is it basically used to give Doc additional powers -> Monoid?
+--   I wonder if it wasn't better if it was named DocPlus or Doc' or smth like that, and also a newtype, and then
+--   used like that around: `newtype DocPlus a = DocPlus (Chunk (Doc a))`, or maybe we can kick `Chunk` out completely?
+--   Feels to me like "Chunk" abstraction is a bit confusing: how does it relate to Doc? Is it
+--   really a "doc chunk"? But isn't Doc already a "chunk of doc"?.
+
+-- TODO: We have two types of functions here: general (Chunk a) operations, and Chunk (Doc a) operations. We should probably split those into separate modules.
+
 -- | The free monoid on a semigroup 'a'.
 newtype Chunk a = Chunk
   { unChunk :: Maybe a }
@@ -88,20 +96,20 @@ extractChunk = fromMaybe mempty . unChunk
 --
 -- Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty
 -- 'Chunk'.
-(<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc
+(<<+>>) :: Chunk (Doc a) -> Chunk (Doc a) -> Chunk (Doc a)
 (<<+>>) = chunked (<+>)
 
 -- | Concatenate two 'Chunk's with a softline in between.  This is exactly like
 -- '<<+>>', but uses a softline instead of a space.
-(<</>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc
+(<</>>) :: Chunk (Doc a) -> Chunk (Doc a) -> Chunk (Doc a)
 (<</>>) = chunked (</>)
 
 -- | Concatenate 'Chunk's vertically.
-vcatChunks :: [Chunk Doc] -> Chunk Doc
+vcatChunks :: [Chunk (Doc a)] -> Chunk (Doc a)
 vcatChunks = foldr (chunked (.$.)) mempty
 
 -- | Concatenate 'Chunk's vertically separated by empty lines.
-vsepChunks :: [Chunk Doc] -> Chunk Doc
+vsepChunks :: [Chunk (Doc a)] -> Chunk (Doc a)
 vsepChunks = foldr (chunked (\x y -> x .$. mempty .$. y)) mempty
 
 -- | Whether a 'Chunk' is empty.  Note that something like 'pure mempty' is not
@@ -113,7 +121,7 @@ isEmpty = isNothing . unChunk
 --
 -- > isEmpty . stringChunk = null
 -- > extractChunk . stringChunk = string
-stringChunk :: String -> Chunk Doc
+stringChunk :: String -> Chunk (Doc a)
 stringChunk "" = mempty
 stringChunk s = pure (pretty s)
 
@@ -124,12 +132,12 @@ stringChunk s = pure (pretty s)
 -- This satisfies:
 --
 -- > isEmpty . paragraph = null . words
-paragraph :: String -> Chunk Doc
+paragraph :: String -> Chunk (Doc a)
 paragraph = foldr (chunked (</>) . stringChunk) mempty
           . words
 
 -- | Display pairs of strings in a table.
-tabulate :: Int -> [(Doc, Doc)] -> Chunk Doc
+tabulate :: Int -> [((Doc a), (Doc a))] -> Chunk (Doc a)
 tabulate _ [] = mempty
 tabulate size table = pure $ vcat
   [ indent 2 (fillBreak size key <+> value)

src/Options/Applicative/Help/Core.hs

@@ -37,27 +37,37 @@ import Options.Applicative.Common
 import Options.Applicative.Types
 import Options.Applicative.Help.Pretty
 import Options.Applicative.Help.Chunk
+import Options.Applicative.Help.HelpDoc (HelpDoc, HelpType (CmdName, Description, Metavar, OptionName, Title), annotateHelp, ansiDocToHelpDoc)
+
+-- XXX(Martin): Seems like this module returns a bunch of helpers for generating Help, there is no
+--   single top level function, instead they are called and combined together in
+--   Options.Applicative.Extra? Makes it a bit hard to reason about the whole thing for me,
+--   plus module named Extra sounds like it wouldn't be doing this, combining them.
 
 -- | Style for rendering an option.
 data OptDescStyle
   = OptDescStyle
-      { descSep :: Doc,
+      { descSep :: HelpDoc,
         descHidden :: Bool,
         descGlobal :: Bool
       }
 
 safelast :: [a] -> Maybe a
 safelast = foldl' (const Just) Nothing
 
+-- XXX(Martin): What does this really generate? Just the names for the option + metavar?
+--   Or does it also generate its usage information? I don't see where usage is getting generated.
+--   I guess the question is, what does `Desc` in `optDesc` stand for? What kind of description?
+
 -- | Generate description for a single option.
-optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (Chunk Doc, Parenthetic)
+optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (Chunk HelpDoc, Parenthetic)
 optDesc pprefs style _reachability opt =
   let names =
         sort . optionNames . optMain $ opt
       meta =
-        stringChunk $ optMetaVar opt
+        annotateHelp Metavar <$> stringChunk (optMetaVar opt)
       descs =
-        map (pretty . showOption) names
+        map (annotateHelp OptionName . pretty . showOption) names
       descriptions =
         listToChunk (intersperse (descSep style) descs)
       desc
@@ -88,32 +98,38 @@ optDesc pprefs style _reachability opt =
         maybe id fmap (optDescMod opt) rendered
    in (modified, wrapping)
 
+-- TODO(Martin): I started going through this file and annotating chunks,
+--   but there is still more to annotate and I am not having an easy time figuring out what
+--   is what in the codebase, so it goes very slow.
+
 -- | Generate descriptions for commands.
-cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]
+cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk HelpDoc)]
 cmdDesc pprefs = mapParser desc
   where
     desc _ opt =
       case optMain opt of
         CmdReader gn cmds ->
           (,) gn $
             tabulate (prefTabulateFill pprefs)
-              [ (pretty nm, align (extractChunk (infoProgDesc cmd)))
-              | (nm, cmd) <- reverse cmds
+              [ (annotateHelp CmdName $ pretty cmdName,
+                 align (annotateHelp Description $ ansiDocToHelpDoc $ extractChunk (infoProgDesc cmdInfo))
+                )
+              | (cmdName, cmdInfo) <- reverse cmds
               ]
         _ -> mempty
 
 -- | Generate a brief help text for a parser.
-briefDesc :: ParserPrefs -> Parser a -> Chunk Doc
+briefDesc :: ParserPrefs -> Parser a -> Chunk HelpDoc
 briefDesc = briefDesc' True
 
 -- | Generate a brief help text for a parser, only including mandatory
 --   options and arguments.
-missingDesc :: ParserPrefs -> Parser a -> Chunk Doc
+missingDesc :: ParserPrefs -> Parser a -> Chunk HelpDoc
 missingDesc = briefDesc' False
 
 -- | Generate a brief help text for a parser, allowing the specification
 --   of if optional arguments are show.
-briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
+briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk HelpDoc
 briefDesc' showOptional pprefs =
   wrapOver NoDefault MaybeRequired
     . foldTree pprefs style
@@ -132,7 +148,7 @@ briefDesc' showOptional pprefs =
       }
 
 -- | Wrap a doc in parentheses or brackets if required.
-wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
+wrapOver :: AltNodeType -> Parenthetic -> (Chunk HelpDoc, Parenthetic) -> Chunk HelpDoc
 wrapOver altnode mustWrapBeyond (chunk, wrapping)
   | altnode == MarkDefault =
     fmap brackets chunk
@@ -143,7 +159,7 @@ wrapOver altnode mustWrapBeyond (chunk, wrapping)
 
 -- Fold a tree of option docs into a single doc with fully marked
 -- optional areas and groups.
-foldTree :: ParserPrefs -> OptDescStyle -> OptTree (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)
+foldTree :: ParserPrefs -> OptDescStyle -> OptTree (Chunk HelpDoc, Parenthetic) -> (Chunk HelpDoc, Parenthetic)
 foldTree _ _ (Leaf x) =
   x
 foldTree prefs s (MultNode xs) =
@@ -166,7 +182,7 @@ foldTree prefs s (AltNode b xs) =
     . map (foldTree prefs s)
     $ xs
   where
-    alt_node :: [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)
+    alt_node :: [(Chunk HelpDoc, Parenthetic)] -> (Chunk HelpDoc, Parenthetic)
     alt_node [n] = n
     alt_node ns =
       (\y -> (y, AlwaysRequired))
@@ -183,16 +199,16 @@ foldTree prefs s (BindNode x) =
    in (withSuffix, NeverRequired)
 
 -- | Generate a full help text for a parser
-fullDesc :: ParserPrefs -> Parser a -> Chunk Doc
+fullDesc :: ParserPrefs -> Parser a -> Chunk HelpDoc
 fullDesc = optionsDesc False
 
 -- | Generate a help text for the parser, showing
 --   only what is relevant in the "Global options: section"
-globalDesc :: ParserPrefs -> Parser a -> Chunk Doc
+globalDesc :: ParserPrefs -> Parser a -> Chunk HelpDoc
 globalDesc = optionsDesc True
 
 -- | Common generator for full descriptions and globals
-optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
+optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk HelpDoc
 optionsDesc global pprefs = tabulate (prefTabulateFill pprefs) . catMaybes . mapParser doc
   where
     doc info opt = do
@@ -210,47 +226,48 @@ optionsDesc global pprefs = tabulate (prefTabulateFill pprefs) . catMaybes . map
         descGlobal = global
       }
 
-errorHelp :: Chunk Doc -> ParserHelp
+errorHelp :: Chunk HelpDoc -> ParserHelp
 errorHelp chunk = mempty { helpError = chunk }
 
-headerHelp :: Chunk Doc -> ParserHelp
+headerHelp :: Chunk HelpDoc -> ParserHelp
 headerHelp chunk = mempty { helpHeader = chunk }
 
-suggestionsHelp :: Chunk Doc -> ParserHelp
+suggestionsHelp :: Chunk HelpDoc -> ParserHelp
 suggestionsHelp chunk = mempty { helpSuggestions = chunk }
 
-globalsHelp :: Chunk Doc -> ParserHelp
+globalsHelp :: Chunk HelpDoc -> ParserHelp
 globalsHelp chunk = mempty { helpGlobals = chunk }
 
-usageHelp :: Chunk Doc -> ParserHelp
+usageHelp :: Chunk HelpDoc -> ParserHelp
 usageHelp chunk = mempty { helpUsage = chunk }
 
-descriptionHelp :: Chunk Doc -> ParserHelp
+descriptionHelp :: Chunk HelpDoc -> ParserHelp
 descriptionHelp chunk = mempty { helpDescription = chunk }
 
-bodyHelp :: Chunk Doc -> ParserHelp
+bodyHelp :: Chunk HelpDoc -> ParserHelp
 bodyHelp chunk = mempty { helpBody = chunk }
 
-footerHelp :: Chunk Doc -> ParserHelp
+footerHelp :: Chunk HelpDoc -> ParserHelp
 footerHelp chunk = mempty { helpFooter = chunk }
 
 -- | Generate the help text for a program.
 parserHelp :: ParserPrefs -> Parser a -> ParserHelp
 parserHelp pprefs p =
   bodyHelp . vsepChunks $
-    with_title "Available options:" (fullDesc pprefs p)
-      : (group_title <$> cs)
+    optionsHelp :
+    (cmdGroupHelp <$> cmdGroups)
   where
-    def = "Available commands:"
-    cs = groupBy ((==) `on` fst) $ cmdDesc pprefs p
+    optionsHelp = with_title "Available options:" (fullDesc pprefs p)
+
+    cmdGroupHelp cmdGroup@((groupName, _) : _) =
+      with_title (fromMaybe "Available commands:" groupName) $
+        vcatChunks (snd <$> cmdGroup)
+    cmdGroupHelp _ = mempty
 
-    group_title a@((n, _) : _) =
-      with_title (fromMaybe def n) $
-        vcatChunks (snd <$> a)
-    group_title _ = mempty
+    cmdGroups = groupBy ((==) `on` fst) $ cmdDesc pprefs p
 
-    with_title :: String -> Chunk Doc -> Chunk Doc
-    with_title title = fmap (pretty title .$.)
+    with_title :: String -> Chunk HelpDoc -> Chunk HelpDoc
+    with_title title = fmap (annotateHelp Title . (pretty title .$.))
 
 
 parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
@@ -262,7 +279,7 @@ parserGlobals pprefs p =
 
 
 -- | Generate option summary.
-parserUsage :: ParserPrefs -> Parser a -> String -> Doc
+parserUsage :: ParserPrefs -> Parser a -> String -> HelpDoc
 parserUsage pprefs p progn =
   group $
     hsep

src/Options/Applicative/Help/HelpDoc.hs

@@ -0,0 +1,35 @@
+module Options.Applicative.Help.HelpDoc
+  ( HelpDoc,
+    HelpType (..),
+    ansiDocToHelpDoc,
+    helpDocToAnsiDoc,
+    annotateHelp,
+    annotateStyle,
+  )
+where
+
+import Options.Applicative.Help.Pretty (AnsiDoc, AnsiStyle, annotate, reAnnotate)
+import qualified Prettyprinter as PP
+import Prelude
+
+type HelpDoc = PP.Doc HelpAnn
+
+data HelpAnn = HelpAnnType HelpType | HelpAnnStyle AnsiStyle
+
+data HelpType = CmdName | OptionName | Description | Title | Metavar
+
+annotateHelp :: HelpType -> HelpDoc -> HelpDoc
+annotateHelp helpType = annotate $ HelpAnnType helpType
+
+annotateStyle :: AnsiStyle -> HelpDoc -> HelpDoc
+annotateStyle ansiStyle = annotate $ HelpAnnStyle ansiStyle
+
+ansiDocToHelpDoc :: AnsiDoc -> HelpDoc
+ansiDocToHelpDoc = reAnnotate HelpAnnStyle
+
+helpDocToAnsiDoc :: HelpDoc -> AnsiDoc
+-- TODO(Martin): I will want to probably use reAnnotate here -> for each HelpAnn, I will generate 0
+-- to N AnsiStyle annotations. However maybe I should not do this for Docs, but for SimpleDocStream,
+-- as they recommended! So maybe we should not implement this function, but instead one that does
+-- SimpleDocStream HelpAnn -> SimpleDocStream AnsiStyle.
+helpDocToAnsiDoc = error "TODO"