Skip to content

Commit 2abc5b0

Browse files
authored
Merge pull request #318 from pcapriotti/topic/subparser-reimplementation-breaking
Allow inlining of subparsers instead of independent execution
2 parents 5e377c0 + 4205047 commit 2abc5b0

File tree

5 files changed

+69
-43
lines changed

5 files changed

+69
-43
lines changed

Options/Applicative.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -193,6 +193,7 @@ module Options.Applicative (
193193
showHelpOnError,
194194
showHelpOnEmpty,
195195
noBacktrack,
196+
subparserInline,
196197
columns,
197198
defaultPrefs,
198199

Options/Applicative/Builder.hs

Lines changed: 11 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -83,6 +83,7 @@ module Options.Applicative.Builder (
8383
showHelpOnError,
8484
showHelpOnEmpty,
8585
noBacktrack,
86+
subparserInline,
8687
columns,
8788
prefs,
8889
defaultPrefs,
@@ -485,7 +486,15 @@ showHelpOnEmpty = PrefsMod $ \p -> p { prefShowHelpOnEmpty = True }
485486

486487
-- | Turn off backtracking after subcommand is parsed.
487488
noBacktrack :: PrefsMod
488-
noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False }
489+
noBacktrack = PrefsMod $ \p -> p { prefBacktrack = NoBacktrack }
490+
491+
-- | Allow full mixing of subcommand and parent arguments by inlining
492+
-- selected subparsers into the parent parser.
493+
--
494+
-- /NOTE:/ When this option is used, preferences for the subparser which
495+
-- effect the parser behaviour (such as noIntersperse) are ignored.
496+
subparserInline :: PrefsMod
497+
subparserInline = PrefsMod $ \p -> p { prefBacktrack = SubparserInline }
489498

490499
-- | Set the maximum width of the generated help text.
491500
columns :: Int -> PrefsMod
@@ -500,7 +509,7 @@ prefs m = applyPrefsMod m base
500509
, prefDisambiguate = False
501510
, prefShowHelpOnError = False
502511
, prefShowHelpOnEmpty = False
503-
, prefBacktrack = True
512+
, prefBacktrack = Backtrack
504513
, prefColumns = 80 }
505514

506515
-- Convenience shortcuts

Options/Applicative/Common.hs

Lines changed: 29 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,7 @@ module Options.Applicative.Common (
5151
) where
5252

5353
import Control.Applicative
54-
import Control.Monad (guard, mzero, msum, when, liftM)
54+
import Control.Monad (guard, mzero, msum, when)
5555
import Control.Monad.Trans.Class (lift)
5656
import Control.Monad.Trans.State (StateT(..), get, put, runStateT)
5757
import Data.List (isPrefixOf)
@@ -79,22 +79,6 @@ isOptionPrefix _ _ = False
7979
liftOpt :: Option a -> Parser a
8080
liftOpt = OptP
8181

82-
argMatches :: MonadP m => OptReader a -> String
83-
-> Maybe (StateT Args m a)
84-
argMatches opt arg = case opt of
85-
ArgReader rdr -> Just . lift $
86-
runReadM (crReader rdr) arg
87-
CmdReader _ _ f ->
88-
flip fmap (f arg) $ \subp -> StateT $ \args -> do
89-
prefs <- getPrefs
90-
let runSubparser
91-
| prefBacktrack prefs = \i a ->
92-
runParser (infoPolicy i) CmdStart (infoParser i) a
93-
| otherwise = \i a
94-
-> (,) <$> runParserInfo i a <*> pure []
95-
enterContext arg subp *> runSubparser subp args <* exitContext
96-
_ -> Nothing
97-
9882
optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)
9983
optMatches disambiguate opt (OptWord arg1 val) = case opt of
10084
OptReader names rdr no_arg_err -> do
@@ -150,10 +134,10 @@ parseWord ('-' : w) = case w of
150134
parseWord _ = Nothing
151135

152136
searchParser :: Monad m
153-
=> (forall r . Option r -> NondetT m r)
137+
=> (forall r . Option r -> NondetT m (Parser r))
154138
-> Parser a -> NondetT m (Parser a)
155139
searchParser _ (NilP _) = mzero
156-
searchParser f (OptP opt) = liftM pure (f opt)
140+
searchParser f (OptP opt) = f opt
157141
searchParser f (MultP p1 p2) = foldr1 (<!>)
158142
[ do p1' <- searchParser f p1
159143
return (p1' <*> p2)
@@ -175,27 +159,42 @@ searchOpt pprefs w = searchParser $ \opt -> do
175159
let disambiguate = prefDisambiguate pprefs
176160
&& optVisibility opt > Internal
177161
case optMatches disambiguate (optMain opt) w of
178-
Just matcher -> lift matcher
162+
Just matcher -> lift $ fmap pure matcher
179163
Nothing -> mzero
180164

181-
searchArg :: MonadP m => String -> Parser a
165+
searchArg :: MonadP m => ParserPrefs -> String -> Parser a
182166
-> NondetT (StateT Args m) (Parser a)
183-
searchArg arg = searchParser $ \opt -> do
167+
searchArg prefs arg = searchParser $ \opt -> do
184168
when (isArg (optMain opt)) cut
185-
case argMatches (optMain opt) arg of
186-
Just matcher -> lift matcher
187-
Nothing -> mzero
169+
case optMain opt of
170+
CmdReader _ _ f ->
171+
case (f arg, prefBacktrack prefs) of
172+
(Just subp, NoBacktrack) -> lift $ do
173+
args <- get <* put []
174+
fmap pure . lift $ enterContext arg subp *> runParserInfo subp args <* exitContext
175+
176+
(Just subp, Backtrack) -> fmap pure . lift . StateT $ \args -> do
177+
enterContext arg subp *> runParser (infoPolicy subp) CmdStart (infoParser subp) args <* exitContext
178+
179+
(Just subp, SubparserInline) -> lift $ do
180+
lift $ enterContext arg subp
181+
return $ infoParser subp
182+
183+
(Nothing, _) -> mzero
184+
ArgReader rdr ->
185+
fmap pure . lift . lift $ runReadM (crReader rdr) arg
186+
_ -> mzero
188187

189188
stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String
190189
-> Parser a -> NondetT (StateT Args m) (Parser a)
191-
stepParser _ AllPositionals arg p =
192-
searchArg arg p
190+
stepParser pprefs AllPositionals arg p =
191+
searchArg pprefs arg p
193192
stepParser pprefs ForwardOptions arg p = case parseWord arg of
194-
Just w -> searchOpt pprefs w p <|> searchArg arg p
195-
Nothing -> searchArg arg p
193+
Just w -> searchOpt pprefs w p <|> searchArg pprefs arg p
194+
Nothing -> searchArg pprefs arg p
196195
stepParser pprefs _ arg p = case parseWord arg of
197196
Just w -> searchOpt pprefs w p
198-
Nothing -> searchArg arg p
197+
Nothing -> searchArg pprefs arg p
199198

200199

201200
-- | Apply a 'Parser' to a command line, and return a result and leftover

Options/Applicative/Types.hs

Lines changed: 18 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Options.Applicative.Types (
99
OptReader(..),
1010
OptProperties(..),
1111
OptVisibility(..),
12+
Backtracking(..),
1213
ReadM(..),
1314
readerAsk,
1415
readerAbort,
@@ -95,19 +96,25 @@ data ParserInfo a = ParserInfo
9596
instance Functor ParserInfo where
9697
fmap f i = i { infoParser = fmap f (infoParser i) }
9798

99+
data Backtracking
100+
= Backtrack
101+
| NoBacktrack
102+
| SubparserInline
103+
deriving (Eq, Show)
104+
98105
-- | Global preferences for a top-level 'Parser'.
99106
data ParserPrefs = ParserPrefs
100-
{ prefMultiSuffix :: String -- ^ metavar suffix for multiple options
101-
, prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations
102-
-- (default: False)
103-
, prefShowHelpOnError :: Bool -- ^ always show help text on parse errors
104-
-- (default: False)
105-
, prefShowHelpOnEmpty :: Bool -- ^ show the help text for a command or subcommand
106-
-- if it fails with no input (default: False)
107-
, prefBacktrack :: Bool -- ^ backtrack to parent parser when a
108-
-- subcommand fails (default: True)
109-
, prefColumns :: Int -- ^ number of columns in the terminal, used to
110-
-- format the help page (default: 80)
107+
{ prefMultiSuffix :: String -- ^ metavar suffix for multiple options
108+
, prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations
109+
-- (default: False)
110+
, prefShowHelpOnError :: Bool -- ^ always show help text on parse errors
111+
-- (default: False)
112+
, prefShowHelpOnEmpty :: Bool -- ^ show the help text for a command or subcommand
113+
-- if it fails with no input (default: False)
114+
, prefBacktrack :: Backtracking -- ^ backtrack to parent parser when a
115+
-- subcommand fails (default: Backtrack)
116+
, prefColumns :: Int -- ^ number of columns in the terminal, used to
117+
-- format the help page (default: 80)
111118
} deriving (Eq, Show)
112119

113120
data OptName = OptShort !Char

tests/test.hs

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -393,6 +393,16 @@ prop_backtracking = once $
393393
result = execParserPure (prefs noBacktrack) i ["c", "-b"]
394394
in assertError result $ \_ -> property succeeded
395395

396+
prop_subparser_inline :: Property
397+
prop_subparser_inline = once $
398+
let p2 = switch (short 'a')
399+
p1 = (,)
400+
<$> subparser (command "c" (info p2 idm))
401+
<*> switch (short 'b')
402+
i = info (p1 <**> helper) idm
403+
result = execParserPure (prefs subparserInline) i ["c", "-b", "-a" ]
404+
in assertResult result ((True, True) ===)
405+
396406
prop_error_context :: Property
397407
prop_error_context = once $
398408
let p = pk <$> option auto (long "port")

0 commit comments

Comments
 (0)