Use tree to filter out optionals, instead of annotating the leaves

Options/Applicative/Builder/Internal.hs

@@ -160,9 +160,11 @@ mkParser :: DefaultProp a
          -> (OptProperties -> OptProperties)
          -> OptReader a
          -> Parser a
-mkParser d@(DefaultProp def _) g rdr = liftOpt opt <|> maybe empty pure def
-  where
-    opt = mkOption d g rdr
+mkParser d@(DefaultProp def _) g rdr =
+  let
+    o = liftOpt $ mkOption d g rdr
+  in
+    maybe o (\a -> o <|> pure a) def
 
 mkOption :: DefaultProp a
          -> (OptProperties -> OptProperties)

Options/Applicative/Common.hs

@@ -257,46 +257,41 @@ mapParser f = flatten . treeMapParser f
 treeMapParser :: (forall x . OptHelpInfo -> Option x -> b)
           -> Parser a
           -> OptTree b
-treeMapParser g = simplify . go False False False g
+treeMapParser g = simplify . go False False g
   where
     has_default :: Parser a -> Bool
     has_default p = isJust (evalParser p)
 
     go :: Bool
-       -> Bool
        -> Bool
        -> (forall x . OptHelpInfo -> Option x -> b)
        -> Parser a
        -> OptTree b
-    go _ _ _ _ (NilP _) = MultNode []
-    go m d r f (OptP opt)
+    go _ _ _ (NilP _) = MultNode []
+    go m r f (OptP opt)
       | optVisibility opt > Internal
-      = Leaf (f (OptHelpInfo m d r) opt)
+      = Leaf (f (OptHelpInfo m r) opt)
       | otherwise
       = MultNode []
-    go m d r f (MultP p1 p2) =
-      MultNode [go m d r f p1, go m d r' f p2]
+    go m r f (MultP p1 p2) =
+      MultNode [go m r f p1, go m r' f p2]
       where r' = r || hasArg p1
-    go m d r f p@(AltP p1 p2) =
-      AltNode altNodeType [go m d' r f p1, go m d' r f p2]
+    go m r f (AltP p1 p2) =
+      AltNode altNodeType [go m r f p1, go m r f p2]
       where
-        -- The 'altNodeType' variable tracks whether or not this node of the
-        -- 'OptTree' ought to be displayed with brackets or not. Generally, we want
-        -- to put brackets around it when the parser has optional arguments, but if
-        -- *both* of its children also have optional arguments, then we don't put
-        -- brackets around the top-level because that would be redundant.
-        altNodeType | has_default p && not (has_default p1 && has_default p2) = MarkDefault
-                    | otherwise = NoDefault
-        -- The 'd' variable tracks whether the option nodes at the leaves have
-        -- optional arguments so that when we want to hide optional arguments, we
-        -- have the information needed to do that. An option can be considered
-        -- optional in this sense if any of its parents were optional.
-        d' = d || altNodeType == MarkDefault
-    go _ d r f (BindP p k) =
-      let go' = go True d r f p
+        -- The 'AltNode' indicates if one of the branches has a default.
+        -- This is used for rendering brackets, as well as filtering
+        -- out optional arguments when generating the "missing:" text.
+        altNodeType =
+          if has_default p1 || has_default p2
+            then MarkDefault
+            else NoDefault
+
+    go _ r f (BindP p k) =
+      let go' = go True r f p
       in case evalParser p of
         Nothing -> go'
-        Just aa -> MultNode [ go', go True d r f (k aa) ]
+        Just aa -> MultNode [ go', go True r f (k aa) ]
 
     hasArg :: Parser a -> Bool
     hasArg (NilP _) = False
@@ -307,11 +302,6 @@ treeMapParser g = simplify . go False False False g
 
 simplify :: OptTree a -> OptTree a
 simplify (Leaf x) = Leaf x
-simplify (AltNode b xs) = AltNode b (concatMap (remove_alt . simplify) xs)
-  where
-    remove_alt (AltNode _ ts) = map simplify ts
-    remove_alt (MultNode []) = []
-    remove_alt t = [simplify t]
 simplify (MultNode xs) =
   case concatMap (remove_mult . simplify) xs of
     [x] -> x
@@ -319,3 +309,9 @@ simplify (MultNode xs) =
   where
     remove_mult (MultNode ts) = ts
     remove_mult t = [t]
+simplify (AltNode b xs) =
+  AltNode b (concatMap (remove_alt . simplify) xs)
+  where
+    remove_alt (AltNode _ ts) = ts
+    remove_alt (MultNode []) = []
+    remove_alt t = [t]

Options/Applicative/Help/Core.hs

@@ -30,9 +30,7 @@ import Options.Applicative.Help.Chunk
 -- | Style for rendering an option.
 data OptDescStyle = OptDescStyle
   { descSep :: Doc
-  , descHidden :: Bool
-  , descOptional :: Bool
-  , descSurround :: Bool }
+  , descHidden :: Bool }
 
 -- | Generate description for a single option.
 optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> (Chunk Doc, Wrapping)
@@ -42,8 +40,6 @@ optDesc pprefs style info opt =
       descs = map (string . showOption) (sort ns)
       desc  = listToChunk (intersperse (descSep style) descs) <<+>> mv
       show_opt
-        | hinfoDefault info && not (descOptional style)
-        = False
         | optVisibility opt == Hidden
         = descHidden style
         | otherwise
@@ -88,15 +84,20 @@ 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 = wrap NoDefault . foldTree . treeMapParser (optDesc pprefs style)
+briefDesc' showOptional pprefs
+    = wrap NoDefault . foldTree . mfilterOptional . treeMapParser (optDesc pprefs style)
   where
+    mfilterOptional
+      | showOptional
+      = id
+      | otherwise
+      = filterOptional
+
     style = OptDescStyle
       { descSep = string "|"
-      , descHidden = False
-      , descOptional = showOptional
-      , descSurround = True }
+      , descHidden = False }
 
--- | Potentially wrap a doc in parentheses or brackets as required.
+-- | Wrap a doc in parentheses or brackets if required.
 wrap :: AltNodeType ->  (Chunk Doc, Wrapping) -> Chunk Doc
 wrap altnode (chunk, wrapping)
   | altnode == MarkDefault
@@ -109,19 +110,22 @@ wrap altnode (chunk, wrapping)
 -- Fold a tree of option docs into a single doc with fully marked
 -- optional areas and groups.
 foldTree :: OptTree (Chunk Doc, Wrapping) -> (Chunk Doc, Wrapping)
-foldTree (Leaf x) = x
-foldTree (MultNode xs) = (foldr ((<</>>) . fst . foldTree) mempty xs, Bare)
-foldTree (AltNode b xs) = (\x -> (x, Bare))
-                           . wrap b
-                           . alt_node
-                           . filter (not . isEmpty . fst)
-                           . map foldTree $ xs
-  where
-    alt_node :: [(Chunk Doc, Wrapping)] -> (Chunk Doc, Wrapping)
-    alt_node [n] = n
-    alt_node ns = (\y -> (y, Wrapped))
-                . foldr (chunked (\x y -> x </> char '|' </> y) . wrap NoDefault) mempty
-                $ ns
+foldTree (Leaf x)
+  = x
+foldTree (MultNode xs)
+  = (foldr ((<</>>) . wrap NoDefault . foldTree) mempty xs, Bare)
+foldTree (AltNode b xs)
+  = (\x -> (x, Bare))
+  . wrap b
+  . alt_node
+  . filter (not . isEmpty . fst)
+  . map foldTree $ xs
+    where
+  alt_node :: [(Chunk Doc, Wrapping)] -> (Chunk Doc, Wrapping)
+  alt_node [n] = n
+  alt_node ns = (\y -> (y, Wrapped))
+              . foldr (chunked (\x y -> x </> char '|' </> y) . wrap NoDefault) mempty
+              $ ns
 
 -- | Generate a full help text for a parser.
 fullDesc :: ParserPrefs -> Parser a -> Chunk Doc
@@ -138,9 +142,7 @@ fullDesc pprefs = tabulate . catMaybes . mapParser doc
         show_def s = parens (string "default:" <+> string s)
     style = OptDescStyle
       { descSep = string ","
-      , descHidden = True
-      , descOptional = True
-      , descSurround = False }
+      , descHidden = True }
 
 errorHelp :: Chunk Doc -> ParserHelp
 errorHelp chunk = mempty { helpError = chunk }
@@ -194,4 +196,4 @@ wrapIf :: Bool -> Wrapping
 wrapIf b = if b then Wrapped else Bare
 
 needsWrapping :: Wrapping -> Bool
-needsWrapping = (==)  Wrapped
+needsWrapping = (==) Wrapped

Options/Applicative/Types.hs

@@ -38,6 +38,7 @@ module Options.Applicative.Types (
   manyM,
   someM,
 
+  filterOptional,
   optVisibility,
   optMetaVar,
   optHelp,
@@ -376,8 +377,7 @@ data ArgPolicy
   deriving (Eq, Ord, Show)
 
 data OptHelpInfo = OptHelpInfo
-  { hinfoMulti :: Bool    -- ^ Whether this is part of a many or some (approximately)
-  , hinfoDefault :: Bool  -- ^ Whether this option has a default value
+  { hinfoMulti :: Bool           -- ^ Whether this is part of a many or some (approximately)
   , hinfoUnreachableArgs :: Bool -- ^ If the result is a positional, if it can't be
                                  --   accessed in the current parser position ( first arg )
   } deriving (Eq, Show)
@@ -393,6 +393,17 @@ data OptTree a
   | AltNode AltNodeType [OptTree a]
   deriving Show
 
+filterOptional :: OptTree a -> OptTree a
+filterOptional t = case t of
+  Leaf a
+    -> Leaf a
+  MultNode xs
+    -> MultNode (map filterOptional xs)
+  AltNode MarkDefault _
+    -> AltNode MarkDefault []
+  AltNode NoDefault xs
+    -> AltNode NoDefault (map filterOptional xs)
+
 optVisibility :: Option a -> OptVisibility
 optVisibility = propVisibility . optProps
 

tests/test.hs

@@ -812,7 +812,7 @@ prop_edit_substitution as bs a b = a /= b ==>
 
 prop_edit_transposition :: [Char] -> [Char] -> Char -> Char -> Property
 prop_edit_transposition as bs a b = a /= b ==>
-  editDistance (as ++ [a] ++ [b] ++ bs) (as ++ [b] ++ [a] ++ bs) === 1
+  editDistance (as ++ [a,b] ++ bs) (as ++ [b,a] ++ bs) === 1
 
 ---