From 0b83cf1099bb31b589c26559755221d4a1d4d6c7 Mon Sep 17 00:00:00 2001 From: Huw Campbell Date: Thu, 14 Mar 2019 07:49:19 +1100 Subject: [PATCH] Use tree to filter out optionals, instead of annotating the leaves --- Options/Applicative/Builder/Internal.hs | 8 ++-- Options/Applicative/Common.hs | 54 +++++++++++------------- Options/Applicative/Help/Core.hs | 56 +++++++++++++------------ Options/Applicative/Types.hs | 15 ++++++- tests/test.hs | 2 +- 5 files changed, 73 insertions(+), 62 deletions(-) diff --git a/Options/Applicative/Builder/Internal.hs b/Options/Applicative/Builder/Internal.hs index 25d1bc6..be8f941 100644 --- a/Options/Applicative/Builder/Internal.hs +++ b/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) diff --git a/Options/Applicative/Common.hs b/Options/Applicative/Common.hs index 31ba011..b9225b0 100644 --- a/Options/Applicative/Common.hs +++ b/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] diff --git a/Options/Applicative/Help/Core.hs b/Options/Applicative/Help/Core.hs index 920c275..442e951 100644 --- a/Options/Applicative/Help/Core.hs +++ b/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 diff --git a/Options/Applicative/Types.hs b/Options/Applicative/Types.hs index cd2cd6a..fa6554d 100644 --- a/Options/Applicative/Types.hs +++ b/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 diff --git a/tests/test.hs b/tests/test.hs index a865ff2..8233d00 100644 --- a/tests/test.hs +++ b/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 ---