Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Fix Context for nested commands.

  • Loading branch information...
commit 573162700c7b329fe31059289a588c1e64d5e7dd 1 parent f5585f6
@pcapriotti authored
View
6 Options/Applicative/Common.hs
@@ -99,7 +99,7 @@ optMatches rdr arg = case rdr of
CmdReader _ f
| Just subp <- f arg
-> Just $ \args -> do
- setContext (Just arg) subp
+ setContext arg subp
runParser (infoParser subp) args
_ -> Nothing
where
@@ -121,8 +121,8 @@ tryP = maybe empty return
runP :: P a -> (Either String a, Context)
runP = runWriter . runErrorT
-setContext :: Maybe String -> ParserInfo a -> P ()
-setContext name = lift . tell . Context name
+setContext :: String -> ParserInfo a -> P ()
+setContext name = lift . tell . Context [name]
stepParser :: Parser a -> String -> [String] -> P (Parser a, [String])
stepParser (NilP _) _ _ = empty
View
12 Options/Applicative/Extra.hs
@@ -56,27 +56,27 @@ execParserPure pprefs pinfo args =
(Right a, _) -> Right a
(Left msg, ctx) -> Left ParserFailure
{ errMessage = \progn
- -> with_context ctx pinfo $ \name ->
+ -> with_context ctx pinfo $ \names ->
parserHelpText pprefs
. add_error msg
- . add_usage name progn
+ . add_usage names progn
, errExitCode = ExitFailure (infoFailureCode pinfo) }
where
parser = infoParser pinfo
- add_usage name progn i = i
+ add_usage names progn i = i
{ infoHeader = vcat
[ infoHeader i
, usage pprefs (infoParser i) ename ] }
where
- ename = maybe progn (\n -> progn ++ " " ++ n) name
+ ename = unwords (progn : names)
add_error msg i = i
{ infoHeader = vcat [msg, infoHeader i] }
with_context :: Context
-> ParserInfo a
- -> (forall b . Maybe String -> ParserInfo b -> c)
+ -> (forall b . [String] -> ParserInfo b -> c)
-> c
- with_context NullContext i f = f Nothing i
+ with_context NullContext i f = f [] i
with_context (Context n i) _ f = f n i
p = runParserFully parser args
View
8 Options/Applicative/Types.hs
@@ -46,12 +46,16 @@ data ParserPrefs = ParserPrefs
}
data Context where
- Context :: Maybe String -> ParserInfo a -> Context
+ Context :: [String] -> ParserInfo a -> Context
NullContext :: Context
+contextNames :: Context -> [String]
+contextNames (Context ns _) = ns
+contextNames NullContext = []
+
instance Monoid Context where
mempty = NullContext
- mappend _ c@(Context _ _) = c
+ mappend c (Context ns i) = Context (contextNames c ++ ns) i
mappend c _ = c
type P = ErrorT String (Writer Context)
View
8 tests/Tests.hs
@@ -122,5 +122,13 @@ case_alt_help = do
i = info (p <**> helper) idm
checkHelpText "alt" i ["--help"]
+case_nested_commands :: Assertion
+case_nested_commands = do
+ let p3 = strOption (short 'a' & metavar "A")
+ p2 = subparser (command "b" (info p3 idm))
+ p1 = subparser (command "c" (info p2 idm))
+ i = info (p1 <**> helper) idm
+ checkHelpText "nested" i ["c", "b"]
+
main :: IO ()
main = $(defaultMainGenerator)
View
1  tests/nested.err.txt
@@ -0,0 +1 @@
+Usage: nested c b -a A
Please sign in to comment.
Something went wrong with that request. Please try again.