Without annotations

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

src/Options/Applicative.hs

@@ -94,6 +94,9 @@ module Options.Applicative (
   showDefault,
   metavar,
   noArgError,
+  helpAlignUsageOverflow,
+  helpHangUsageOverflow,
+  helpRenderHelp,
   hidden,
   internal,
   style,

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 ++ "..."

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
 

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)

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,12 +129,21 @@ 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
 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

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,29 +140,43 @@ 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.
 foldTree :: ParserPrefs -> OptDescStyle -> OptTree (Chunk Doc, Parenthetic) -> (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.
 --