Skip to content

Commit

Permalink
Initial work on replacing Doc with HelpDoc and AnsiDoc. Not compiling
Browse files Browse the repository at this point in the history
yet.
  • Loading branch information
Martinsos committed Jun 11, 2023
1 parent 270a626 commit 5efa15f
Show file tree
Hide file tree
Showing 6 changed files with 162 additions and 89 deletions.
22 changes: 15 additions & 7 deletions src/Options/Applicative/Help/Chunk.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 }
Expand Down Expand Up @@ -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
Expand All @@ -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)

Expand All @@ -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)
Expand Down
87 changes: 52 additions & 35 deletions src/Options/Applicative/Help/Core.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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) =
Expand All @@ -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))
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
35 changes: 35 additions & 0 deletions src/Options/Applicative/Help/HelpDoc.hs
Original file line number Diff line number Diff line change
@@ -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"
Loading

0 comments on commit 5efa15f

Please sign in to comment.