@@ -51,7 +51,7 @@ module Options.Applicative.Common (
51
51
) where
52
52
53
53
import Control.Applicative
54
- import Control.Monad (guard , mzero , msum , when , liftM )
54
+ import Control.Monad (guard , mzero , msum , when )
55
55
import Control.Monad.Trans.Class (lift )
56
56
import Control.Monad.Trans.State (StateT (.. ), get , put , runStateT )
57
57
import Data.List (isPrefixOf )
@@ -79,22 +79,6 @@ isOptionPrefix _ _ = False
79
79
liftOpt :: Option a -> Parser a
80
80
liftOpt = OptP
81
81
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
-
98
82
optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a )
99
83
optMatches disambiguate opt (OptWord arg1 val) = case opt of
100
84
OptReader names rdr no_arg_err -> do
@@ -150,10 +134,10 @@ parseWord ('-' : w) = case w of
150
134
parseWord _ = Nothing
151
135
152
136
searchParser :: Monad m
153
- => (forall r . Option r -> NondetT m r )
137
+ => (forall r . Option r -> NondetT m ( Parser r ) )
154
138
-> Parser a -> NondetT m (Parser a )
155
139
searchParser _ (NilP _) = mzero
156
- searchParser f (OptP opt) = liftM pure ( f opt)
140
+ searchParser f (OptP opt) = f opt
157
141
searchParser f (MultP p1 p2) = foldr1 (<!>)
158
142
[ do p1' <- searchParser f p1
159
143
return (p1' <*> p2)
@@ -175,27 +159,42 @@ searchOpt pprefs w = searchParser $ \opt -> do
175
159
let disambiguate = prefDisambiguate pprefs
176
160
&& optVisibility opt > Internal
177
161
case optMatches disambiguate (optMain opt) w of
178
- Just matcher -> lift matcher
162
+ Just matcher -> lift $ fmap pure matcher
179
163
Nothing -> mzero
180
164
181
- searchArg :: MonadP m => String -> Parser a
165
+ searchArg :: MonadP m => ParserPrefs -> String -> Parser a
182
166
-> NondetT (StateT Args m ) (Parser a )
183
- searchArg arg = searchParser $ \ opt -> do
167
+ searchArg prefs arg = searchParser $ \ opt -> do
184
168
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
188
187
189
188
stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String
190
189
-> 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
193
192
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
196
195
stepParser pprefs _ arg p = case parseWord arg of
197
196
Just w -> searchOpt pprefs w p
198
- Nothing -> searchArg arg p
197
+ Nothing -> searchArg pprefs arg p
199
198
200
199
201
200
-- | Apply a 'Parser' to a command line, and return a result and leftover
0 commit comments