diff --git a/Options/Applicative/BashCompletion.hs b/Options/Applicative/BashCompletion.hs index fa84c06d..31145cf7 100644 --- a/Options/Applicative/BashCompletion.hs +++ b/Options/Applicative/BashCompletion.hs @@ -40,16 +40,30 @@ bashCompletionQuery pinfo pprefs ws i _ = case runCompletion compl pprefs of Just (Right c) -> run_completer c _ -> return [] where - list_options = - fmap concat + list_options + = fmap concat . sequence - . mapParser (const opt_completions) + . mapParser opt_completions - opt_completions opt = case optMain opt of + -- + -- Prior to 0.14 there was a subtle bug which would + -- mean that completions from positional arguments + -- further into the parse would be shown. + -- + -- We therefore now check to see that + -- hinfoUnreachableArgs is off before running the + -- completion for position arguments. + opt_completions hinfo opt = case optMain opt of OptReader ns _ _ -> return $ show_names ns FlagReader ns _ -> return $ show_names ns - ArgReader rdr -> run_completer (crCompleter rdr) - CmdReader _ ns _ -> return $ filter_names ns + ArgReader rdr | hinfoUnreachableArgs hinfo + -> return [] + | otherwise + -> run_completer (crCompleter rdr) + CmdReader _ ns _ | hinfoUnreachableArgs hinfo + -> return [] + | otherwise + -> return $ filter_names ns show_name :: OptName -> String show_name (OptShort c) = '-':[c] diff --git a/Options/Applicative/Common.hs b/Options/Applicative/Common.hs index c60b1ed7..38d8dc86 100644 --- a/Options/Applicative/Common.hs +++ b/Options/Applicative/Common.hs @@ -201,7 +201,7 @@ runParser policy isCmdStart p args = case args of prefs <- getPrefs (mp', args') <- do_step prefs arg argt case mp' of - Nothing -> hoistMaybe result <|> parseError arg + Nothing -> hoistMaybe result <|> parseError arg p Just p' -> runParser (newPolicy arg) CmdCont p' args' where result = (,) <$> evalParser p <*> pure args @@ -213,12 +213,8 @@ runParser policy isCmdStart p args = case args of NoIntersperse -> if isJust (parseWord a) then NoIntersperse else AllPositionals x -> x -parseError :: MonadP m => String -> m a -parseError arg = errorP . ErrorMsg $ msg - where - msg = case arg of - ('-':_) -> "Invalid option `" ++ arg ++ "'" - _ -> "Invalid argument `" ++ arg ++ "'" +parseError :: MonadP m => String -> Parser x -> m a +parseError arg = errorP . UnexpectedError arg . SomeParser runParserInfo :: MonadP m => ParserInfo a -> Args -> m a runParserInfo i = runParserFully (infoPolicy i) (infoParser i) @@ -228,7 +224,7 @@ runParserFully policy p args = do (r, args') <- runParser policy CmdStart p args case args' of [] -> return r - a:_ -> parseError a + a:_ -> parseError a (pure ()) -- | The default value of a 'Parser'. This function returns an error if any of -- the options don't have a default value. @@ -242,7 +238,7 @@ evalParser (BindP p k) = evalParser p >>= evalParser . k -- | Map a polymorphic function over all the options of a parser, and collect -- the results in a list. mapParser :: (forall x. OptHelpInfo -> Option x -> b) - -> Parser a -> [b] + -> Parser a -> [b] mapParser f = flatten . treeMapParser f where flatten (Leaf x) = [x] @@ -253,25 +249,40 @@ mapParser f = flatten . treeMapParser f treeMapParser :: (forall x . OptHelpInfo -> Option x -> b) -> Parser a -> OptTree b -treeMapParser g = simplify . go False False g +treeMapParser g = simplify . go False False False g where has_default :: Parser a -> Bool has_default p = isJust (evalParser p) - go :: Bool -> Bool + go :: Bool -> Bool -> Bool -> (forall x . OptHelpInfo -> Option x -> b) -> Parser a -> OptTree b - go _ _ _ (NilP _) = MultNode [] - go m d f (OptP opt) + go _ _ _ _ (NilP _) = MultNode [] + go m d r f (OptP opt) | optVisibility opt > Internal - = Leaf (f (OptHelpInfo m d) opt) + = Leaf (f (OptHelpInfo m d r) opt) | otherwise = MultNode [] - go m d f (MultP p1 p2) = MultNode [go m d f p1, go m d f p2] - go m d f (AltP p1 p2) = AltNode [go m d' f p1, go m d' f p2] + go m d r f (MultP p1 p2) = MultNode [go m d r f p1, go m d r' f p2] + where r' = r || has_positional p1 + go m d r f (AltP p1 p2) = AltNode [go m d' r f p1, go m d' r f p2] where d' = d || has_default p1 || has_default p2 - go _ d f (BindP p _) = go True d f p + go _ d r f (BindP p _) = go True d r f p + + has_positional :: Parser a -> Bool + has_positional (NilP _) = False + has_positional (OptP p) = (is_positional . optMain) p + has_positional (MultP p1 p2) = has_positional p1 || has_positional p2 + has_positional (AltP p1 p2) = has_positional p1 || has_positional p2 + has_positional (BindP p _) = has_positional p + + is_positional :: OptReader a -> Bool + is_positional (OptReader {}) = False + is_positional (FlagReader {}) = False + is_positional (ArgReader {}) = True + is_positional (CmdReader {}) = True + simplify :: OptTree a -> OptTree a simplify (Leaf x) = Leaf x diff --git a/Options/Applicative/Extra.hs b/Options/Applicative/Extra.hs index a814801e..1ace1321 100644 --- a/Options/Applicative/Extra.hs +++ b/Options/Applicative/Extra.hs @@ -33,6 +33,7 @@ import Options.Applicative.Builder hiding (briefDesc) import Options.Applicative.Builder.Internal import Options.Applicative.Common import Options.Applicative.Help +import Options.Applicative.Help.Levenshtein ( editDistance ) import Options.Applicative.Internal import Options.Applicative.Types @@ -147,11 +148,12 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn -> in (h, exit_code, prefColumns pprefs) where exit_code = case msg of - ErrorMsg _ -> ExitFailure (infoFailureCode pinfo) - UnknownError -> ExitFailure (infoFailureCode pinfo) - MissingError _ _ -> ExitFailure (infoFailureCode pinfo) - ShowHelpText -> ExitSuccess - InfoMsg _ -> ExitSuccess + ErrorMsg {} -> ExitFailure (infoFailureCode pinfo) + UnknownError -> ExitFailure (infoFailureCode pinfo) + MissingError {} -> ExitFailure (infoFailureCode pinfo) + UnexpectedError {} -> ExitFailure (infoFailureCode pinfo) + ShowHelpText -> ExitSuccess + InfoMsg {} -> ExitSuccess with_context :: [Context] -> ParserInfo a @@ -167,13 +169,89 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn -> , fmap (indent 2) . infoProgDesc $ i ] error_help = errorHelp $ case msg of - ShowHelpText -> mempty - ErrorMsg m -> stringChunk m - InfoMsg m -> stringChunk m - MissingError CmdStart _ | prefShowHelpOnEmpty pprefs - -> mempty - MissingError _ (SomeParser x) -> stringChunk "Missing:" <<+>> missingDesc pprefs x - UnknownError -> mempty + ShowHelpText + -> mempty + + ErrorMsg m + -> stringChunk m + + InfoMsg m + -> stringChunk m + + MissingError CmdStart _ + | prefShowHelpOnEmpty pprefs + -> mempty + + MissingError _ (SomeParser x) + -> stringChunk "Missing:" <<+>> missingDesc pprefs x + + UnexpectedError arg (SomeParser x) + -- + -- We have an unexpected argument and the parser which + -- it's running over. + -- + -- We can make a good help suggestion here if we do + -- a levenstein distance between all possible suggestions + -- and the supplied option or argument. + -- + -> vsepChunks [stringChunk msg', suggestions] + where + -- + -- This gives us the same error we have always + -- reported + msg' = case arg of + ('-':_) -> "Invalid option `" ++ arg ++ "'" + _ -> "Invalid argument `" ++ arg ++ "'" + + -- + -- Not using chunked here, as we don't want to + -- show "Did you mean" if there's nothing there + -- to show + suggestions = (.$.) <$> prose + <*> (indent 4 <$> (vcatChunks . fmap stringChunk $ good )) + + -- + -- We won't worry about the 0 case, it won't be + -- shown anyway. + prose = if length good < 2 + then stringChunk "Did you mean this?" + else stringChunk "Did you mean one of these?" + -- + -- Suggestions we will show, they're close enough + -- to what the user wrote + good = filter (isClose arg) possibles + + -- + -- Bit of an arbitrary decision here. + -- Edit distances of 1 or 2 will give hints + isClose a b = editDistance a b < 3 + + -- + -- Similar to how bash completion works. + -- We map over the parser and get the names + -- ( no IO here though, unlike for completers ) + possibles = concat $ mapParser opt_completions x + + -- + -- Look at the option and give back the possible + -- things the user could type. If it's a command + -- reader also ensure that it can be immediately + -- reachable from where the error was given. + opt_completions hinfo opt = case optMain opt of + OptReader ns _ _ -> fmap show_name ns + FlagReader ns _ -> fmap show_name ns + ArgReader _ -> [] + CmdReader _ ns _ | hinfoUnreachableArgs hinfo + -> [] + | otherwise + -> ns + + show_name :: OptName -> String + show_name (OptShort c) = '-':[c] + show_name (OptLong l) = "--" ++ l + + UnknownError + -> mempty base_help :: ParserInfo a -> ParserHelp base_help i @@ -187,7 +265,7 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn -> show_full_help = case msg of ShowHelpText -> True - MissingError CmdStart _ | prefShowHelpOnEmpty pprefs + MissingError CmdStart _ | prefShowHelpOnEmpty pprefs -> True _ -> prefShowHelpOnError pprefs diff --git a/Options/Applicative/Help/Levenshtein.hs b/Options/Applicative/Help/Levenshtein.hs new file mode 100644 index 00000000..a0a68a53 --- /dev/null +++ b/Options/Applicative/Help/Levenshtein.hs @@ -0,0 +1,54 @@ +module Options.Applicative.Help.Levenshtein ( + editDistance + ) where + +-- | Calculate the Damerau-Levenshtein edit distance +-- between two lists (strings). +-- +-- Optparse can't really take on any dependencies +-- so we're bringing it in here. +-- +-- This is modified from +-- https://wiki.haskell.org/Edit_distance +-- and is originally from Lloyd Allison's paper +-- "Lazy Dynamic-Programming can be Eager" +-- +-- It's been changed though from Levenshtein to +-- Damerau-Levenshtein, which treats transposition +-- of adjacent characters as one change instead of +-- two. +-- +-- The significant difference is an extra case to +-- doDiag, which checks if it's actually a +-- transposition. +-- +-- As there are a few ugly partial function calls +-- there's property tests to ensure it doesn't +-- crash :/ and obeys the laws. +-- +editDistance :: Eq a => [a] -> [a] -> Int +editDistance a b + = last (if lab == 0 then mainDiag + else if lab > 0 then lowers !! (lab - 1) + else {- < 0 -} uppers !! (-1 - lab)) + where mainDiag = oneDiag a b (head uppers) (-1 : head lowers) + uppers = eachDiag a b (mainDiag : uppers) -- upper diagonals + lowers = eachDiag b a (mainDiag : lowers) -- lower diagonals + eachDiag _ [] _ = [] + eachDiag _ _ [] = [] + eachDiag a' (_:bs) (lastDiag:diags) = oneDiag a' bs nextDiag lastDiag : eachDiag a' bs diags + where nextDiag = head (tail diags) + oneDiag a' b' diagAbove diagBelow = thisdiag + where doDiag [] _ _ _ _ = [] + doDiag _ [] _ _ _ = [] + -- Check for a transposition + doDiag (ach:ach':as) (bch:bch':bs) nw n w + | ach' == bch && ach == bch' + = nw : (doDiag (ach':as) (bch':bs) nw (tail n) (tail w)) + -- Usual case + doDiag (ach:as) (bch:bs) nw n w = me : (doDiag as bs me (tail n) (tail w)) + where me = if ach == bch then nw else 1 + min3 (head w) nw (head n) + firstelt = 1 + head diagBelow + thisdiag = firstelt : doDiag a' b' firstelt diagAbove (tail diagBelow) + lab = length a - length b + min3 x y z = if x < y then x else min y z diff --git a/Options/Applicative/Types.hs b/Options/Applicative/Types.hs index f4bd1485..dec3a901 100644 --- a/Options/Applicative/Types.hs +++ b/Options/Applicative/Types.hs @@ -63,6 +63,7 @@ data ParseError | ShowHelpText | UnknownError | MissingError IsCmdStart SomeParser + | UnexpectedError String SomeParser data IsCmdStart = CmdStart | CmdCont deriving Show @@ -343,8 +344,10 @@ data ArgPolicy deriving (Eq, Ord, Show) data OptHelpInfo = OptHelpInfo - { hinfoMulti :: Bool - , hinfoDefault :: Bool + { hinfoMulti :: Bool -- ^ Whether this is part of a many or some (approximately) + , hinfoDefault :: Bool -- ^ Whether this option has a default value + , hinfoUnreachableArgs :: Bool -- ^ If the result is a positional, if it can't be + -- accessed in the current parser position ( first arg ) } deriving (Eq, Show) data OptTree a diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal index a7bc6fd3..7c968d68 100644 --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -112,9 +112,10 @@ library Options.Applicative.Common, Options.Applicative.Extra, Options.Applicative.Help, - Options.Applicative.Help.Pretty, Options.Applicative.Help.Chunk, Options.Applicative.Help.Core, + Options.Applicative.Help.Levenshtein, + Options.Applicative.Help.Pretty, Options.Applicative.Help.Types, Options.Applicative.Types, Options.Applicative.Internal diff --git a/tests/test.hs b/tests/test.hs index 411b3417..f32f0a72 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -24,6 +24,7 @@ import Options.Applicative.Types import Options.Applicative.Help.Pretty (Doc, SimpleDoc(..)) import qualified Options.Applicative.Help.Pretty as Doc import Options.Applicative.Help.Chunk +import Options.Applicative.Help.Levenshtein import Prelude @@ -225,6 +226,20 @@ prop_completion = once . ioProperty $ Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed +prop_completion_only_reachable :: Property +prop_completion_only_reachable = once . ioProperty $ + let p = (,) + <$> strArgument (completeWith ["reachable"]) + <*> strArgument (completeWith ["unreachable"]) + i = info p idm + result = run i ["--bash-completion-index", "0"] + in case result of + CompletionInvoked (CompletionResult err) -> do + completions <- lines <$> err "test" + return $ ["reachable"] === completions + Failure _ -> return $ counterexample "unexpected failure" failed + Success val -> return $ counterexample ("unexpected result " ++ show val) failed + prop_bind_usage :: Property prop_bind_usage = once $ let p = many (argument str (metavar "ARGS...")) @@ -559,6 +574,38 @@ prop_paragraph s = isEmpty (paragraph s) === null (words s) --- +-- +-- From +-- https://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance +-- +-- In information theory and computer science, the Damerau–Levenshtein +-- distance is a distance (string metric) between two strings, i.e., +-- finite sequence of symbols, given by counting the minimum number +-- of operations needed to transform one string into the other, where +-- an operation is defined as an insertion, deletion, or substitution +-- of a single character, or a transposition of two adjacent characters. +-- +prop_edit_distance_gezero :: String -> String -> Bool +prop_edit_distance_gezero a b = editDistance a b >= 0 + +prop_edit_insertion :: [Char] -> Char -> [Char] -> Property +prop_edit_insertion as i bs = + editDistance (as ++ bs) (as ++ [i] ++ bs) === 1 + +prop_edit_symmetric :: [Char] -> [Char] -> Property +prop_edit_symmetric as bs = + editDistance as bs === editDistance bs as + +prop_edit_substitution :: [Char] -> [Char] -> Char -> Char -> Property +prop_edit_substitution as bs a b = a /= b ==> + editDistance (as ++ [a] ++ bs) (as ++ [b] ++ bs) === 1 + +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 + +--- + return [] main :: IO () main = do