From ca02c8e0f54a8f1853e7a1c1f770153833cae988 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 21 Jul 2021 14:36:21 +1000 Subject: [PATCH] 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)