Add suggestions for typos

Uses a Levenshtein distance to see if there's a suitable
candidate for suggestions.

Also fixes a subtle bug in bash completions, where argument
completers from deeper into the parser would have their
possibilities added to the completion.

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]

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

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
 

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

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

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

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