Improved formatting and tracing

Author: newhoggy

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
@@ -96,10 +97,10 @@ library
                      , Options.Applicative.Types
                      , Options.Applicative.Internal
 
-  build-depends:       base                            == 4.*
-                     , transformers                    >= 0.2 && < 0.6
-                     , transformers-compat             >= 0.3 && < 0.7
-                     , ansi-wl-pprint                  >= 0.6.8 && < 0.7
+  build-depends:       base                                 == 4.*
+                     , transformers                         >= 0.2 && < 0.6
+                     , transformers-compat                  >= 0.3 && < 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,17 @@ 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 }
+
+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 +555,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/Ann.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Options.Applicative.Help.Ann (
+  Ann(..),
+  CanAnnotate(..)
+  ) where
+
+import Prettyprinter (Doc, annotate)
+
+data Ann = AnnTrace
+  Int     -- ^ Trace level
+  String  -- ^ Trace message
+  deriving (Eq, Show)
+
+-- | The minimum trace level for tracing to be included
+minTraceLevel :: Int
+minTraceLevel = 2
+
+class CanAnnotate a where
+  annTrace :: Int -> String -> a -> a
+
+instance CanAnnotate (Doc Ann) where
+  annTrace n = if n >= minTraceLevel then annotate . AnnTrace n else const id

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,13 +24,17 @@ 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'.
 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,19 @@ 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 ]
+
+chunkFlatAlt :: Chunk Doc -> Chunk Doc -> Chunk Doc
+chunkFlatAlt a b = pure (flatAlt (extractChunk a) (extractChunk b))
+
+chunkIsEffectivelyEmpty :: Chunk Doc -> Bool
+chunkIsEffectivelyEmpty = fromMaybe True . fmap isEffectivelyEmpty . unChunk