Switch to prettyprinter library. Tracing. ANSI support for prettyprin…

…ter.
pcapriotti · Aug 19, 2022 · 2957cfb · 2957cfb
1 parent 9bdeef6
commit 2957cfb
Show file tree

Hide file tree

Showing 11 changed files with 472 additions and 29 deletions.
diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal
@@ -88,19 +88,22 @@ 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
                      , Options.Applicative.Help.Pretty
+                     , Options.Applicative.Help.Style
                      , Options.Applicative.Help.Types
                      , Options.Applicative.NonEmpty
                      , Options.Applicative.Types
                      , Options.Applicative.Internal
 
   build-depends:       base                            == 4.*
+                     , ansi-terminal                   >= 0.4.0
+                     , prettyprinter                   >= 1.7.1 && < 1.8
                      , transformers                    >= 0.2 && < 0.7
                      , transformers-compat             >= 0.3 && < 0.8
-                     , ansi-wl-pprint                  >= 0.6.8 && < 0.7
 
   if flag(process)
     build-depends:     process                         >= 1.0 && < 1.7

diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs
@@ -143,7 +143,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
@@ -116,8 +116,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 --
 
@@ -545,7 +546,8 @@ prefs m = applyPrefsMod m base
       , prefColumns = 80
       , prefHelpLongEquals = False
       , prefHelpShowGlobal = False
-      , prefTabulateFill = 24 }
+      , prefTabulateFill = 24
+      }
 
 -- Convenience shortcuts
 

diff --git a/src/Options/Applicative/Help/Ann.hs b/src/Options/Applicative/Help/Ann.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Options.Applicative.Help.Ann
+  ( Ann(..)
+  ) where
+
+import Options.Applicative.Help.Style
+
+newtype Ann = AnnStyle SetStyle
+  deriving (Eq, Show)
diff --git 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,7 @@ module Options.Applicative.Help.Chunk
   , paragraph
   , extractChunk
   , tabulate
+  , chunkFlatAlt
   ) where
 
 import Control.Applicative
@@ -134,3 +137,9 @@ 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))
diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs
@@ -35,8 +35,8 @@ 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
 
 -- | Style for rendering an option.
 data OptDescStyle
@@ -157,6 +157,7 @@ foldTree prefs s (MultNode xs) =
   where
     mult_wrap [_] = NeverRequired
     mult_wrap _ = MaybeRequired
+
 foldTree prefs s (AltNode b xs) =
   (\x -> (x, NeverRequired))
     . fmap groupOrNestLine