Does not compile completely but is starting to make sense.

Author: Martinsos

src/Options/Applicative/Help/Core.hs

@@ -35,29 +35,36 @@ import Data.Semigroup (Semigroup (..))
 #endif
 import Options.Applicative.Common
 import Options.Applicative.Help.Chunk
+import Options.Applicative.Help.HelpDoc (HelpDoc, HelpType (CmdName, Description, Metavar, OptionName, Title), annotateHelp, ansiDocToHelpDoc)
 import Options.Applicative.Help.Pretty
 import Options.Applicative.Types
 import Prelude hiding (any)
 
+-- XXX(Martin): Seems like this returns a ton of helpers for generating Help, there is no proper top level function,
+--   instead they are called and combined together in Options.Applicative.Extra .
+
 -- | 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.
+
 -- | 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,8 +95,12 @@ 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 =
@@ -98,23 +109,25 @@ cmdDesc pprefs = mapParser desc
           (,) 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
@@ -134,7 +147,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
@@ -145,7 +158,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) =
@@ -168,7 +181,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))
@@ -185,16 +198,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
@@ -213,28 +226,28 @@ 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}
 
 -- TODO: fullDesc and cmdDesc already return chunked usage information, so we need to look into them.
@@ -255,17 +268,18 @@ parserHelp pprefs p =
 
     cmdGroups = groupBy ((==) `on` fst) $ cmdDesc pprefs p
 
-    with_title :: String -> Chunk Doc -> Chunk Doc
-    with_title title = fmap (annotate (color Green <> bold) . (pretty title .$.))
+    with_title :: String -> Chunk HelpDoc -> Chunk HelpDoc
+    with_title title = fmap (annotateHelp Title . (pretty title .$.))
 
+-- | XXX(Martin): This generates just a part of parser help.
 parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
 parserGlobals pprefs p =
   globalsHelp $
     (.$.) <$> stringChunk "Global options:"
       <*> globalDesc 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

@@ -1,17 +1,34 @@
+{-# LANGUAGE TupleSections #-}
+
 module Options.Applicative.Help.HelpDoc
   ( HelpDoc,
     HelpType (..),
+    ansiDocToHelpDoc,
+    helpDocToAnsiDoc,
+    annotateHelp,
+    annotateStyle,
   )
 where
 
-import Options.Applicative.Help.Pretty (AnsiDoc)
+import Options.Applicative.Help.Pretty (AnsiDoc, AnsiStyle, annotate, reAnnotate)
 import qualified Prettyprinter as PP
 import Prelude
 
-type HelpDoc = PP.Doc HelpType
+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
 
--- TODO: Make these types more relevant, this was just my quick guess to put something in.
-data HelpType = Header | Usage | Description | Title | Undefined
+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"

src/Options/Applicative/Help/Types.hs

@@ -8,7 +8,6 @@ import Data.Semigroup
 import Options.Applicative.Help.Chunk
 import Options.Applicative.Help.HelpDoc (HelpDoc, helpDocToAnsiDoc)
 import Options.Applicative.Help.Pretty
-import qualified Prettyprinter as PP
 import Prelude
 
 data ParserHelp = ParserHelp
@@ -51,6 +50,6 @@ helpText (ParserHelp e s h u d b g f) =
 -- | Convert a help text to 'String'.
 renderHelp :: Int -> ParserHelp -> String
 renderHelp cols =
-  prettyString 1.0 cols
+  ansiDocToPrettyString 1.0 cols
     . helpDocToAnsiDoc
     . helpText