Move to pretty printer

.github/workflows/haskell-ci.yml

@@ -98,16 +98,6 @@ jobs:
             compilerVersion: 7.4.2
             setup-method: hvr-ppa
             allow-failure: false
-          - compiler: ghc-7.2.2
-            compilerKind: ghc
-            compilerVersion: 7.2.2
-            setup-method: hvr-ppa
-            allow-failure: false
-          - compiler: ghc-7.0.4
-            compilerKind: ghc
-            compilerVersion: 7.0.4
-            setup-method: hvr-ppa
-            allow-failure: false
       fail-fast: false
     steps:
       - name: apt

optparse-applicative.cabal

@@ -100,10 +100,11 @@ library
                      , Options.Applicative.Types
                      , Options.Applicative.Internal
 
-  build-depends:       base                            == 4.*
+  build-depends:       base                            >= 4.5 && < 5
                      , transformers                    >= 0.2 && < 0.7
                      , transformers-compat             >= 0.3 && < 0.8
-                     , ansi-wl-pprint                  >= 0.6.8 && < 1.1
+                     , prettyprinter                   >= 1.7 && < 1.8
+                     , prettyprinter-ansi-terminal     >= 1.1 && < 1.2
 
   if flag(process)
     build-depends:     process                         >= 1.0 && < 1.7

src/Options/Applicative/BashCompletion.hs

@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 -- | You don't need to import this module to enable bash completion.
 --
 -- See
@@ -150,7 +149,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 (prettyString 1 len doc) of
       [] -> ""
       [x] -> x
       x : _ -> x ++ "..."

src/Options/Applicative/Help/Chunk.hs

@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Options.Applicative.Help.Chunk
   ( Chunk(..)
   , chunked
@@ -116,7 +115,7 @@ isEmpty = isNothing . unChunk
 -- > extractChunk . stringChunk = string
 stringChunk :: String -> Chunk Doc
 stringChunk "" = mempty
-stringChunk s = pure (string s)
+stringChunk s = pure (pretty 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

src/Options/Applicative/Help/Core.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Options.Applicative.Help.Core (
   cmdDesc,
   briefDesc,
@@ -58,7 +57,7 @@ optDesc pprefs style _reachability opt =
       meta =
         stringChunk $ optMetaVar opt
       descs =
-        map (string . showOption) names
+        map (pretty . showOption) names
       descriptions =
         listToChunk (intersperse (descSep style) descs)
       desc
@@ -98,7 +97,7 @@ cmdDesc pprefs = mapParser desc
         CmdReader gn cmds ->
           (,) gn $
             tabulate (prefTabulateFill pprefs)
-              [ (string nm, align (extractChunk (infoProgDesc cmd)))
+              [ (pretty nm, align (extractChunk (infoProgDesc cmd)))
               | (nm, cmd) <- reverse cmds
               ]
         _ -> mempty
@@ -127,7 +126,7 @@ briefDesc' showOptional pprefs =
       | otherwise =
         filterOptional
     style = OptDescStyle
-      { descSep = string "|",
+      { descSep = pretty '|',
         descHidden = False,
         descGlobal = False
       }
@@ -204,9 +203,9 @@ optionsDesc global pprefs = tabulate (prefTabulateFill pprefs) . catMaybes . map
         n = fst $ optDesc pprefs style info opt
         h = optHelp opt
         hdef = Chunk . fmap show_def . optShowDefault $ opt
-        show_def s = parens (string "default:" <+> string s)
+        show_def s = parens (pretty "default:" <+> pretty s)
     style = OptDescStyle
-      { descSep = string ",",
+      { descSep = pretty ',',
         descHidden = True,
         descGlobal = global
       }
@@ -251,7 +250,7 @@ parserHelp pprefs p =
     group_title _ = mempty
 
     with_title :: String -> Chunk Doc -> Chunk Doc
-    with_title title = fmap (string title .$.)
+    with_title title = fmap (pretty title .$.)
 
 
 parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
@@ -267,8 +266,8 @@ parserUsage :: ParserPrefs -> Parser a -> String -> Doc
 parserUsage pprefs p progn =
   group $
     hsep
-      [ string "Usage:",
-        string progn,
+      [ pretty "Usage:",
+        pretty progn,
         hangAtIfOver 9 35 (extractChunk (briefDesc pprefs p))
       ]
 

src/Options/Applicative/Help/Pretty.hs

@@ -1,40 +1,41 @@
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Options.Applicative.Help.Pretty
-  ( module Text.PrettyPrint.ANSI.Leijen
+  ( module Prettyprinter
+  , module Prettyprinter.Render.Terminal
   , Doc
-  , indent
-  , renderPretty
-  , displayS
+  , SimpleDoc
+
   , (.$.)
+  , (</>)
+
   , groupOrNestLine
   , altSep
   , hangAtIfOver
+
+  , prettyString
   ) where
 
 #if !MIN_VERSION_base(4,11,0)
-import           Data.Semigroup ((<>))
+import           Data.Semigroup ((<>), mempty)
 #endif
 
-import           Text.PrettyPrint.ANSI.Leijen hiding (Doc, (<$>), (<>), columns, indent, renderPretty, displayS)
-import qualified Text.PrettyPrint.ANSI.Leijen as PP
+import           Prettyprinter hiding (Doc)
+import qualified Prettyprinter as PP
+import qualified Prettyprinter.Render.String as PP
+import           Prettyprinter.Render.Terminal
 
 import           Prelude
 
-type Doc = PP.Doc
+type Doc = PP.Doc Prettyprinter.Render.Terminal.AnsiStyle
+type SimpleDoc = SimpleDocStream AnsiStyle
 
-indent :: Int -> PP.Doc -> PP.Doc
-indent = PP.indent
-
-renderPretty :: Float -> Int -> PP.Doc -> SimpleDoc
-renderPretty = PP.renderPretty
-
-displayS :: SimpleDoc -> ShowS
-displayS = PP.displayS
+linebreak :: Doc
+linebreak = flatAlt line mempty
 
 (.$.) :: Doc -> Doc -> Doc
-(.$.) = (PP.<$>)
-
+x .$. y = x <> line <> y
+(</>) :: Doc -> Doc -> Doc
+x </> y = x <> softline <> y
 
 -- | Apply the function if we're not at the
 --   start of our nesting level.
@@ -58,7 +59,6 @@ ifElseAtRoot f g doc =
         then f doc
         else g doc
 
-
 -- | Render flattened text on this line, or start
 --   a new line before rendering any text.
 --
@@ -81,7 +81,7 @@ groupOrNestLine =
 --   next line.
 altSep :: Doc -> Doc -> Doc
 altSep x y =
-  group (x <+> char '|' <> line) <//> y
+  group (x <+> pretty '|' <> line) <> group linebreak <>  y
 
 
 -- | Printer hacks to get nice indentation for long commands
@@ -102,3 +102,18 @@ hangAtIfOver i j d =
       align d
     else
       linebreak <> ifAtRoot (indent i) d
+
+
+renderPretty :: Double -> Int -> Doc -> SimpleDocStream AnsiStyle
+renderPretty ribbonFraction lineWidth
+  = layoutSmart LayoutOptions
+      { layoutPageWidth = AvailablePerLine lineWidth ribbonFraction }
+
+prettyString :: Double -> Int -> Doc -> String
+prettyString ribbonFraction lineWidth
+  = streamToString
+  . renderPretty ribbonFraction lineWidth
+
+streamToString :: SimpleDocStream AnsiStyle -> String
+streamToString stream =
+  PP.renderShowS stream ""

src/Options/Applicative/Help/Types.hs

@@ -42,6 +42,5 @@ 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
+  = prettyString 1.0 cols
   . helpText

tests/test.hs

@@ -28,7 +28,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
@@ -951,9 +951,9 @@ prop_long_command_line_flow = once $
 deriving instance Arbitrary a => Arbitrary (Chunk a)
 
 
-equalDocs :: Float -> Int -> Doc -> Doc -> Property
-equalDocs f w d1 d2 = Doc.displayS (Doc.renderPretty f w d1) ""
-                  === Doc.displayS (Doc.renderPretty f w d2) ""
+equalDocs :: Double -> Int -> Doc -> Doc -> Property
+equalDocs f w d1 d2 = Doc.prettyString f w d1
+                  === Doc.prettyString f w d2
 
 prop_listToChunk_1 :: [String] -> Property
 prop_listToChunk_1 xs = isEmpty (listToChunk xs) === null xs
@@ -967,10 +967,10 @@ 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)
+                (Doc.pretty s)
 
 prop_stringChunk_2 :: String -> Property
 prop_stringChunk_2 s = isEmpty (stringChunk s) === null s