From ca02c8e0f54a8f1853e7a1c1f770153833cae988 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 21 Jul 2021 14:36:21 +1000 Subject: [PATCH 1/2] Improved formatting. Switch to prettyprinter library. Tracing. --- optparse-applicative.cabal | 3 +- src/Options/Applicative.hs | 3 + src/Options/Applicative/BashCompletion.hs | 2 +- src/Options/Applicative/Builder.hs | 23 +++- src/Options/Applicative/Extra.hs | 21 ++-- src/Options/Applicative/Help/Ann.hs | 22 ++++ src/Options/Applicative/Help/Chunk.hs | 39 +++++-- src/Options/Applicative/Help/Core.hs | 120 +++++++++++++------ src/Options/Applicative/Help/Pretty.hs | 135 +++++++++++++++++++--- src/Options/Applicative/Help/Types.hs | 5 +- src/Options/Applicative/Types.hs | 46 +++++--- tests/test.hs | 12 +- 12 files changed, 333 insertions(+), 98 deletions(-) create mode 100644 src/Options/Applicative/Help/Ann.hs diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal index 7ea5f91c..7b34c457 100644 --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -87,6 +87,7 @@ library , Options.Applicative.Common , Options.Applicative.Extra , Options.Applicative.Help + , Options.Applicative.Help.Ann , Options.Applicative.Help.Chunk , Options.Applicative.Help.Core , Options.Applicative.Help.Levenshtein @@ -99,7 +100,7 @@ library build-depends: base == 4.* , transformers >= 0.2 && < 0.6 , transformers-compat >= 0.3 && < 0.7 - , ansi-wl-pprint >= 0.6.8 && < 0.7 + , prettyprinter >= 1.7.0 && < 1.8 if flag(process) build-depends: process >= 1.0 && < 1.7 diff --git a/src/Options/Applicative.hs b/src/Options/Applicative.hs index 662134bb..b9059bc9 100644 --- a/src/Options/Applicative.hs +++ b/src/Options/Applicative.hs @@ -94,6 +94,9 @@ module Options.Applicative ( showDefault, metavar, noArgError, + helpAlignUsageOverflow, + helpHangUsageOverflow, + helpRenderHelp, hidden, internal, style, diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs index b010c7df..30abc1f9 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/src/Options/Applicative/BashCompletion.hs @@ -142,7 +142,7 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre -- If there was a line break, it would come across as a different completion -- possibility. render_line :: Int -> Doc -> String - render_line len doc = case lines (displayS (renderPretty 1 len doc) "") of + render_line len doc = case lines (renderShowS (layoutPretty (LayoutOptions (AvailablePerLine len 1.0)) doc) "") of [] -> "" [x] -> x x : _ -> x ++ "..." diff --git a/src/Options/Applicative/Builder.hs b/src/Options/Applicative/Builder.hs index 917659a2..4d667413 100644 --- a/src/Options/Applicative/Builder.hs +++ b/src/Options/Applicative/Builder.hs @@ -88,7 +88,10 @@ module Options.Applicative.Builder ( columns, helpLongEquals, helpShowGlobals, + helpAlignUsageOverflow, + helpHangUsageOverflow, helpIndent, + helpRenderHelp, prefs, defaultPrefs, @@ -116,8 +119,9 @@ import Options.Applicative.Builder.Completer import Options.Applicative.Builder.Internal import Options.Applicative.Common import Options.Applicative.Types -import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk +import Options.Applicative.Help.Pretty +import Options.Applicative.Help.Types (renderHelp) -- Readers -- @@ -521,6 +525,18 @@ helpLongEquals = PrefsMod $ \p -> p { prefHelpLongEquals = True } helpShowGlobals :: PrefsMod helpShowGlobals = PrefsMod $ \p -> p { prefHelpShowGlobal = True } +-- | Align usage overflow to the right +helpAlignUsageOverflow :: PrefsMod +helpAlignUsageOverflow = PrefsMod $ \p -> p { prefUsageOverflow = UsageOverflowAlign } + +-- | Hang usage overflow to the specified indent +helpHangUsageOverflow :: Int -> PrefsMod +helpHangUsageOverflow indentation = PrefsMod $ \p -> p { prefUsageOverflow = UsageOverflowHang indentation } + +-- | Custom render function +helpRenderHelp :: (Int -> ParserHelp -> String) -> PrefsMod +helpRenderHelp f = PrefsMod $ \p -> p { prefRenderHelp = f } + -- | Set fill width in help text presentation. helpIndent :: Int -> PrefsMod helpIndent w = PrefsMod $ \p -> p { prefTabulateFill = w } @@ -540,7 +556,10 @@ prefs m = applyPrefsMod m base , prefColumns = 80 , prefHelpLongEquals = False , prefHelpShowGlobal = False - , prefTabulateFill = 24 } + , prefUsageOverflow = UsageOverflowAlign + , prefTabulateFill = 24 + , prefRenderHelp = renderHelp + } -- Convenience shortcuts diff --git a/src/Options/Applicative/Extra.hs b/src/Options/Applicative/Extra.hs index e8e9a752..5b6eb6fc 100644 --- a/src/Options/Applicative/Extra.hs +++ b/src/Options/Applicative/Extra.hs @@ -13,6 +13,7 @@ module Options.Applicative.Extra ( handleParseResult, parserFailure, renderFailure, + renderFailure', ParserFailure(..), overFailure, ParserResult(..), @@ -104,19 +105,22 @@ execParser = customExecParser defaultPrefs customExecParser :: ParserPrefs -> ParserInfo a -> IO a customExecParser pprefs pinfo = execParserPure pprefs pinfo <$> getArgs - >>= handleParseResult + >>= handleParseResult' pprefs -- | Handle `ParserResult`. handleParseResult :: ParserResult a -> IO a -handleParseResult (Success a) = return a -handleParseResult (Failure failure) = do +handleParseResult = handleParseResult' defaultPrefs + +handleParseResult' :: ParserPrefs -> ParserResult a -> IO a +handleParseResult' _ (Success a) = return a +handleParseResult' pprefs (Failure failure) = do progn <- getProgName - let (msg, exit) = renderFailure failure progn + let (msg, exit) = renderFailure' pprefs failure progn case exit of ExitSuccess -> putStrLn msg _ -> hPutStrLn stderr msg exitWith exit -handleParseResult (CompletionInvoked compl) = do +handleParseResult' _ (CompletionInvoked compl) = do progn <- getProgName msg <- execCompletion compl progn putStr msg @@ -328,6 +332,9 @@ parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn -> _ -> prefShowHelpOnError pprefs renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode) -renderFailure failure progn = +renderFailure = renderFailure' defaultPrefs + +renderFailure' :: ParserPrefs -> ParserFailure ParserHelp -> String -> (String, ExitCode) +renderFailure' pprefs failure progn = let (h, exit, cols) = execFailure failure progn - in (renderHelp cols h, exit) + in (prefRenderHelp pprefs cols h, exit) diff --git a/src/Options/Applicative/Help/Ann.hs b/src/Options/Applicative/Help/Ann.hs new file mode 100644 index 00000000..a5f45ba2 --- /dev/null +++ b/src/Options/Applicative/Help/Ann.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Options.Applicative.Help.Ann ( + Ann(..), + CanAnnotate(..) + ) where + +import Prettyprinter (Doc, annotate) + +data Ann = AnnTrace Int String + deriving (Eq, Show) + +class CanAnnotate a where + -- | Annotate trace a value + annTrace + :: Int -- ^ Trace level + -> String -- ^ Trace message + -> a -- ^ Value to be traced + -> a -- ^ The traced value + +instance CanAnnotate (Doc Ann) where + annTrace n = annotate . AnnTrace n diff --git a/src/Options/Applicative/Help/Chunk.hs b/src/Options/Applicative/Help/Chunk.hs index 6fd39a91..77bb7ccd 100644 --- a/src/Options/Applicative/Help/Chunk.hs +++ b/src/Options/Applicative/Help/Chunk.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} + module Options.Applicative.Help.Chunk ( Chunk(..) , chunked @@ -11,6 +13,8 @@ module Options.Applicative.Help.Chunk , paragraph , extractChunk , tabulate + , chunkFlatAlt + , chunkIsEffectivelyEmpty ) where import Control.Applicative @@ -20,6 +24,7 @@ import Data.Maybe import Data.Semigroup import Prelude +import Options.Applicative.Help.Ann import Options.Applicative.Help.Pretty -- | The free monoid on a semigroup 'a'. @@ -27,6 +32,9 @@ newtype Chunk a = Chunk { unChunk :: Maybe a } deriving (Eq, Show) +instance CanAnnotate (Chunk Doc) where + annTrace n = fmap . annTrace n + instance Functor Chunk where fmap f = Chunk . fmap f . unChunk @@ -89,20 +97,20 @@ extractChunk = fromMaybe mempty . unChunk -- Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty -- 'Chunk'. (<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc -(<<+>>) = chunked (<+>) +(<<+>>) = fmap (annTrace 1 "(<<+>>)") . 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 -(<>) = chunked () +(<>) = fmap (annTrace 1 "(<>)") . chunked () -- | Concatenate 'Chunk's vertically. vcatChunks :: [Chunk Doc] -> Chunk Doc -vcatChunks = foldr (chunked (.$.)) mempty +vcatChunks = fmap (annTrace 1 "vcatChunks") . foldr (chunked (.$.)) mempty -- | Concatenate 'Chunk's vertically separated by empty lines. vsepChunks :: [Chunk Doc] -> Chunk Doc -vsepChunks = foldr (chunked (\x y -> x .$. mempty .$. y)) mempty +vsepChunks = annTrace 1 "vsepChunks" . foldr (chunked (\x y -> x .$. mempty .$. y)) mempty -- | Whether a 'Chunk' is empty. Note that something like 'pure mempty' is not -- considered an empty chunk, even though the underlying 'Doc' is empty. @@ -114,8 +122,8 @@ isEmpty = isNothing . unChunk -- > isEmpty . stringChunk = null -- > extractChunk . stringChunk = string stringChunk :: String -> Chunk Doc -stringChunk "" = mempty -stringChunk s = pure (string s) +stringChunk "" = annTrace 0 "stringChunk" mempty +stringChunk s = annTrace 0 "stringChunk" $ pure (string s) -- | Convert a paragraph into a 'Chunk'. The resulting chunk is composed by the -- words of the original paragraph separated by softlines, so it will be @@ -125,12 +133,23 @@ stringChunk s = pure (string s) -- -- > isEmpty . paragraph = null . words paragraph :: String -> Chunk Doc -paragraph = foldr (chunked () . stringChunk) mempty - . words +paragraph = annTrace 0 "paragraph" + . foldr (chunked () . stringChunk) mempty + . words -- | Display pairs of strings in a table. tabulate :: Int -> [(Doc, Doc)] -> Chunk Doc -tabulate _ [] = mempty -tabulate size table = pure $ vcat +tabulate _ [] = annTrace 1 "tabulate" mempty +tabulate size table = annTrace 1 "tabulate" . pure $ vcat [ indent 2 (fillBreak size key <+> value) | (key, value) <- table ] + +-- | By default, @('chunkFlatAlt' x y)@ renders as @x@. However when 'group'ed, +-- @y@ will be preferred, with @x@ as the fallback for the case when @y@ +-- doesn't fit. +chunkFlatAlt :: Chunk Doc -> Chunk Doc -> Chunk Doc +chunkFlatAlt x y = pure (flatAlt (extractChunk x) (extractChunk y)) + +-- | Determine if the document chunk is empty when rendered +chunkIsEffectivelyEmpty :: Chunk Doc -> Bool +chunkIsEffectivelyEmpty = maybe True isEffectivelyEmpty . unChunk diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs index 1901546d..e19f870f 100644 --- a/src/Options/Applicative/Help/Core.hs +++ b/src/Options/Applicative/Help/Core.hs @@ -20,7 +20,8 @@ module Options.Applicative.Help.Core ( ) where import Control.Applicative -import Control.Monad (guard) +import Control.Monad (guard, MonadPlus) +import Data.Bifunctor (Bifunctor(first)) import Data.Function (on) import Data.List (sort, intersperse, groupBy) import Data.Foldable (any, foldl') @@ -35,8 +36,13 @@ import Prelude hiding (any) import Options.Applicative.Common import Options.Applicative.Types -import Options.Applicative.Help.Pretty +import Options.Applicative.Help.Ann import Options.Applicative.Help.Chunk +import Options.Applicative.Help.Pretty + +{- HLINT ignore "Redundant $" -} +{- HLINT ignore "Use <$>" -} +{- HLINT ignore "Use tuple-section" -} -- | Style for rendering an option. data OptDescStyle @@ -51,7 +57,7 @@ safelast = foldl' (const Just) Nothing -- | Generate description for a single option. optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (Chunk Doc, Parenthetic) -optDesc pprefs style _reachability opt = +optDesc pprefs style _reachability opt = first (annTrace 2 "optDesc") $ let names = sort . optionNames . optMain $ opt meta = @@ -90,7 +96,7 @@ optDesc pprefs style _reachability opt = -- | Generate descriptions for commands. cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)] -cmdDesc pprefs = mapParser desc +cmdDesc pprefs = fmap (fmap (annTrace 2 "cmdDesc")) <$> mapParser desc where desc _ opt = case optMain opt of @@ -105,18 +111,18 @@ cmdDesc pprefs = mapParser desc -- | Generate a brief help text for a parser. briefDesc :: ParserPrefs -> Parser a -> Chunk Doc -briefDesc = briefDesc' True +briefDesc = fmap (annTrace 2 "briefDesc") . briefDesc' True -- | Generate a brief help text for a parser, only including mandatory -- options and arguments. missingDesc :: ParserPrefs -> Parser a -> Chunk Doc -missingDesc = briefDesc' False +missingDesc = fmap (annTrace 2 "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' showOptional pprefs = - wrapOver NoDefault MaybeRequired +briefDesc' showOptional pprefs = fmap (annTrace 2 "briefDesc'") + . wrapOver NoDefault MaybeRequired . foldTree pprefs style . mfilterOptional . treeMapParser (optDesc pprefs style) @@ -135,30 +141,45 @@ briefDesc' showOptional pprefs = -- | Wrap a doc in parentheses or brackets if required. wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc wrapOver altnode mustWrapBeyond (chunk, wrapping) + | chunkIsEffectivelyEmpty chunk = + annTrace 3 "wrapOver0" <$> chunk | altnode == MarkDefault = - fmap brackets chunk + annTrace 3 "wrapOver1" <$> fmap brackets chunk | wrapping > mustWrapBeyond = - fmap parens chunk + annTrace 3 "wrapOver2" <$> fmap parens chunk | otherwise = - chunk + annTrace 3 "wrapOver3" chunk -- 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 _ _ (Leaf x) = +foldTree _ _ (Leaf x) = first (annTrace 3 "foldTree1") x foldTree prefs s (MultNode xs) = - let go = - (<>) . wrapOver NoDefault MaybeRequired . foldTree prefs s - x = - foldr go mempty xs - wrapLevel = - mult_wrap xs - in (x, wrapLevel) + ( let generous :: Chunk Doc + generous = + ( if null xs + then mempty + else + ( mconcat + . fmap (uncurry (<>)) + . zip leads + $ fmap (wrapOver NoDefault MaybeRequired . first (fmap (nest 2)) . foldTree prefs s) xs + ) <> pure line + ) + compact :: Chunk Doc + compact = + foldr (chunked () . wrapOver NoDefault MaybeRequired . foldTree prefs s) mempty xs + in group <$> chunkFlatAlt generous compact + , mult_wrap xs + ) where mult_wrap [_] = NeverRequired mult_wrap _ = MaybeRequired -foldTree prefs s (AltNode b xs) = + leads :: [Chunk Doc] + leads = fmap pure (pretty " ":repeat (line <> pretty " ")) + +foldTree prefs s (AltNode b xs) = first (annTrace 3 "foldTree2") $ (\x -> (x, NeverRequired)) . fmap groupOrNestLine . wrapOver b MaybeRequired @@ -170,10 +191,27 @@ foldTree prefs s (AltNode b xs) = alt_node :: [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic) alt_node [n] = n alt_node ns = - (\y -> (y, AlwaysRequired)) - . foldr (chunked altSep . wrapOver NoDefault MaybeRequired) mempty - $ ns -foldTree prefs s (BindNode x) = + ( fmap group + $ chunkFlatAlt + ( if null ns + then mempty + else + ( mconcat + . fmap (uncurry (<>)) + . zip leads + $ fmap (wrapOver NoDefault MaybeRequired) ns + ) <> pure line + ) + + ( foldr (chunked altSep . wrapOver NoDefault MaybeRequired) mempty + $ ns + ) + , AlwaysRequired + ) + leads :: [Chunk Doc] + leads = fmap pure (pretty " ":repeat (line <> pretty "| ")) + +foldTree prefs s (BindNode x) = first (annTrace 3 "foldTree3") $ let rendered = wrapOver NoDefault NeverRequired (foldTree prefs s x) @@ -185,17 +223,21 @@ foldTree prefs s (BindNode x) = -- | Generate a full help text for a parser fullDesc :: ParserPrefs -> Parser a -> Chunk Doc -fullDesc = optionsDesc False +fullDesc = fmap (annTrace 2 "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 = optionsDesc True +globalDesc = fmap (annTrace 2 "globalDesc") <$> optionsDesc True -- | Common generator for full descriptions and globals optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc -optionsDesc global pprefs = tabulate (prefTabulateFill pprefs) . catMaybes . mapParser doc +optionsDesc global pprefs = fmap (annTrace 2 "optionsDesc") + . tabulate (prefTabulateFill pprefs) + . catMaybes + . mapParser doc where + doc :: MonadPlus m => ArgumentReachability -> Option a -> m (Doc, Doc) doc info opt = do guard . not . isEmpty $ n guard . not . isEmpty $ h @@ -250,8 +292,7 @@ parserHelp pprefs p = vcatChunks (snd <$> a) group_title _ = mempty - with_title :: String -> Chunk Doc -> Chunk Doc - with_title title = fmap (string title .$.) + with_title title = annTrace 1 "with_title" . fmap (string title .$.) parserGlobals :: ParserPrefs -> Parser a -> ParserHelp @@ -264,12 +305,21 @@ parserGlobals pprefs p = -- | Generate option summary. parserUsage :: ParserPrefs -> Parser a -> String -> Doc -parserUsage pprefs p progn = - hsep - [ string "Usage:", - string progn, - align (extractChunk (briefDesc pprefs p)) - ] +parserUsage pprefs p progn = annTrace 2 "parserUsage" $ + case prefUsageOverflow pprefs of + UsageOverflowAlign -> + hsep + [ string "Usage:", + string progn, + align (extractChunk (briefDesc pprefs p)) + ] + UsageOverflowHang level -> + hang level $ + hsep + [ string "Usage:", + string progn, + extractChunk (briefDesc pprefs p) + ] -- | Peek at the structure of the rendered tree within. -- diff --git a/src/Options/Applicative/Help/Pretty.hs b/src/Options/Applicative/Help/Pretty.hs index f23f02b3..8635c68b 100644 --- a/src/Options/Applicative/Help/Pretty.hs +++ b/src/Options/Applicative/Help/Pretty.hs @@ -1,9 +1,30 @@ {-# LANGUAGE CPP #-} + module Options.Applicative.Help.Pretty - ( module Text.PrettyPrint.ANSI.Leijen + ( module PP , (.$.) , groupOrNestLine , altSep + , Ann(..) + , Doc + + , enclose + , parens + , brackets + , hang + , indent + , nest + + -- TODO Remove these + -- , (<$>) + , () + , (<$$>) + , () + , string + + , isEffectivelyEmpty + + , renderShowS ) where import Control.Applicative @@ -11,22 +32,25 @@ import Control.Applicative import Data.Semigroup ((<>)) #endif -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>), columns) -import Text.PrettyPrint.ANSI.Leijen.Internal (Doc (..), flatten) -import qualified Text.PrettyPrint.ANSI.Leijen as PP +import Options.Applicative.Help.Ann +import Prettyprinter hiding ((<>), Doc, enclose, parens, brackets, hang, indent, nest) +import qualified Prettyprinter as PP +import qualified Prettyprinter.Internal as PPI +import Prettyprinter.Render.String (renderShowS) import Prelude -(.$.) :: Doc -> Doc -> Doc -(.$.) = (PP.<$>) +type Doc = PPI.Doc Ann +(.$.) :: Doc -> Doc -> Doc +(.$.) x y = annTrace 1 "(.$.)" (x <> line <> y) -- | Apply the function if we're not at the -- start of our nesting level. ifNotAtRoot :: (Doc -> Doc) -> Doc -> Doc -ifNotAtRoot f doc = - Nesting $ \i -> - Column $ \j -> +ifNotAtRoot f doc = annTrace 1 "ifNotAtRoot" $ + PPI.Nesting $ \i -> + PPI.Column $ \j -> if i == j then doc else f doc @@ -38,11 +62,26 @@ ifNotAtRoot f doc = -- This will also nest subsequent lines in the -- group. groupOrNestLine :: Doc -> Doc -groupOrNestLine = - Union +groupOrNestLine d = annTrace 1 "groupOrNestLine" $ + (PPI.Union <$> flatten - <*> ifNotAtRoot (line <>) . nest 2 + <*> ifNotAtRoot (line <>)) d + where flatten :: Doc -> Doc + flatten doc = case doc of + PPI.FlatAlt _ y -> flatten y + PPI.Cat x y -> PPI.Cat (flatten x) (flatten y) + PPI.Nest i x -> PPI.Nest i (flatten x) + PPI.Line -> PPI.Fail + PPI.Union x _ -> flatten x + PPI.Column f -> PPI.Column (flatten . f) + PPI.WithPageWidth f -> PPI.WithPageWidth (flatten . f) + PPI.Nesting f -> PPI.Nesting (flatten . f) + PPI.Annotated ann x -> PPI.Annotated ann (flatten x) + x@PPI.Fail -> x + x@PPI.Empty -> x + x@PPI.Char{} -> x + x@PPI.Text{} -> x -- | Separate items in an alternative with a pipe. -- @@ -55,5 +94,73 @@ groupOrNestLine = -- but it's possible for y to still appear on the -- next line. altSep :: Doc -> Doc -> Doc -altSep x y = - group (x <+> char '|' <> line) y +altSep x y = annTrace 1 "altSep" $ + group (x <+> pretty "|" <> line) <> softline' <> y + + +-- (<$>) :: Doc -> Doc -> Doc +-- (<$>) = \x y -> x <> line <> y + +() :: Doc -> Doc -> Doc +() x y = annTrace 1 "()" $ x <> softline <> y + +(<$$>) :: Doc -> Doc -> Doc +(<$$>) x y = annTrace 1 "(<$$>)" $x <> linebreak <> y + +() :: Doc -> Doc -> Doc +() x y = annTrace 1 "()" $ x <> softbreak <> y + +linebreak :: Doc +linebreak = annTrace 0 "linebreak" $ flatAlt line mempty + +softbreak :: Doc +softbreak = annTrace 0 "softbreak" $ group linebreak + +-- | Traced version of 'PP.string'. +string :: String -> Doc +string = annTrace 0 "string" . PP.pretty + +-- | Traced version of 'PP.parens'. +parens :: Doc -> Doc +parens = annTrace 1 "parens" . PP.parens + +-- | Traced version of 'PP.brackets'. +brackets :: Doc -> Doc +brackets = annTrace 1 "brackets" . PP.brackets + +-- | Traced version of 'PP.enclose'. +enclose + :: Doc -- ^ L + -> Doc -- ^ R + -> Doc -- ^ x + -> Doc -- ^ LxR +enclose l r x = annTrace 1 "enclose" (PP.enclose l r x) + +-- | Traced version of 'PP.hang'. +hang :: Int -> Doc -> Doc +hang n = annTrace 1 "hang" . PP.hang n + +-- | Traced version of 'PP.nest'. +nest :: Int -> Doc -> Doc +nest n = annTrace 1 "nest" . PP.nest n + +-- | Traced version of 'PP.indent'. +indent :: Int -> Doc -> Doc +indent n = annTrace 1 "indent" . PP.indent n + +-- | Determine if the document is empty when rendered +isEffectivelyEmpty :: Doc -> Bool +isEffectivelyEmpty doc = case doc of + PPI.Fail -> True + PPI.Empty -> True + PPI.Char _ -> False + PPI.Text _ _ -> False + PPI.Line -> False + PPI.FlatAlt _ d -> isEffectivelyEmpty d + PPI.Cat a b -> isEffectivelyEmpty a && isEffectivelyEmpty b + PPI.Nest _ d -> isEffectivelyEmpty d + PPI.Union _ d -> isEffectivelyEmpty d + PPI.Column _ -> True + PPI.WithPageWidth _ -> False + PPI.Nesting _ -> False + PPI.Annotated _ d -> isEffectivelyEmpty d diff --git a/src/Options/Applicative/Help/Types.hs b/src/Options/Applicative/Help/Types.hs index 0e2d05c0..fe0b5cb8 100644 --- a/src/Options/Applicative/Help/Types.hs +++ b/src/Options/Applicative/Help/Types.hs @@ -1,6 +1,7 @@ module Options.Applicative.Help.Types ( ParserHelp (..) , renderHelp + , helpText ) where import Data.Semigroup @@ -42,6 +43,6 @@ helpText (ParserHelp e s h u d b g f) = -- | Convert a help text to 'String'. renderHelp :: Int -> ParserHelp -> String renderHelp cols - = (`displayS` "") - . renderPretty 1.0 cols + = (`renderShowS` "") + . layoutPretty (LayoutOptions (AvailablePerLine cols 1.0)) . helpText diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs index ee0636b6..ea1b8846 100644 --- a/src/Options/Applicative/Types.hs +++ b/src/Options/Applicative/Types.hs @@ -3,6 +3,7 @@ module Options.Applicative.Types ( ParseError(..), ParserInfo(..), ParserPrefs(..), + UsageOverflow(..), Option(..), OptName(..), @@ -107,27 +108,34 @@ data Backtracking | SubparserInline deriving (Eq, Show) +data UsageOverflow + = UsageOverflowAlign -- ^ usage is aligned to the right of the command + | UsageOverflowHang Int -- ^ usage follows a hanging indent with indent level supplied + deriving (Eq, Show) + -- | Global preferences for a top-level 'Parser'. data ParserPrefs = ParserPrefs - { prefMultiSuffix :: String -- ^ metavar suffix for multiple options - , prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations - -- (default: False) - , prefShowHelpOnError :: Bool -- ^ always show help text on parse errors - -- (default: False) - , prefShowHelpOnEmpty :: Bool -- ^ show the help text for a command or subcommand - -- if it fails with no input (default: False) - , prefBacktrack :: Backtracking -- ^ backtrack to parent parser when a - -- subcommand fails (default: Backtrack) - , prefColumns :: Int -- ^ number of columns in the terminal, used to - -- format the help page (default: 80) - , prefHelpLongEquals :: Bool -- ^ when displaying long names in usage and help, - -- use an '=' sign for long names, rather than a - -- single space (default: False) - , prefHelpShowGlobal :: Bool -- ^ when displaying subparsers' usage help, - -- show parent options under a "global options" - -- section (default: True) - , prefTabulateFill ::Int -- ^ Indentation width for tables - } deriving (Eq, Show) + { prefMultiSuffix :: String -- ^ metavar suffix for multiple options + , prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations + -- (default: False) + , prefShowHelpOnError :: Bool -- ^ always show help text on parse errors + -- (default: False) + , prefShowHelpOnEmpty :: Bool -- ^ show the help text for a command or subcommand + -- if it fails with no input (default: False) + , prefBacktrack :: Backtracking -- ^ backtrack to parent parser when a + -- subcommand fails (default: Backtrack) + , prefColumns :: Int -- ^ number of columns in the terminal, used to + -- format the help page (default: 80) + , prefHelpLongEquals :: Bool -- ^ when displaying long names in usage and help, + -- use an '=' sign for long names, rather than a + -- single space (default: False) + , prefHelpShowGlobal :: Bool -- ^ when displaying subparsers' usage help, + -- show parent options under a "global options" + -- section (default: True) + , prefUsageOverflow :: UsageOverflow -- ^ how usage overflow over lines is handled + , prefTabulateFill ::Int -- ^ Indentation width for tables + , prefRenderHelp :: Int -> ParserHelp -> String -- ^ Render help function + } data OptName = OptShort !Char | OptLong !String diff --git a/tests/test.hs b/tests/test.hs index 3c8bf6a4..a888e74d 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -27,7 +27,7 @@ import qualified Options.Applicative.NonEmpty import qualified Options.Applicative.Help as H -import Options.Applicative.Help.Pretty (Doc, SimpleDoc(..)) +import Options.Applicative.Help.Pretty (Doc) import qualified Options.Applicative.Help.Pretty as Doc import Options.Applicative.Help.Chunk import Options.Applicative.Help.Levenshtein @@ -894,12 +894,10 @@ prop_help_unknown_context = once $ --- deriving instance Arbitrary a => Arbitrary (Chunk a) -deriving instance Eq SimpleDoc -deriving instance Show SimpleDoc -equalDocs :: Float -> Int -> Doc -> Doc -> Property -equalDocs f w d1 d2 = Doc.renderPretty f w d1 - === Doc.renderPretty f w d2 +equalDocs :: Double -> Int -> Doc -> Doc -> Property +equalDocs f w d1 d2 = Doc.layoutPretty (Doc.LayoutOptions (Doc.AvailablePerLine w f)) d1 + === Doc.layoutPretty (Doc.LayoutOptions (Doc.AvailablePerLine w f)) d2 prop_listToChunk_1 :: [String] -> Property prop_listToChunk_1 xs = isEmpty (listToChunk xs) === null xs @@ -913,7 +911,7 @@ prop_extractChunk_1 x = extractChunk (pure x) === x prop_extractChunk_2 :: Chunk String -> Property prop_extractChunk_2 x = extractChunk (fmap pure x) === x -prop_stringChunk_1 :: Positive Float -> Positive Int -> String -> Property +prop_stringChunk_1 :: Positive Double -> Positive Int -> String -> Property prop_stringChunk_1 (Positive f) (Positive w) s = equalDocs f w (extractChunk (stringChunk s)) (Doc.string s) From 243771c0a71b02e60a0d32ee07bebc2c916869cb Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 21 Jul 2021 15:53:40 +1000 Subject: [PATCH 2/2] Undo annotations --- optparse-applicative.cabal | 1 - src/Options/Applicative/Help/Ann.hs | 22 --------- src/Options/Applicative/Help/Chunk.hs | 24 ++++------ src/Options/Applicative/Help/Core.hs | 42 +++++++---------- src/Options/Applicative/Help/Pretty.hs | 65 +++++++------------------- 5 files changed, 43 insertions(+), 111 deletions(-) delete mode 100644 src/Options/Applicative/Help/Ann.hs diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal index 7b34c457..7998338b 100644 --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -87,7 +87,6 @@ library , Options.Applicative.Common , Options.Applicative.Extra , Options.Applicative.Help - , Options.Applicative.Help.Ann , Options.Applicative.Help.Chunk , Options.Applicative.Help.Core , Options.Applicative.Help.Levenshtein diff --git a/src/Options/Applicative/Help/Ann.hs b/src/Options/Applicative/Help/Ann.hs deleted file mode 100644 index a5f45ba2..00000000 --- a/src/Options/Applicative/Help/Ann.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - -module Options.Applicative.Help.Ann ( - Ann(..), - CanAnnotate(..) - ) where - -import Prettyprinter (Doc, annotate) - -data Ann = AnnTrace Int String - deriving (Eq, Show) - -class CanAnnotate a where - -- | Annotate trace a value - annTrace - :: Int -- ^ Trace level - -> String -- ^ Trace message - -> a -- ^ Value to be traced - -> a -- ^ The traced value - -instance CanAnnotate (Doc Ann) where - annTrace n = annotate . AnnTrace n diff --git a/src/Options/Applicative/Help/Chunk.hs b/src/Options/Applicative/Help/Chunk.hs index 77bb7ccd..fd2e1f25 100644 --- a/src/Options/Applicative/Help/Chunk.hs +++ b/src/Options/Applicative/Help/Chunk.hs @@ -24,7 +24,6 @@ import Data.Maybe import Data.Semigroup import Prelude -import Options.Applicative.Help.Ann import Options.Applicative.Help.Pretty -- | The free monoid on a semigroup 'a'. @@ -32,9 +31,6 @@ newtype Chunk a = Chunk { unChunk :: Maybe a } deriving (Eq, Show) -instance CanAnnotate (Chunk Doc) where - annTrace n = fmap . annTrace n - instance Functor Chunk where fmap f = Chunk . fmap f . unChunk @@ -97,20 +93,20 @@ extractChunk = fromMaybe mempty . unChunk -- Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty -- 'Chunk'. (<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc -(<<+>>) = fmap (annTrace 1 "(<<+>>)") . chunked (<+>) +(<<+>>) = 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 -(<>) = fmap (annTrace 1 "(<>)") . chunked () +(<>) = chunked () -- | Concatenate 'Chunk's vertically. vcatChunks :: [Chunk Doc] -> Chunk Doc -vcatChunks = fmap (annTrace 1 "vcatChunks") . foldr (chunked (.$.)) mempty +vcatChunks = foldr (chunked (.$.)) mempty -- | Concatenate 'Chunk's vertically separated by empty lines. vsepChunks :: [Chunk Doc] -> Chunk Doc -vsepChunks = annTrace 1 "vsepChunks" . foldr (chunked (\x y -> x .$. mempty .$. y)) mempty +vsepChunks = foldr (chunked (\x y -> x .$. mempty .$. y)) mempty -- | Whether a 'Chunk' is empty. Note that something like 'pure mempty' is not -- considered an empty chunk, even though the underlying 'Doc' is empty. @@ -122,8 +118,8 @@ isEmpty = isNothing . unChunk -- > isEmpty . stringChunk = null -- > extractChunk . stringChunk = string stringChunk :: String -> Chunk Doc -stringChunk "" = annTrace 0 "stringChunk" mempty -stringChunk s = annTrace 0 "stringChunk" $ pure (string s) +stringChunk "" = mempty +stringChunk s = pure (string s) -- | Convert a paragraph into a 'Chunk'. The resulting chunk is composed by the -- words of the original paragraph separated by softlines, so it will be @@ -133,14 +129,12 @@ stringChunk s = annTrace 0 "stringChunk" $ pure (string s) -- -- > isEmpty . paragraph = null . words paragraph :: String -> Chunk Doc -paragraph = annTrace 0 "paragraph" - . foldr (chunked () . stringChunk) mempty - . words +paragraph = foldr (chunked () . stringChunk) mempty . words -- | Display pairs of strings in a table. tabulate :: Int -> [(Doc, Doc)] -> Chunk Doc -tabulate _ [] = annTrace 1 "tabulate" mempty -tabulate size table = annTrace 1 "tabulate" . pure $ vcat +tabulate _ [] = mempty +tabulate size table = pure $ vcat [ indent 2 (fillBreak size key <+> value) | (key, value) <- table ] diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs index e19f870f..a7f58ad7 100644 --- a/src/Options/Applicative/Help/Core.hs +++ b/src/Options/Applicative/Help/Core.hs @@ -36,7 +36,6 @@ import Prelude hiding (any) import Options.Applicative.Common import Options.Applicative.Types -import Options.Applicative.Help.Ann import Options.Applicative.Help.Chunk import Options.Applicative.Help.Pretty @@ -57,7 +56,7 @@ safelast = foldl' (const Just) Nothing -- | Generate description for a single option. optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (Chunk Doc, Parenthetic) -optDesc pprefs style _reachability opt = first (annTrace 2 "optDesc") $ +optDesc pprefs style _reachability opt = let names = sort . optionNames . optMain $ opt meta = @@ -96,7 +95,7 @@ optDesc pprefs style _reachability opt = first (annTrace 2 "optDesc") $ -- | Generate descriptions for commands. cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)] -cmdDesc pprefs = fmap (fmap (annTrace 2 "cmdDesc")) <$> mapParser desc +cmdDesc pprefs = mapParser desc where desc _ opt = case optMain opt of @@ -111,18 +110,18 @@ cmdDesc pprefs = fmap (fmap (annTrace 2 "cmdDesc")) <$> mapParser desc -- | Generate a brief help text for a parser. briefDesc :: ParserPrefs -> Parser a -> Chunk Doc -briefDesc = fmap (annTrace 2 "briefDesc") . briefDesc' True +briefDesc = briefDesc' True -- | Generate a brief help text for a parser, only including mandatory -- options and arguments. missingDesc :: ParserPrefs -> Parser a -> Chunk Doc -missingDesc = fmap (annTrace 2 "missingDesc") . briefDesc' False +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' showOptional pprefs = fmap (annTrace 2 "briefDesc'") - . wrapOver NoDefault MaybeRequired +briefDesc' showOptional pprefs = + wrapOver NoDefault MaybeRequired . foldTree pprefs style . mfilterOptional . treeMapParser (optDesc pprefs style) @@ -142,18 +141,17 @@ briefDesc' showOptional pprefs = fmap (annTrace 2 "briefDesc'") wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc wrapOver altnode mustWrapBeyond (chunk, wrapping) | chunkIsEffectivelyEmpty chunk = - annTrace 3 "wrapOver0" <$> chunk + chunk | altnode == MarkDefault = - annTrace 3 "wrapOver1" <$> fmap brackets chunk + fmap brackets chunk | wrapping > mustWrapBeyond = - annTrace 3 "wrapOver2" <$> fmap parens chunk - | otherwise = - annTrace 3 "wrapOver3" chunk + fmap parens chunk + | otherwise = chunk -- 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 _ _ (Leaf x) = first (annTrace 3 "foldTree1") +foldTree _ _ (Leaf x) = x foldTree prefs s (MultNode xs) = ( let generous :: Chunk Doc @@ -179,7 +177,7 @@ foldTree prefs s (MultNode xs) = leads :: [Chunk Doc] leads = fmap pure (pretty " ":repeat (line <> pretty " ")) -foldTree prefs s (AltNode b xs) = first (annTrace 3 "foldTree2") $ +foldTree prefs s (AltNode b xs) = (\x -> (x, NeverRequired)) . fmap groupOrNestLine . wrapOver b MaybeRequired @@ -211,7 +209,7 @@ foldTree prefs s (AltNode b xs) = first (annTrace 3 "foldTree2") $ leads :: [Chunk Doc] leads = fmap pure (pretty " ":repeat (line <> pretty "| ")) -foldTree prefs s (BindNode x) = first (annTrace 3 "foldTree3") $ +foldTree prefs s (BindNode x) = let rendered = wrapOver NoDefault NeverRequired (foldTree prefs s x) @@ -223,21 +221,17 @@ foldTree prefs s (BindNode x) = first (annTrace 3 "foldTree3") $ -- | Generate a full help text for a parser fullDesc :: ParserPrefs -> Parser a -> Chunk Doc -fullDesc = fmap (annTrace 2 "fullDesc") <$> optionsDesc False +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 = fmap (annTrace 2 "globalDesc") <$> optionsDesc True +globalDesc = optionsDesc True -- | Common generator for full descriptions and globals optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc -optionsDesc global pprefs = fmap (annTrace 2 "optionsDesc") - . tabulate (prefTabulateFill pprefs) - . catMaybes - . mapParser doc +optionsDesc global pprefs = tabulate (prefTabulateFill pprefs) . catMaybes . mapParser doc where - doc :: MonadPlus m => ArgumentReachability -> Option a -> m (Doc, Doc) doc info opt = do guard . not . isEmpty $ n guard . not . isEmpty $ h @@ -292,7 +286,7 @@ parserHelp pprefs p = vcatChunks (snd <$> a) group_title _ = mempty - with_title title = annTrace 1 "with_title" . fmap (string title .$.) + with_title title = fmap (string title .$.) parserGlobals :: ParserPrefs -> Parser a -> ParserHelp @@ -305,7 +299,7 @@ parserGlobals pprefs p = -- | Generate option summary. parserUsage :: ParserPrefs -> Parser a -> String -> Doc -parserUsage pprefs p progn = annTrace 2 "parserUsage" $ +parserUsage pprefs p progn = case prefUsageOverflow pprefs of UsageOverflowAlign -> hsep diff --git a/src/Options/Applicative/Help/Pretty.hs b/src/Options/Applicative/Help/Pretty.hs index 8635c68b..4a160aa0 100644 --- a/src/Options/Applicative/Help/Pretty.hs +++ b/src/Options/Applicative/Help/Pretty.hs @@ -5,16 +5,8 @@ module Options.Applicative.Help.Pretty , (.$.) , groupOrNestLine , altSep - , Ann(..) , Doc - , enclose - , parens - , brackets - , hang - , indent - , nest - -- TODO Remove these -- , (<$>) , () @@ -32,23 +24,22 @@ import Control.Applicative import Data.Semigroup ((<>)) #endif -import Options.Applicative.Help.Ann -import Prettyprinter hiding ((<>), Doc, enclose, parens, brackets, hang, indent, nest) +import Prettyprinter hiding ((<>), Doc) import qualified Prettyprinter as PP import qualified Prettyprinter.Internal as PPI import Prettyprinter.Render.String (renderShowS) import Prelude -type Doc = PPI.Doc Ann +type Doc = PPI.Doc () (.$.) :: Doc -> Doc -> Doc -(.$.) x y = annTrace 1 "(.$.)" (x <> line <> y) +(.$.) x y = x <> line <> y -- | Apply the function if we're not at the -- start of our nesting level. ifNotAtRoot :: (Doc -> Doc) -> Doc -> Doc -ifNotAtRoot f doc = annTrace 1 "ifNotAtRoot" $ +ifNotAtRoot f doc = PPI.Nesting $ \i -> PPI.Column $ \j -> if i == j @@ -62,10 +53,10 @@ ifNotAtRoot f doc = annTrace 1 "ifNotAtRoot" $ -- This will also nest subsequent lines in the -- group. groupOrNestLine :: Doc -> Doc -groupOrNestLine d = annTrace 1 "groupOrNestLine" $ - (PPI.Union +groupOrNestLine = + PPI.Union <$> flatten - <*> ifNotAtRoot (line <>)) d + <*> ifNotAtRoot (line <>) where flatten :: Doc -> Doc flatten doc = case doc of PPI.FlatAlt _ y -> flatten y @@ -94,59 +85,35 @@ groupOrNestLine d = annTrace 1 "groupOrNestLine" $ -- but it's possible for y to still appear on the -- next line. altSep :: Doc -> Doc -> Doc -altSep x y = annTrace 1 "altSep" $ +altSep x y = group (x <+> pretty "|" <> line) <> softline' <> y - --- (<$>) :: Doc -> Doc -> Doc --- (<$>) = \x y -> x <> line <> y - () :: Doc -> Doc -> Doc -() x y = annTrace 1 "()" $ x <> softline <> y +() x y = x <> softline <> y (<$$>) :: Doc -> Doc -> Doc -(<$$>) x y = annTrace 1 "(<$$>)" $x <> linebreak <> y +(<$$>) x y = x <> linebreak <> y () :: Doc -> Doc -> Doc -() x y = annTrace 1 "()" $ x <> softbreak <> y +() x y = x <> softbreak <> y linebreak :: Doc -linebreak = annTrace 0 "linebreak" $ flatAlt line mempty +linebreak = flatAlt line mempty softbreak :: Doc -softbreak = annTrace 0 "softbreak" $ group linebreak +softbreak = group linebreak -- | Traced version of 'PP.string'. string :: String -> Doc -string = annTrace 0 "string" . PP.pretty +string = PP.pretty -- | Traced version of 'PP.parens'. parens :: Doc -> Doc -parens = annTrace 1 "parens" . PP.parens +parens = PP.parens -- | Traced version of 'PP.brackets'. brackets :: Doc -> Doc -brackets = annTrace 1 "brackets" . PP.brackets - --- | Traced version of 'PP.enclose'. -enclose - :: Doc -- ^ L - -> Doc -- ^ R - -> Doc -- ^ x - -> Doc -- ^ LxR -enclose l r x = annTrace 1 "enclose" (PP.enclose l r x) - --- | Traced version of 'PP.hang'. -hang :: Int -> Doc -> Doc -hang n = annTrace 1 "hang" . PP.hang n - --- | Traced version of 'PP.nest'. -nest :: Int -> Doc -> Doc -nest n = annTrace 1 "nest" . PP.nest n - --- | Traced version of 'PP.indent'. -indent :: Int -> Doc -> Doc -indent n = annTrace 1 "indent" . PP.indent n +brackets = PP.brackets -- | Determine if the document is empty when rendered isEffectivelyEmpty :: Doc -> Bool