mirror of
https://github.com/ilyakooo0/optparse-applicative.git
synced 2024-09-11 10:45:25 +03:00
Put suggestions into their own ParserHelp record.
This would allow one to either delete them or not show things like usage if there is a suggestion.
This commit is contained in:
parent
7f292eba34
commit
f66ff9b083
@ -144,6 +144,7 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
|
||||
let h = with_context ctx pinfo $ \names pinfo' -> mconcat
|
||||
[ base_help pinfo'
|
||||
, usage_help progn names pinfo'
|
||||
, suggestion_help
|
||||
, error_help ]
|
||||
in (h, exit_code, prefColumns pprefs)
|
||||
where
|
||||
@ -185,6 +186,22 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
|
||||
MissingError _ (SomeParser x)
|
||||
-> stringChunk "Missing:" <<+>> missingDesc pprefs x
|
||||
|
||||
UnexpectedError arg _
|
||||
-> stringChunk msg'
|
||||
where
|
||||
--
|
||||
-- This gives us the same error we have always
|
||||
-- reported
|
||||
--
|
||||
msg' = case arg of
|
||||
('-':_) -> "Invalid option `" ++ arg ++ "'"
|
||||
_ -> "Invalid argument `" ++ arg ++ "'"
|
||||
|
||||
UnknownError
|
||||
-> mempty
|
||||
|
||||
|
||||
suggestion_help = suggestionsHelp $ case msg of
|
||||
UnexpectedError arg (SomeParser x)
|
||||
--
|
||||
-- We have an unexpected argument and the parser which
|
||||
@ -194,15 +211,8 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
|
||||
-- a levenstein distance between all possible suggestions
|
||||
-- and the supplied option or argument.
|
||||
--
|
||||
-> vsepChunks [stringChunk msg', suggestions]
|
||||
-> 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
|
||||
@ -219,12 +229,12 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
|
||||
--
|
||||
-- Suggestions we will show, they're close enough
|
||||
-- to what the user wrote
|
||||
good = filter (isClose arg) possibles
|
||||
good = filter isClose possibles
|
||||
|
||||
--
|
||||
-- Bit of an arbitrary decision here.
|
||||
-- Edit distances of 1 or 2 will give hints
|
||||
isClose a b = editDistance a b < 3
|
||||
isClose a = editDistance a arg < 3
|
||||
|
||||
--
|
||||
-- Similar to how bash completion works.
|
||||
@ -250,7 +260,7 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
|
||||
show_name (OptShort c) = '-':[c]
|
||||
show_name (OptLong l) = "--" ++ l
|
||||
|
||||
UnknownError
|
||||
_
|
||||
-> mempty
|
||||
|
||||
base_help :: ParserInfo a -> ParserHelp
|
||||
|
@ -7,6 +7,7 @@ module Options.Applicative.Help.Core (
|
||||
ParserHelp(..),
|
||||
errorHelp,
|
||||
headerHelp,
|
||||
suggestionsHelp,
|
||||
usageHelp,
|
||||
bodyHelp,
|
||||
footerHelp,
|
||||
@ -131,19 +132,22 @@ fullDesc pprefs = tabulate . catMaybes . mapParser doc
|
||||
, descSurround = False }
|
||||
|
||||
errorHelp :: Chunk Doc -> ParserHelp
|
||||
errorHelp chunk = ParserHelp chunk mempty mempty mempty mempty
|
||||
errorHelp chunk = mempty { helpError = chunk }
|
||||
|
||||
headerHelp :: Chunk Doc -> ParserHelp
|
||||
headerHelp chunk = ParserHelp mempty chunk mempty mempty mempty
|
||||
headerHelp chunk = mempty { helpHeader = chunk }
|
||||
|
||||
suggestionsHelp :: Chunk Doc -> ParserHelp
|
||||
suggestionsHelp chunk = mempty { helpSuggestions = chunk }
|
||||
|
||||
usageHelp :: Chunk Doc -> ParserHelp
|
||||
usageHelp chunk = ParserHelp mempty mempty chunk mempty mempty
|
||||
usageHelp chunk = mempty { helpUsage = chunk }
|
||||
|
||||
bodyHelp :: Chunk Doc -> ParserHelp
|
||||
bodyHelp chunk = ParserHelp mempty mempty mempty chunk mempty
|
||||
bodyHelp chunk = mempty { helpBody = chunk }
|
||||
|
||||
footerHelp :: Chunk Doc -> ParserHelp
|
||||
footerHelp chunk = ParserHelp mempty mempty mempty mempty chunk
|
||||
footerHelp chunk = mempty { helpFooter = chunk }
|
||||
|
||||
-- | Generate the help text for a program.
|
||||
parserHelp :: ParserPrefs -> Parser a -> ParserHelp
|
||||
|
@ -1,6 +1,6 @@
|
||||
module Options.Applicative.Help.Types (
|
||||
ParserHelp(..),
|
||||
renderHelp
|
||||
ParserHelp (..)
|
||||
, renderHelp
|
||||
) where
|
||||
|
||||
import Data.Semigroup
|
||||
@ -11,6 +11,7 @@ import Options.Applicative.Help.Pretty
|
||||
|
||||
data ParserHelp = ParserHelp
|
||||
{ helpError :: Chunk Doc
|
||||
, helpSuggestions :: Chunk Doc
|
||||
, helpHeader :: Chunk Doc
|
||||
, helpUsage :: Chunk Doc
|
||||
, helpBody :: Chunk Doc
|
||||
@ -20,17 +21,17 @@ instance Show ParserHelp where
|
||||
showsPrec _ h = showString (renderHelp 80 h)
|
||||
|
||||
instance Monoid ParserHelp where
|
||||
mempty = ParserHelp mempty mempty mempty mempty mempty
|
||||
mempty = ParserHelp mempty mempty mempty mempty mempty mempty
|
||||
mappend = (<>)
|
||||
|
||||
instance Semigroup ParserHelp where
|
||||
(ParserHelp e1 h1 u1 b1 f1) <> (ParserHelp e2 h2 u2 b2 f2)
|
||||
= ParserHelp (mappend e1 e2) (mappend h1 h2)
|
||||
(mappend u1 u2) (mappend b1 b2)
|
||||
(mappend f1 f2)
|
||||
(ParserHelp e1 s1 h1 u1 b1 f1) <> (ParserHelp e2 s2 h2 u2 b2 f2)
|
||||
= ParserHelp (mappend e1 e2) (mappend s1 s2)
|
||||
(mappend h1 h2) (mappend u1 u2)
|
||||
(mappend b1 b2) (mappend f1 f2)
|
||||
|
||||
helpText :: ParserHelp -> Doc
|
||||
helpText (ParserHelp e h u b f) = extractChunk . vsepChunks $ [e, h, u, b, f]
|
||||
helpText (ParserHelp e s h u b f) = extractChunk . vsepChunks $ [e, s, h, u, b, f]
|
||||
|
||||
-- | Convert a help text to 'String'.
|
||||
renderHelp :: Int -> ParserHelp -> String
|
||||
|
@ -1,3 +1,6 @@
|
||||
Invalid option `-zzz'
|
||||
Invalid option `-zello'
|
||||
|
||||
Did you mean this?
|
||||
hello
|
||||
|
||||
Usage: commands_header COMMAND
|
||||
|
@ -1,4 +1,7 @@
|
||||
Invalid option `-zzz'
|
||||
Invalid option `-zello'
|
||||
|
||||
Did you mean this?
|
||||
hello
|
||||
|
||||
foo
|
||||
|
||||
|
@ -74,9 +74,9 @@ prop_cmd_header :: Property
|
||||
prop_cmd_header = once $
|
||||
let i = info (helper <*> Commands.sample) (header "foo")
|
||||
r1 = checkHelpTextWith (ExitFailure 1) defaultPrefs
|
||||
"commands_header" i ["-zzz"]
|
||||
"commands_header" i ["-zello"]
|
||||
r2 = checkHelpTextWith (ExitFailure 1) (prefs showHelpOnError)
|
||||
"commands_header_full" i ["-zzz"]
|
||||
"commands_header_full" i ["-zello"]
|
||||
in (r1 .&&. r2)
|
||||
|
||||
prop_cabal_conf :: Property
|
||||
@ -549,7 +549,7 @@ prop_suggest = once $
|
||||
in assertError result $ \failure ->
|
||||
let (msg, _) = renderFailure failure "prog"
|
||||
in counterexample msg
|
||||
$ isInfixOf "Did you mean this?\n reachable\n" msg
|
||||
$ isInfixOf "Did you mean this?\n reachable" msg
|
||||
.&. not (isInfixOf "unreachable" msg)
|
||||
|
||||
---
|
||||
|
Loading…
Reference in New Issue
Block a user