From 5efa15ff9fc772c1033d124839a346d53599708b Mon Sep 17 00:00:00 2001 From: Martin Sosic Date: Sun, 11 Jun 2023 23:02:10 +0200 Subject: [PATCH 1/3] Initial work on replacing Doc with HelpDoc and AnsiDoc. Not compiling yet. --- src/Options/Applicative/Help/Chunk.hs | 22 +++++-- src/Options/Applicative/Help/Core.hs | 87 +++++++++++++++---------- src/Options/Applicative/Help/HelpDoc.hs | 35 ++++++++++ src/Options/Applicative/Help/Pretty.hs | 68 ++++++++++--------- src/Options/Applicative/Help/Types.hs | 24 ++++--- src/Options/Applicative/Types.hs | 15 +++-- 6 files changed, 162 insertions(+), 89 deletions(-) create mode 100644 src/Options/Applicative/Help/HelpDoc.hs diff --git a/src/Options/Applicative/Help/Chunk.hs b/src/Options/Applicative/Help/Chunk.hs index 881a3819..55ef91cc 100644 --- a/src/Options/Applicative/Help/Chunk.hs +++ b/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) diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs index ce89070f..048c4297 100644 --- a/src/Options/Applicative/Help/Core.hs +++ b/src/Options/Applicative/Help/Core.hs @@ -37,11 +37,17 @@ 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 } @@ -49,15 +55,19 @@ data OptDescStyle 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,8 +98,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 = @@ -97,23 +111,25 @@ cmdDesc pprefs = mapParser desc 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 diff --git a/src/Options/Applicative/Help/HelpDoc.hs b/src/Options/Applicative/Help/HelpDoc.hs new file mode 100644 index 00000000..c6816dc1 --- /dev/null +++ b/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" diff --git a/src/Options/Applicative/Help/Pretty.hs b/src/Options/Applicative/Help/Pretty.hs index 43d111a8..ebe701ef 100644 --- a/src/Options/Applicative/Help/Pretty.hs +++ b/src/Options/Applicative/Help/Pretty.hs @@ -2,8 +2,7 @@ module Options.Applicative.Help.Pretty ( module Prettyprinter , module Prettyprinter.Render.Terminal - , Doc - , SimpleDoc + , AnsiDoc , (.$.) , () @@ -12,7 +11,7 @@ module Options.Applicative.Help.Pretty , altSep , hangAtIfOver - , prettyString + , ansiDocToPrettyString ) where #if !MIN_VERSION_base(4,11,0) @@ -20,38 +19,44 @@ import Data.Semigroup ((<>), mempty) #endif import qualified Data.Text.Lazy as Lazy -import Prettyprinter hiding (Doc) -import qualified Prettyprinter as PP +import Prettyprinter import Prettyprinter.Render.Terminal import Prelude -type Doc = PP.Doc AnsiStyle -type SimpleDoc = SimpleDocStream AnsiStyle - -linebreak :: Doc +-- TODO: Pass semantically more meaningful type to Doc, as annotation (as parameter). +-- From docs: +-- Summary: Use semantic annotations for Doc, and after layouting map to backend-specific ones. +-- For example, suppose you want to prettyprint some programming language code. If you want +-- keywords to be red, you should annotate the Doc with a type that has a Keyword field (without +-- any notion of color), and then after layouting convert the annotations to map Keyword to e.g. +-- Red (using reAnnotateS). The alternative that I do not recommend is directly annotating the +-- Doc with Red. +-- Btw I put this comment here for no good reason, it is a general comment for the whole refactoring. + +linebreak :: Doc a linebreak = flatAlt line mempty -(.$.) :: Doc -> Doc -> Doc +(.$.) :: Doc a -> Doc a -> Doc a x .$. y = x <> line <> y -() :: Doc -> Doc -> Doc +() :: Doc a -> Doc a -> Doc a x y = x <> softline <> y -- | Apply the function if we're not at the -- start of our nesting level. -ifNotAtRoot :: (Doc -> Doc) -> Doc -> Doc +ifNotAtRoot :: (Doc a -> Doc a) -> Doc a -> Doc a ifNotAtRoot = ifElseAtRoot id -- | Apply the function if we're not at the -- start of our nesting level. -ifAtRoot :: (Doc -> Doc) -> Doc -> Doc +ifAtRoot :: (Doc a -> Doc a) -> Doc a -> Doc a ifAtRoot = flip ifElseAtRoot id -- | Apply the function if we're not at the -- start of our nesting level. -ifElseAtRoot :: (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc +ifElseAtRoot :: (Doc a -> Doc a) -> (Doc a -> Doc a) -> Doc a -> Doc a ifElseAtRoot f g doc = nesting $ \i -> column $ \j -> @@ -64,7 +69,7 @@ ifElseAtRoot f g doc = -- -- This will also nest subsequent lines in the -- group. -groupOrNestLine :: Doc -> Doc +groupOrNestLine :: Doc a -> Doc a groupOrNestLine = group . ifNotAtRoot (linebreak <>) . nest 2 @@ -79,7 +84,7 @@ groupOrNestLine = -- does fit on the line, there is at least a space, -- but it's possible for y to still appear on the -- next line. -altSep :: Doc -> Doc -> Doc +altSep :: Doc a -> Doc a -> Doc a altSep x y = group (x <+> pretty '|' <> line) <> group linebreak <> y @@ -95,7 +100,7 @@ altSep x y = -- operation is put under a `group` then the linebreak -- will disappear; then item d will therefore not be at -- the starting column, and it won't be indented more. -hangAtIfOver :: Int -> Int -> Doc -> Doc +hangAtIfOver :: Int -> Int -> Doc a -> Doc a hangAtIfOver i j d = column $ \k -> if k <= j then @@ -104,20 +109,23 @@ hangAtIfOver i j d = linebreak <> ifAtRoot (indent i) d -renderPretty :: Double -> Int -> Doc -> SimpleDocStream AnsiStyle +renderPretty :: Double -> Int -> Doc a -> SimpleDocStream a renderPretty ribbonFraction lineWidth = layoutPretty LayoutOptions { layoutPageWidth = AvailablePerLine lineWidth ribbonFraction } -prettyString :: Double -> Int -> Doc -> String -prettyString ribbonFraction lineWidth - = streamToString - . renderPretty ribbonFraction lineWidth - -streamToString :: SimpleDocStream AnsiStyle -> String -streamToString sdoc = - let - rendered = - Prettyprinter.Render.Terminal.renderLazy sdoc - in - Lazy.unpack rendered +-- TODO: All the functions above are for any Doc a, only functions / types below are specific to +-- AnsiDoc. So look into splitting them into different modules most likely. + +type AnsiDoc = Doc AnsiStyle + +ansiDocToPrettyString :: Double -> Int -> AnsiDoc -> String +ansiDocToPrettyString ribbonFraction lineWidth = + ansiStreamToString + . renderPretty ribbonFraction lineWidth + +ansiStreamToString :: SimpleDocStream AnsiStyle -> String +ansiStreamToString sdoc = + let rendered = + Prettyprinter.Render.Terminal.renderLazy sdoc + in Lazy.unpack rendered diff --git a/src/Options/Applicative/Help/Types.hs b/src/Options/Applicative/Help/Types.hs index e9743ca2..c86f0608 100644 --- a/src/Options/Applicative/Help/Types.hs +++ b/src/Options/Applicative/Help/Types.hs @@ -8,16 +8,17 @@ import Prelude import Options.Applicative.Help.Chunk import Options.Applicative.Help.Pretty +import Options.Applicative.Help.HelpDoc (HelpDoc, helpDocToAnsiDoc) data ParserHelp = ParserHelp - { helpError :: Chunk Doc - , helpSuggestions :: Chunk Doc - , helpHeader :: Chunk Doc - , helpUsage :: Chunk Doc - , helpDescription :: Chunk Doc - , helpBody :: Chunk Doc - , helpGlobals :: Chunk Doc - , helpFooter :: Chunk Doc + { helpError :: Chunk HelpDoc + , helpSuggestions :: Chunk HelpDoc + , helpHeader :: Chunk HelpDoc + , helpUsage :: Chunk HelpDoc + , helpDescription :: Chunk HelpDoc + , helpBody :: Chunk HelpDoc + , helpGlobals :: Chunk HelpDoc + , helpFooter :: Chunk HelpDoc } instance Show ParserHelp where @@ -34,13 +35,16 @@ instance Semigroup ParserHelp where (mappend d1 d2) (mappend b1 b2) (mappend g1 g2) (mappend f1 f2) -helpText :: ParserHelp -> Doc +helpText :: ParserHelp -> HelpDoc helpText (ParserHelp e s h u d b g f) = extractChunk $ vsepChunks [e, s, h, u, fmap (indent 2) d, b, g, f] +-- TODO: Probably should rename this module to ParserHelp or smth like that? + -- | Convert a help text to 'String'. renderHelp :: Int -> ParserHelp -> String renderHelp cols - = prettyString 1.0 cols + = ansiDocToPrettyString 1.0 cols + . helpDocToAnsiDoc . helpText diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs index a556f2a8..83964d43 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -63,6 +63,7 @@ import System.Exit (ExitCode(..)) import Options.Applicative.Help.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk +import Options.Applicative.Help.HelpDoc (HelpDoc) data ParseError @@ -90,9 +91,9 @@ data ParserInfo a = ParserInfo { infoParser :: Parser a -- ^ the option parser for the program , infoFullDesc :: Bool -- ^ whether the help text should contain full -- documentation - , infoProgDesc :: Chunk Doc -- ^ brief parser description - , infoHeader :: Chunk Doc -- ^ header of the full parser description - , infoFooter :: Chunk Doc -- ^ footer of the full parser description + , infoProgDesc :: Chunk AnsiDoc -- ^ brief parser description + , infoHeader :: Chunk AnsiDoc -- ^ header of the full parser description + , infoFooter :: Chunk AnsiDoc -- ^ footer of the full parser description , infoFailureCode :: Int -- ^ exit code for a parser failure , infoPolicy :: ArgPolicy -- ^ allow regular options and flags to occur -- after arguments (default: InterspersePolicy) @@ -150,11 +151,11 @@ data OptVisibility -- | Specification for an individual parser option. data OptProperties = OptProperties { propVisibility :: OptVisibility -- ^ whether this flag is shown in the brief description - , propHelp :: Chunk Doc -- ^ help text for this option + , propHelp :: Chunk HelpDoc -- ^ help text for this option , propMetaVar :: String -- ^ metavariable for this option , propShowDefault :: Maybe String -- ^ what to show in the help text as the default , propShowGlobal :: Bool -- ^ whether the option is presented in global options text - , propDescMod :: Maybe ( Doc -> Doc ) -- ^ a function to run over the brief description + , propDescMod :: Maybe ( HelpDoc -> HelpDoc ) -- ^ a function to run over the brief description } instance Show OptProperties where @@ -431,7 +432,7 @@ filterOptional t = case t of optVisibility :: Option a -> OptVisibility optVisibility = propVisibility . optProps -optHelp :: Option a -> Chunk Doc +optHelp :: Option a -> Chunk HelpDoc optHelp = propHelp . optProps optMetaVar :: Option a -> String @@ -440,5 +441,5 @@ optMetaVar = propMetaVar . optProps optShowDefault :: Option a -> Maybe String optShowDefault = propShowDefault . optProps -optDescMod :: Option a -> Maybe ( Doc -> Doc ) +optDescMod :: Option a -> Maybe ( HelpDoc -> HelpDoc ) optDescMod = propDescMod . optProps From b25bde54596787d7c0025a64f24f2a5caf91a055 Mon Sep 17 00:00:00 2001 From: Martin Sosic Date: Sun, 11 Jun 2023 23:24:43 +0200 Subject: [PATCH 2/3] Some compiler fixes. --- src/Options/Applicative/Builder.hs | 10 +++++----- src/Options/Applicative/Types.hs | 8 ++++---- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Options/Applicative/Builder.hs b/src/Options/Applicative/Builder.hs index bc12b5f2..838cc8b5 100644 --- a/src/Options/Applicative/Builder.hs +++ b/src/Options/Applicative/Builder.hs @@ -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. @@ -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 } @@ -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. @@ -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. @@ -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. diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs index 83964d43..6197c3b4 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -151,11 +151,11 @@ data OptVisibility -- | Specification for an individual parser option. data OptProperties = OptProperties { propVisibility :: OptVisibility -- ^ whether this flag is shown in the brief description - , propHelp :: Chunk HelpDoc -- ^ help text for this option + , propHelp :: Chunk AnsiDoc -- ^ help text for this option , propMetaVar :: String -- ^ metavariable for this option , propShowDefault :: Maybe String -- ^ what to show in the help text as the default , propShowGlobal :: Bool -- ^ whether the option is presented in global options text - , propDescMod :: Maybe ( HelpDoc -> HelpDoc ) -- ^ a function to run over the brief description + , propDescMod :: Maybe ( AnsiDoc -> AnsiDoc ) -- ^ a function to run over the brief description } instance Show OptProperties where @@ -432,7 +432,7 @@ filterOptional t = case t of optVisibility :: Option a -> OptVisibility optVisibility = propVisibility . optProps -optHelp :: Option a -> Chunk HelpDoc +optHelp :: Option a -> Chunk AnsiDoc optHelp = propHelp . optProps optMetaVar :: Option a -> String @@ -441,5 +441,5 @@ optMetaVar = propMetaVar . optProps optShowDefault :: Option a -> Maybe String optShowDefault = propShowDefault . optProps -optDescMod :: Option a -> Maybe ( HelpDoc -> HelpDoc ) +optDescMod :: Option a -> Maybe ( AnsiDoc -> AnsiDoc ) optDescMod = propDescMod . optProps From f5e7f721ac7efd0dcccf0e62789c05877a122ceb Mon Sep 17 00:00:00 2001 From: Martin Sosic Date: Sun, 11 Jun 2023 23:36:29 +0200 Subject: [PATCH 3/3] fix --- optparse-applicative.cabal | 1 + src/Options/Applicative/Help/Core.hs | 10 +++++++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal index d9a20768..66b5a5ef 100644 --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -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 diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs index 048c4297..544c2a32 100644 --- a/src/Options/Applicative/Help/Core.hs +++ b/src/Options/Applicative/Help/Core.hs @@ -95,6 +95,13 @@ 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) @@ -217,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