Replace WriterT in P Monad stack with StateT.

This allows us to enter and exit the context more easily, and reset
it when a parser is finished.

Options/Applicative/Common.hs

@@ -52,7 +52,7 @@ module Options.Applicative.Common (
   OptDescStyle (..)
   ) where
 
-import Control.Applicative (pure, (<*>), (<$>), (<|>), (<$))
+import Control.Applicative (pure, (<*>), (<*), (<$>), (<|>), (<$))
 import Control.Arrow (left)
 import Control.Monad (guard, mzero, msum, when, liftM)
 import Control.Monad.Trans.Class (lift)
@@ -102,14 +102,14 @@ argMatches opt arg = case opt of
     return result
   CmdReader _ f ->
     flip fmap (f arg) $ \subp -> StateT $ \args -> do
-      setContext (Just arg) subp
+      enterContext arg subp
       prefs <- getPrefs
       let runSubparser
             | prefBacktrack prefs = \i a ->
                 runParser (getPolicy i) (infoParser i) a
             | otherwise = \i a
             -> (,) <$> runParserInfo i a <*> pure []
-      runSubparser subp args
+      runSubparser subp args <* exitContext
   _ -> Nothing
 
 optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)

Options/Applicative/Extra.hs

@@ -133,7 +133,7 @@ execParserPure pprefs pinfo args =
 --
 -- @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@
 parserFailure :: ParserPrefs -> ParserInfo a
-              -> ParseError -> Context
+              -> ParseError -> [Context]
               -> ParserFailure ParserHelp
 parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
   let h = with_context ctx pinfo $ \names pinfo' -> mconcat
@@ -149,12 +149,12 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->
       ShowHelpText   -> ExitSuccess
       InfoMsg  _     -> ExitSuccess
 
-    with_context :: Context
+    with_context :: [Context]
                  -> ParserInfo a
                  -> (forall b . [String] -> ParserInfo b -> c)
                  -> c
-    with_context NullContext i f = f [] i
-    with_context (Context n i) _ f = f n i
+    with_context [] i f = f [] i
+    with_context c@(Context _ i:_) _ f = f (contextNames c) i
 
     usage_help progn names i = case msg of
       InfoMsg _ -> mempty

Options/Applicative/Internal.hs

@@ -17,6 +17,7 @@ module Options.Applicative.Internal
   , runCompletion
   , SomeParser(..)
   , ComplError(..)
+  , contextNames
 
   , ListT
   , takeListT
@@ -35,15 +36,13 @@ import Control.Monad.Trans.Except
   (runExcept, runExceptT, withExcept, ExceptT(..), throwE, catchE)
 import Control.Monad.Trans.Reader
   (mapReaderT, runReader, runReaderT, Reader, ReaderT, ask)
-import Control.Monad.Trans.Writer (runWriterT, WriterT, tell)
-import Control.Monad.Trans.State (StateT, get, put, evalStateT)
-import Data.Maybe (maybeToList)
-import Data.Monoid (Monoid(..))
+import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT)
 
 import Options.Applicative.Types
 
 class (Alternative m, MonadPlus m) => MonadP m where
-  setContext :: Maybe String -> ParserInfo a -> m ()
+  enterContext :: String -> ParserInfo a -> m ()
+  exitContext :: m ()
   getPrefs :: m ParserPrefs
 
   missingArgP :: ParseError -> Completer -> m a
@@ -51,7 +50,7 @@ class (Alternative m, MonadPlus m) => MonadP m where
   errorP :: ParseError -> m a
   exitP :: Parser b -> Either ParseError a -> m a
 
-newtype P a = P (ExceptT ParseError (WriterT Context (Reader ParserPrefs)) a)
+newtype P a = P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)
 
 instance Functor P where
   fmap f (P m) = P $ fmap f m
@@ -74,20 +73,16 @@ instance MonadPlus P where
 
 
 data Context
-  = forall a . Context [String] (ParserInfo a)
-  | NullContext
+  = forall a . Context String (ParserInfo a)
 
-contextNames :: Context -> [String]
-contextNames (Context ns _) = ns
-contextNames NullContext = []
-
-instance Monoid Context where
-  mempty = NullContext
-  mappend c (Context ns i) = Context (contextNames c ++ ns) i
-  mappend c _ = c
+contextNames :: [Context] -> [String]
+contextNames ns =
+  let go (Context n _) = n
+  in  reverse $ go <$> ns
 
 instance MonadP P where
-  setContext name = P . lift . tell . Context (maybeToList name)
+  enterContext name pinfo = P $ lift $ modify $ (:) $ Context name pinfo
+  exitContext = P $ lift $ modify $ drop 1
   getPrefs = P . lift . lift $ ask
 
   missingArgP e _ = errorP e
@@ -101,8 +96,8 @@ hoistMaybe = maybe mzero return
 hoistEither :: MonadP m => Either ParseError a -> m a
 hoistEither = either errorP return
 
-runP :: P a -> ParserPrefs -> (Either ParseError a, Context)
-runP (P p) = runReader . runWriterT . runExceptT $ p
+runP :: P a -> ParserPrefs -> (Either ParseError a, [Context])
+runP (P p) = runReader . flip runStateT [] . runExceptT $ p
 
 uncons :: [a] -> Maybe (a, [a])
 uncons [] = Nothing
@@ -165,7 +160,8 @@ instance MonadPlus Completion where
   mplus (Completion x) (Completion y) = Completion $ mplus x y
 
 instance MonadP Completion where
-  setContext _ _ = return ()
+  enterContext _ _ = return ()
+  exitContext = return ()
   getPrefs = Completion $ lift ask
 
   missingArgP _ = Completion . lift . lift . ComplOption

tests/Tests.hs

@@ -181,6 +181,15 @@ case_nested_commands = do
       i = info (p1 <**> helper) idm
   checkHelpTextWith (ExitFailure 1) defaultPrefs "nested" i ["c", "b"]
 
+case_drops_back_contexts :: Assertion
+case_drops_back_contexts = do
+  let p3 = strOption (short 'a' <> metavar "A")
+      p2 = subparser (command "b" (info p3 idm)  <> metavar "B")
+      p1 = subparser (command "c" (info p3 idm)  <> metavar "C")
+      p0 = (,) <$> p2 <*> p1
+      i = info (p0 <**> helper) idm
+  checkHelpTextWith (ExitFailure 1) defaultPrefs "dropback" i ["b", "-aA"]
+
 case_many_args :: Assertion
 case_many_args = do
   let p = many (argument str idm)

tests/dropback.err.txt

@@ -0,0 +1,3 @@
+Missing: C
+
+Usage: dropback B C