diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal index 7ea5f91c..7998338b 100644 --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -99,7 +99,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/Chunk.hs b/src/Options/Applicative/Help/Chunk.hs index 6fd39a91..fd2e1f25 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 @@ -125,8 +129,7 @@ stringChunk s = pure (string s) -- -- > isEmpty . paragraph = null . words paragraph :: String -> Chunk Doc -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 @@ -134,3 +137,13 @@ tabulate _ [] = mempty tabulate size table = 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..a7f58ad7 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,12 @@ import Prelude hiding (any) import Options.Applicative.Common import Options.Applicative.Types -import Options.Applicative.Help.Pretty 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 @@ -135,12 +140,13 @@ 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 = + chunk | altnode == MarkDefault = - fmap brackets chunk + fmap brackets chunk | wrapping > mustWrapBeyond = - fmap parens chunk - | otherwise = - chunk + fmap parens chunk + | otherwise = chunk -- Fold a tree of option docs into a single doc with fully marked -- optional areas and groups. @@ -148,16 +154,29 @@ foldTree :: ParserPrefs -> OptDescStyle -> OptTree (Chunk Doc, Parenthetic) -> ( foldTree _ _ (Leaf x) = 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 + leads :: [Chunk Doc] + leads = fmap pure (pretty " ":repeat (line <> pretty " ")) + foldTree prefs s (AltNode b xs) = (\x -> (x, NeverRequired)) . fmap groupOrNestLine @@ -170,9 +189,26 @@ 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 + ( 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) = let rendered = wrapOver NoDefault NeverRequired (foldTree prefs s x) @@ -250,7 +286,6 @@ parserHelp pprefs p = vcatChunks (snd <$> a) group_title _ = mempty - with_title :: String -> Chunk Doc -> Chunk Doc with_title title = fmap (string title .$.) @@ -265,11 +300,20 @@ 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)) - ] + 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..4a160aa0 100644 --- a/src/Options/Applicative/Help/Pretty.hs +++ b/src/Options/Applicative/Help/Pretty.hs @@ -1,9 +1,22 @@ {-# LANGUAGE CPP #-} + module Options.Applicative.Help.Pretty - ( module Text.PrettyPrint.ANSI.Leijen + ( module PP , (.$.) , groupOrNestLine , altSep + , Doc + + -- TODO Remove these + -- , (<$>) + , () + , (<$$>) + , () + , string + + , isEffectivelyEmpty + + , renderShowS ) where import Control.Applicative @@ -11,22 +24,24 @@ 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 Prettyprinter hiding ((<>), Doc) +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 () +(.$.) :: Doc -> Doc -> Doc +(.$.) 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 = - Nesting $ \i -> - Column $ \j -> + PPI.Nesting $ \i -> + PPI.Column $ \j -> if i == j then doc else f doc @@ -39,10 +54,25 @@ ifNotAtRoot f doc = -- group. groupOrNestLine :: Doc -> Doc groupOrNestLine = - Union + PPI.Union <$> flatten - <*> ifNotAtRoot (line <>) . nest 2 + <*> ifNotAtRoot (line <>) + 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. -- @@ -56,4 +86,48 @@ groupOrNestLine = -- next line. altSep :: Doc -> Doc -> Doc altSep x y = - group (x <+> char '|' <> line) y + group (x <+> pretty "|" <> line) <> softline' <> y + +() :: Doc -> Doc -> Doc +() x y = x <> softline <> y + +(<$$>) :: Doc -> Doc -> Doc +(<$$>) x y = x <> linebreak <> y + +() :: Doc -> Doc -> Doc +() x y = x <> softbreak <> y + +linebreak :: Doc +linebreak = flatAlt line mempty + +softbreak :: Doc +softbreak = group linebreak + +-- | Traced version of 'PP.string'. +string :: String -> Doc +string = PP.pretty + +-- | Traced version of 'PP.parens'. +parens :: Doc -> Doc +parens = PP.parens + +-- | Traced version of 'PP.brackets'. +brackets :: Doc -> Doc +brackets = PP.brackets + +-- | 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)