Simplify diff

src/Options/Applicative.hs

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

src/Options/Applicative/Builder.hs

@@ -88,8 +88,6 @@ module Options.Applicative.Builder (
   columns,
   helpLongEquals,
   helpShowGlobals,
-  helpAlignUsageOverflow,
-  helpHangUsageOverflow,
   helpIndent,
   helpRenderHelp,
   prefs,
@@ -525,14 +523,6 @@ 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 }
@@ -556,7 +546,6 @@ prefs m = applyPrefsMod m base
       , prefColumns = 80
       , prefHelpLongEquals = False
       , prefHelpShowGlobal = False
-      , prefUsageOverflow = UsageOverflowAlign
       , prefTabulateFill = 24
       , prefRenderHelp = renderHelp
       }

src/Options/Applicative/Help/Ann.hs

@@ -1,25 +1,10 @@
 {-# LANGUAGE FlexibleInstances #-}
 
-module Options.Applicative.Help.Ann (
-  Ann(..),
-  CanAnnotate(..)
+module Options.Applicative.Help.Ann
+  ( Ann(..)
   ) where
 
-import Prettyprinter (Doc, annotate)
 import Options.Applicative.Help.Style
 
-data Ann
-  = AnnTrace Int String
-  | AnnStyle SetStyle
+newtype Ann = AnnStyle SetStyle
   deriving (Eq, Show)
-
-class CanAnnotate a where
-  -- | Annotate trace a value
-  annTrace
-    :: Int      -- ^ Trace level
-    -> String   -- ^ Trace message
-    -> a        -- ^ Value to be traced
-    -> a        -- ^ The traced value
-
-instance CanAnnotate (Doc Ann) where
-  annTrace n = annotate . AnnTrace n

src/Options/Applicative/Help/Chunk.hs

@@ -24,17 +24,13 @@ 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
 
@@ -97,20 +93,20 @@ extractChunk = fromMaybe mempty . unChunk
 -- Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty
 -- 'Chunk'.
 (<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc
-(<<+>>) = fmap (annTrace 1 "(<<+>>)") . chunked (<+>)
+(<<+>>) = 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
-(<</>>) = fmap (annTrace 1 "(<</>>)") . chunked (</>)
+(<</>>) = chunked (</>)
 
 -- | Concatenate 'Chunk's vertically.
 vcatChunks :: [Chunk Doc] -> Chunk Doc
-vcatChunks = fmap (annTrace 1 "vcatChunks") . foldr (chunked (.$.)) mempty
+vcatChunks = foldr (chunked (.$.)) mempty
 
 -- | Concatenate 'Chunk's vertically separated by empty lines.
 vsepChunks :: [Chunk Doc] -> Chunk Doc
-vsepChunks = annTrace 1 "vsepChunks" . foldr (chunked (\x y -> x .$. mempty .$. y)) mempty
+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.
@@ -122,8 +118,8 @@ isEmpty = isNothing . unChunk
 -- > isEmpty . stringChunk = null
 -- > extractChunk . stringChunk = string
 stringChunk :: String -> Chunk Doc
-stringChunk "" = annTrace 0 "stringChunk" mempty
-stringChunk s = annTrace 0 "stringChunk" $ pure (string s)
+stringChunk "" = mempty
+stringChunk s = 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
@@ -133,14 +129,14 @@ stringChunk s = annTrace 0 "stringChunk" $ pure (string s)
 --
 -- > isEmpty . paragraph = null . words
 paragraph :: String -> Chunk Doc
-paragraph = annTrace 0 "paragraph"
+paragraph = id
   . foldr (chunked (</>) . stringChunk) mempty
   . words
 
 -- | Display pairs of strings in a table.
 tabulate :: Int -> [(Doc, Doc)] -> Chunk Doc
-tabulate _ [] = annTrace 1 "tabulate" mempty
-tabulate size table = annTrace 1 "tabulate" . pure $ vcat
+tabulate _ [] = mempty
+tabulate size table = pure $ vcat
   [ indent 2 (fillBreak size key <+> value)
   | (key, value) <- table ]
 

src/Options/Applicative/Help/Core.hs

@@ -20,8 +20,7 @@ module Options.Applicative.Help.Core (
   ) where
 
 import Control.Applicative
-import Control.Monad (guard, MonadPlus)
-import Data.Bifunctor (Bifunctor(first))
+import Control.Monad (guard)
 import Data.Function (on)
 import Data.List (sort, intersperse, groupBy)
 import Data.Foldable (any, foldl')
@@ -36,7 +35,6 @@ import Prelude hiding (any)
 
 import Options.Applicative.Common
 import Options.Applicative.Types
-import Options.Applicative.Help.Ann
 import Options.Applicative.Help.Chunk
 import Options.Applicative.Help.Pretty
 
@@ -59,7 +57,7 @@ safelast = foldl' (const Just) Nothing
 
 -- | Generate description for a single option.
 optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (Chunk Doc, Parenthetic)
-optDesc pprefs style _reachability opt = first (annTrace 2 "optDesc") $
+optDesc pprefs style _reachability opt =
   let names =
         sort . optionNames . optMain $ opt
       meta =
@@ -98,7 +96,7 @@ optDesc pprefs style _reachability opt = first (annTrace 2 "optDesc") $
 
 -- | Generate descriptions for commands.
 cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]
-cmdDesc pprefs = fmap (fmap (annTrace 2 "cmdDesc")) <$> mapParser desc
+cmdDesc pprefs = mapParser desc
   where
     desc _ opt =
       case optMain opt of
@@ -113,17 +111,17 @@ cmdDesc pprefs = fmap (fmap (annTrace 2 "cmdDesc")) <$> mapParser desc
 
 -- | Generate a brief help text for a parser.
 briefDesc :: ParserPrefs -> Parser a -> Chunk Doc
-briefDesc = fmap (annTrace 2 "briefDesc") . briefDesc' True
+briefDesc = briefDesc' True
 
 -- | Generate a brief help text for a parser, only including mandatory
 --   options and arguments.
 missingDesc :: ParserPrefs -> Parser a -> Chunk Doc
-missingDesc = fmap (annTrace 2 "missingDesc") . briefDesc' False
+missingDesc = briefDesc' False
 
 -- | Generate a brief help text for a parser, allowing the specification
 --   of if optional arguments are show.
 briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
-briefDesc' showOptional pprefs = fmap (annTrace 2 "briefDesc'")
+briefDesc' showOptional pprefs = id
     . wrapOver NoDefault MaybeRequired
     . foldTree pprefs style
     . mfilterOptional
@@ -144,76 +142,49 @@ briefDesc' showOptional pprefs = fmap (annTrace 2 "briefDesc'")
 wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc
 wrapOver altnode mustWrapBeyond (chunk, wrapping)
   | chunkIsEffectivelyEmpty chunk =
-    annTrace 3 "wrapOver0" <$> chunk
+    chunk
   | altnode == MarkDefault =
-    annTrace 3 "wrapOver1" <$> fmap brackets chunk
+    fmap brackets chunk
   | wrapping > mustWrapBeyond =
-    annTrace 3 "wrapOver2" <$> fmap parens chunk
+    fmap parens chunk
   | otherwise =
-    annTrace 3 "wrapOver3" chunk
+    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) = first (annTrace 3 "foldTree1")
+foldTree _ _ (Leaf x) =
   x
 foldTree prefs s (MultNode xs) =
-  ( let generous :: Chunk Doc
-        generous = annTrace 3 "generous" $
-            if null xs
-              then mempty
-              else id
-                . mconcat
-                . fmap (\(w, d) -> (w <>) <$> d)
-                . zip leads
-                $ fmap (wrapOver NoDefault MaybeRequired . first (fmap (nest 2)) . foldTree prefs s) xs
-        compact :: Chunk Doc
-        compact = annTrace 3 "compact" $
-          foldr (chunked (</>) . wrapOver NoDefault MaybeRequired . foldTree prefs s) mempty xs
-    in group <$> chunkFlatAlt generous compact
-  , mult_wrap xs
-  )
+  let go =
+        (<</>>) . wrapOver NoDefault MaybeRequired . foldTree prefs s
+      x =
+        foldr go mempty xs
+      wrapLevel =
+        mult_wrap xs
+   in (x, wrapLevel)
   where
     mult_wrap [_] = NeverRequired
     mult_wrap _ = MaybeRequired
-    leads :: [Doc]
-    leads = mempty:repeat (line <> pretty "  ")
 
-foldTree prefs s (AltNode b xs) = first (annTrace 3 "foldTree2") $
+foldTree prefs s (AltNode b xs) =
   (\x -> (x, NeverRequired))
     . fmap groupOrNestLine
     . wrapOver b MaybeRequired
     . alt_node
-    . fmap (first (\d -> annTrace 3 (show d) d))
     . filter (not . isEmpty . fst)
     . map (foldTree prefs s)
     $ xs
   where
     alt_node :: [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)
     alt_node [n] = n
     alt_node ns =
-      ( fmap group
-        $ chunkFlatAlt
-          ( if null ns
-              then mempty
-              else
-                ( mconcat
-                . fmap (\(w, d) -> (w <>) <$> d)
-                . zip leads
-                $ fmap (wrapOver NoDefault MaybeRequired) ns
-                ) <> pure line
-          )
-
-          ( foldr (chunked altSep . wrapOver NoDefault MaybeRequired) mempty
-          $ ns
-          )
-      , AlwaysRequired
-      )
-    leads :: [Doc]
-    leads = pretty " ":repeat (line <> pretty "| ")
-
-foldTree prefs s (BindNode x) = first (annTrace 3 "foldTree3") $
-  let rendered = annTrace 3 "rendered" $
+       (\y -> (y, AlwaysRequired))
+        . foldr (chunked altSep . wrapOver NoDefault MaybeRequired) mempty
+        $ ns
+
+foldTree prefs s (BindNode x) =
+  let rendered =
         wrapOver NoDefault NeverRequired (foldTree prefs s x)
 
       -- We always want to display the rendered option
@@ -224,21 +195,20 @@ foldTree prefs s (BindNode x) = first (annTrace 3 "foldTree3") $
 
 -- | Generate a full help text for a parser
 fullDesc :: ParserPrefs -> Parser a -> Chunk Doc
-fullDesc = fmap (annTrace 2 "fullDesc") <$> optionsDesc False
+fullDesc = optionsDesc False
 
 -- | Generate a help text for the parser, showing
 --   only what is relevant in the "Global options: section"
 globalDesc :: ParserPrefs -> Parser a -> Chunk Doc
-globalDesc = fmap (annTrace 2 "globalDesc") <$> optionsDesc True
+globalDesc = optionsDesc True
 
 -- | Common generator for full descriptions and globals
 optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc
-optionsDesc global pprefs = fmap (annTrace 2 "optionsDesc")
+optionsDesc global pprefs = id
     . tabulate (prefTabulateFill pprefs)
     . catMaybes
     . mapParser doc
   where
-    doc :: MonadPlus m => ArgumentReachability -> Option a -> m (Doc, Doc)
     doc info opt = do
       guard . not . isEmpty $ n
       guard . not . isEmpty $ h
@@ -293,7 +263,8 @@ parserHelp pprefs p =
         vcatChunks (snd <$> a)
     group_title _ = mempty
 
-    with_title title = annTrace 1 "with_title" . fmap (string title .$.)
+    with_title :: String -> Chunk Doc -> Chunk Doc
+    with_title title = fmap (string title .$.)
 
 
 parserGlobals :: ParserPrefs -> Parser a -> ParserHelp
@@ -306,21 +277,12 @@ parserGlobals pprefs p =
 
 -- | Generate option summary.
 parserUsage :: ParserPrefs -> Parser a -> String -> Doc
-parserUsage pprefs p progn = annTrace 2 "parserUsage" $
-  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)
-          ]
+parserUsage pprefs p progn =
+  hsep
+    [ string "Usage:",
+      string progn,
+      align (extractChunk (briefDesc pprefs p))
+    ]
 
 -- | Peek at the structure of the rendered tree within.
 --