Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Allow customization of help info via introducing semantic Doc #482

Draft
wants to merge 3 commits into
base: master
Choose a base branch
from
Draft
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions optparse-applicative.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -93,6 +93,7 @@ library
, Options.Applicative.Help
, Options.Applicative.Help.Chunk
, Options.Applicative.Help.Core
, Options.Applicative.Help.HelpDoc
, Options.Applicative.Help.Levenshtein
, Options.Applicative.Help.Pretty
, Options.Applicative.Help.Types
Expand Down
10 changes: 5 additions & 5 deletions src/Options/Applicative/Builder.hs
Original file line number Diff line number Diff line change
Expand Up @@ -191,7 +191,7 @@ help s = optionMod $ \p -> p { propHelp = paragraph s }

-- | Specify the help text for an option as a 'Prettyprinter.Doc AnsiStyle'
-- value.
helpDoc :: Maybe Doc -> Mod f a
helpDoc :: Maybe AnsiDoc -> Mod f a
helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc }

-- | Specify the error to display when no argument is provided to this option.
Expand Down Expand Up @@ -220,7 +220,7 @@ hidden = optionMod $ \p ->
-- /NOTE/: This builder is more flexible than its name and example
-- allude. One of the motivating examples for its addition was to
-- use `const` to completely replace the usage text of an option.
style :: ( Doc -> Doc ) -> Mod f a
style :: ( AnsiDoc -> AnsiDoc ) -> Mod f a
style x = optionMod $ \p ->
p { propDescMod = Just x }

Expand Down Expand Up @@ -404,7 +404,7 @@ header s = InfoMod $ \i -> i { infoHeader = paragraph s }

-- | Specify a header for this parser as a 'Prettyprinter.Doc AnsiStyle'
-- value.
headerDoc :: Maybe Doc -> InfoMod a
headerDoc :: Maybe AnsiDoc -> InfoMod a
headerDoc doc = InfoMod $ \i -> i { infoHeader = Chunk doc }

-- | Specify a footer for this parser.
Expand All @@ -413,7 +413,7 @@ footer s = InfoMod $ \i -> i { infoFooter = paragraph s }

-- | Specify a footer for this parser as a 'Prettyprinter.Doc AnsiStyle'
-- value.
footerDoc :: Maybe Doc -> InfoMod a
footerDoc :: Maybe AnsiDoc -> InfoMod a
footerDoc doc = InfoMod $ \i -> i { infoFooter = Chunk doc }

-- | Specify a short program description.
Expand All @@ -422,7 +422,7 @@ progDesc s = InfoMod $ \i -> i { infoProgDesc = paragraph s }

-- | Specify a short program description as a 'Prettyprinter.Doc AnsiStyle'
-- value.
progDescDoc :: Maybe Doc -> InfoMod a
progDescDoc :: Maybe AnsiDoc -> InfoMod a
progDescDoc doc = InfoMod $ \i -> i { infoProgDesc = Chunk doc }

-- | Specify an exit code if a parse error occurs.
Expand Down
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.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It's so we can get a different monoid instance and not add spaces or breaks when things are hidden.

You'll find if its removed that internal and hidden options will affect the way the parser is rendered.

-- | 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
97 changes: 61 additions & 36 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
Comment on lines +68 to +70
Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I did some annotating here.

descriptions =
listToChunk (intersperse (descSep style) descs)
desc
Expand Down Expand Up @@ -85,35 +95,48 @@ optDesc pprefs style _reachability opt =
| otherwise =
desc
modified =
-- TODO(martin): optDescMod here wants to modify the description (`rendered`), but we made
-- description HelpDoc, because we are annotating stuff like metavar and option name,
-- while optDescMode works as AnsiDoc -> AnsiDoc. Figure out what to do: do we make
-- optDescMode work as HelpDoc -> HelpDoc, or do we give up annotating description here
-- and make it AnsiDoc, or maybe there is third option? I am leaning toward making
-- optDescMode operate as HelpDoc -> HelpDoc, but I don't yet understand the whole
-- situation.
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
Comment on lines +121 to +124
Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Some more annotating here.

]
_ -> 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 +155,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 +166,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 +189,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 +206,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 @@ -201,7 +224,8 @@ optionsDesc global pprefs = tabulate (prefTabulateFill pprefs) . catMaybes . map
return (extractChunk n, align . extractChunk $ h <</>> hdef)
where
n = fst $ optDesc pprefs style info opt
h = optHelp opt
-- TODO(Martin) Not 100% if this `ansiDocToHelpDoc` makes sense here as a move, should double check.
h = ansiDocToHelpDoc <$> optHelp opt
hdef = Chunk . fmap show_def . optShowDefault $ opt
show_def s = parens (pretty "default:" <+> pretty s)
style = OptDescStyle
Expand All @@ -210,47 +234,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 .$.))
Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I did a bit of annotating here.



parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
Expand All @@ -262,7 +287,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