Remove state monad from the P stack.

Options/Applicative/BashCompletion.hs

@@ -31,4 +31,4 @@ bashCompletionQuery parser ws i = case runCompletion compl ws i parser of
     show_name (OptShort c) = '-':[c]
     show_name (OptLong name) = "--" ++ name
 
-    compl = runParserWith (\_ _ -> exitCompletion) parser
+    compl = runParser parser ws

Options/Applicative/Common.hs

@@ -35,7 +35,6 @@ module Options.Applicative.Common (
 
   -- * Running parsers
   runParser,
-  runParserWith,
   runParserFully,
   evalParser,
 
@@ -46,8 +45,6 @@ module Options.Applicative.Common (
   optionNames
   ) where
 
-import Debug.Trace
-
 import Control.Applicative
 import Control.Monad
 import Data.Maybe
@@ -74,28 +71,30 @@ instance Monoid MatchResult where
   mappend m@(Match _) _ = m
   mappend _ m = m
 
-optMatches :: MonadP m => OptReader a -> String -> Maybe (m a)
+type Matcher m a = [String] -> m (a, [String])
+
+optMatches :: MonadP m => OptReader a -> String -> Maybe (Matcher m a)
 optMatches rdr arg = case rdr of
   OptReader names f
     | Just (arg1, val) <- parsed
     , arg1 `elem` names
-    -> Just $ do
-         arg' <- nextArg val
-         trace ("arg' nothing: " ++ show (isNothing arg')) $ return ()
-         liftMaybe $ arg' >>= f
+    -> Just $ \args -> do
+         (arg', args') <- liftMaybe . uncons $ maybeToList val ++ args
+         r <- liftMaybe $ f arg'
+         return (r, args')
     | otherwise -> Nothing
   FlagReader names x
     | Just (arg1, Nothing) <- parsed
     , arg1 `elem` names
-    -> Just $ return x
+    -> Just $ \args -> return (x, args)
   ArgReader f
     | Just result <- f arg
-    -> Just $ return result
+    -> Just $ \args -> return (result, args)
   CmdReader _ f
     | Just subp <- f arg
-    -> Just $ do
+    -> Just $ \args -> do
          setContext (Just arg) subp
-         runParser (infoParser subp)
+         runParser (infoParser subp) args
   _ -> Nothing
   where
     parsed
@@ -110,51 +109,46 @@ optMatches rdr arg = case rdr of
           (a : rest) -> Just (OptShort a, Just rest)
       | otherwise = Nothing
 
-stepParser :: MonadP m => Parser a -> String -> m (Parser a)
-stepParser (NilP _) _ = mzero
-stepParser (OptP opt) arg
+stepParser :: MonadP m => Parser a -> String -> [String] -> m (Parser a, [String])
+stepParser (NilP _) _ _ = empty
+stepParser (OptP opt) arg args
   | Just matcher <- optMatches (optMain opt) arg
-  = pure <$> matcher
+  = do (r, args') <- matcher args
+       return (pure r, args')
   | otherwise = empty
-stepParser (MultP p1 p2) arg = msum
-  [ do p1' <- stepParser p1 arg
-       return (p1' <*> p2)
-  , do p2' <- stepParser p2 arg
-       return (p1 <*> p2') ]
-stepParser (AltP p1 p2) arg = msum
-  [ do p1' <- stepParser p1 arg
-       return (p1' <|> p2)
-  , do p2' <- stepParser p2 arg
-       return (p1 <|> p2') ]
-stepParser (BindP p k) arg = do
-  p' <- stepParser p arg
+stepParser (MultP p1 p2) arg args = msum
+  [ do (p1', args') <- stepParser p1 arg args
+       return (p1' <*> p2, args')
+  , do (p2', args') <- stepParser p2 arg args
+       return (p1 <*> p2', args') ]
+stepParser (AltP p1 p2) arg args = msum
+  [ do (p1', args') <- stepParser p1 arg args
+       return (p1' <|> p2, args')
+  , do (p2', args') <- stepParser p2 arg args
+       return (p1 <|> p2', args') ]
+stepParser (BindP p k) arg args = do
+  (p', args') <- stepParser p arg args
   x <- liftMaybe $ evalParser p'
-  return $ k x
-
-runParserWith :: MonadP m => (Parser a -> Maybe String -> m b) -> Parser a -> m b
-runParserWith h p = do
-  a <- nextArg Nothing
-  case a of
-    Nothing -> h p Nothing
-    Just arg -> do
-      r <- tryP $ stepParser p arg
-      case r of
-        Left e -> h p (Just arg) <|> errorP e
-        Right p' -> do
-          setParser (Just arg) p'
-          runParserWith h p'
+  return (k x, args')
 
 -- | Apply a 'Parser' to a command line, and return a result and leftover
 -- arguments.  This function returns an error if any parsing error occurs, or
 -- if any options are missing and don't have a default value.
-runParser :: MonadP m => Parser a -> m a
-runParser = runParserWith $ \p _ -> liftMaybe (evalParser p)
+runParser :: MonadP m => Parser a -> [String] -> m (a, [String])
+runParser p args = case args of
+  [] -> result
+  (arg : argt) -> do
+    x <- tryP (stepParser p arg argt)
+    case x of
+      Left e -> result <|> errorP e
+      Right (p', args') -> runParser p' args'
+  where
+    result = liftMaybe $ (,) <$> evalParser p <*> pure args
 
-runParserFully :: Parser a -> P a
-runParserFully p = do
-  r <- runParser p
-  args <- getArgs
-  guard $ null args
+runParserFully :: Parser a -> [String] -> P a
+runParserFully p args = do
+  (r, args') <- runParser p args
+  guard $ null args'
   return r
 
 -- | The default value of a 'Parser'.  This function returns an error if any of

Options/Applicative/Extra.hs

@@ -15,7 +15,7 @@ import Options.Applicative.BashCompletion
 import Options.Applicative.Common
 import Options.Applicative.Builder
 import Options.Applicative.Help
-import Options.Applicative.Internal hiding (getArgs)
+import Options.Applicative.Internal
 import Options.Applicative.Utils
 import Options.Applicative.Types
 import System.Environment
@@ -61,8 +61,8 @@ execParserPure :: ParserPrefs       -- ^ Global preferences for this parser
                -> [String]          -- ^ Program arguments
                -> Either ParserFailure a
 execParserPure pprefs pinfo args =
-  case runP p args of
-    (Right (r, _), _) -> case r of
+  case runP p of
+    (Right r, _) -> case r of
       Result a -> Right a
       Extra failure -> Left failure
     (Left msg, ctx) -> Left ParserFailure
@@ -91,7 +91,7 @@ execParserPure pprefs pinfo args =
     with_context (Context n i) _ f = f n i
 
     parser' = (Result <$> parser) <|> (Extra <$> bashCompletionParser parser)
-    p = runParserFully parser'
+    p = runParserFully parser' args
 
 -- | Generate option summary.
 usage :: ParserPrefs -> Parser a -> String -> String

Options/Applicative/Internal.hs

@@ -7,8 +7,6 @@ module Options.Applicative.Internal
   , uncons
   , liftMaybe
 
-  , getArgs
-  , setArgs
   , runP
 
   , runCompletion
@@ -30,14 +28,13 @@ import Options.Applicative.Types
 class (Alternative m, MonadPlus m) => MonadP m where
   type PError m
 
-  nextArg :: Maybe String -> m (Maybe String)
   setContext :: Maybe String -> ParserInfo a -> m ()
   setParser :: Maybe String -> Parser a -> m ()
 
   tryP :: m a -> m (Either (PError m) a)
   errorP :: PError m -> m a
 
-type P = StateT [String] (ErrorT String (Writer Context))
+type P = ErrorT String (Writer Context)
 
 data Context where
   Context :: Maybe String -> ParserInfo a -> Context
@@ -51,40 +48,18 @@ instance Monoid Context where
 instance MonadP P where
   type PError P = String
 
-  nextArg val = do
-    args <- getArgs
-    case maybeToList val ++ args of
-      [] -> return Nothing
-      (arg':args') -> do
-        setArgs args'
-        return $ Just arg'
-
-  setContext name = lift . lift . tell . Context name
+  setContext name = lift . tell . Context name
   setParser _ _ = return ()
 
-  errorP = lift . throwError
+  errorP = throwError
 
-  tryP p = do
-    args <- getArgs
-    let (r, ctx) = runP p args
-    lift . lift . tell $ ctx
-    case r of
-      Left e -> return (Left e)
-      Right (x, args') -> do
-        setArgs args'
-        return (Right x)
+  tryP p = lift $ runErrorT p
 
 liftMaybe :: MonadPlus m => Maybe a -> m a
 liftMaybe = maybe mzero return
 
-runP :: P a -> [String] -> (Either String (a, [String]), Context)
-runP p args = runWriter . runErrorT $ runStateT p args
-
-getArgs :: P [String]
-getArgs = get
-
-setArgs :: [String] -> P ()
-setArgs = put
+runP :: P a -> (Either String a, Context)
+runP = runWriter . runErrorT
 
 uncons :: [a] -> Maybe (a, [a])
 uncons [] = Nothing
@@ -111,20 +86,6 @@ type Completion = ErrorT ComplError (State ComplState)
 instance MonadP Completion where
   type PError Completion = ComplError
 
-  nextArg val = do
-    st <- lift get
-    let i = complIndex st
-    unless (i > 0) exitCompletion
-    case val of
-      Just arg -> return $ Just arg
-      Nothing -> do
-        let ws = complWords st
-        (arg, ws') <- liftMaybe (uncons ws)
-        lift . modify $ \s -> s
-          { complWords = ws'
-          , complIndex = i - 1 }
-        return $ Just arg
-
   setContext val i = setParser val (infoParser i)
   setParser val p = lift . modify $ \s -> s
     { complParser = SomeParser p