Merge pull request #318 from pcapriotti/topic/subparser-reimplementation-breaking

Allow inlining of subparsers instead of independent execution

Options/Applicative.hs

@@ -193,6 +193,7 @@ module Options.Applicative (
   showHelpOnError,
   showHelpOnEmpty,
   noBacktrack,
+  subparserInline,
   columns,
   defaultPrefs,
 

Options/Applicative/Builder.hs

@@ -83,6 +83,7 @@ module Options.Applicative.Builder (
   showHelpOnError,
   showHelpOnEmpty,
   noBacktrack,
+  subparserInline,
   columns,
   prefs,
   defaultPrefs,
@@ -485,7 +486,15 @@ showHelpOnEmpty = PrefsMod $ \p -> p { prefShowHelpOnEmpty = True }
 
 -- | Turn off backtracking after subcommand is parsed.
 noBacktrack :: PrefsMod
-noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False }
+noBacktrack = PrefsMod $ \p -> p { prefBacktrack = NoBacktrack }
+
+-- | Allow full mixing of subcommand and parent arguments by inlining
+-- selected subparsers into the parent parser.
+--
+-- /NOTE:/ When this option is used, preferences for the subparser which
+-- effect the parser behaviour (such as noIntersperse) are ignored.
+subparserInline :: PrefsMod
+subparserInline = PrefsMod $ \p -> p { prefBacktrack = SubparserInline }
 
 -- | Set the maximum width of the generated help text.
 columns :: Int -> PrefsMod
@@ -500,7 +509,7 @@ prefs m = applyPrefsMod m base
       , prefDisambiguate = False
       , prefShowHelpOnError = False
       , prefShowHelpOnEmpty = False
-      , prefBacktrack = True
+      , prefBacktrack = Backtrack
       , prefColumns = 80 }
 
 -- Convenience shortcuts

Options/Applicative/Common.hs

@@ -51,7 +51,7 @@ module Options.Applicative.Common (
   ) where
 
 import Control.Applicative
-import Control.Monad (guard, mzero, msum, when, liftM)
+import Control.Monad (guard, mzero, msum, when)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.State (StateT(..), get, put, runStateT)
 import Data.List (isPrefixOf)
@@ -79,22 +79,6 @@ isOptionPrefix _ _ = False
 liftOpt :: Option a -> Parser a
 liftOpt = OptP
 
-argMatches :: MonadP m => OptReader a -> String
-           -> Maybe (StateT Args m a)
-argMatches opt arg = case opt of
-  ArgReader rdr -> Just . lift $
-    runReadM (crReader rdr) arg
-  CmdReader _ _ f ->
-    flip fmap (f arg) $ \subp -> StateT $ \args -> do
-      prefs <- getPrefs
-      let runSubparser
-            | prefBacktrack prefs = \i a ->
-                runParser (infoPolicy i) CmdStart (infoParser i) a
-            | otherwise = \i a
-            -> (,) <$> runParserInfo i a <*> pure []
-      enterContext arg subp *> runSubparser subp args <* exitContext
-  _ -> Nothing
-
 optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)
 optMatches disambiguate opt (OptWord arg1 val) = case opt of
   OptReader names rdr no_arg_err -> do
@@ -150,10 +134,10 @@ parseWord ('-' : w) = case w of
 parseWord _ = Nothing
 
 searchParser :: Monad m
-             => (forall r . Option r -> NondetT m r)
+             => (forall r . Option r -> NondetT m (Parser r))
              -> Parser a -> NondetT m (Parser a)
 searchParser _ (NilP _) = mzero
-searchParser f (OptP opt) = liftM pure (f opt)
+searchParser f (OptP opt) = f opt
 searchParser f (MultP p1 p2) = foldr1 (<!>)
   [ do p1' <- searchParser f p1
        return (p1' <*> p2)
@@ -175,27 +159,42 @@ searchOpt pprefs w = searchParser $ \opt -> do
   let disambiguate = prefDisambiguate pprefs
                   && optVisibility opt > Internal
   case optMatches disambiguate (optMain opt) w of
-    Just matcher -> lift matcher
+    Just matcher -> lift $ fmap pure matcher
     Nothing -> mzero
 
-searchArg :: MonadP m => String -> Parser a
+searchArg :: MonadP m => ParserPrefs -> String -> Parser a
           -> NondetT (StateT Args m) (Parser a)
-searchArg arg = searchParser $ \opt -> do
+searchArg prefs arg = searchParser $ \opt -> do
   when (isArg (optMain opt)) cut
-  case argMatches (optMain opt) arg of
-    Just matcher -> lift matcher
-    Nothing -> mzero
+  case optMain opt of
+    CmdReader _ _ f ->
+      case (f arg, prefBacktrack prefs) of
+        (Just subp, NoBacktrack) -> lift $ do
+          args <- get <* put []
+          fmap pure . lift $ enterContext arg subp *> runParserInfo subp args <* exitContext
+
+        (Just subp, Backtrack) -> fmap pure . lift . StateT $ \args -> do
+          enterContext arg subp *> runParser (infoPolicy subp) CmdStart (infoParser subp) args <* exitContext
+
+        (Just subp, SubparserInline) -> lift $ do
+          lift $ enterContext arg subp
+          return $ infoParser subp
+
+        (Nothing, _)  -> mzero
+    ArgReader rdr ->
+      fmap pure . lift . lift $ runReadM (crReader rdr) arg
+    _ -> mzero
 
 stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String
            -> Parser a -> NondetT (StateT Args m) (Parser a)
-stepParser _ AllPositionals arg p =
-  searchArg arg p
+stepParser pprefs AllPositionals arg p =
+  searchArg pprefs arg p
 stepParser pprefs ForwardOptions arg p = case parseWord arg of
-  Just w -> searchOpt pprefs w p <|> searchArg arg p
-  Nothing -> searchArg arg p
+  Just w -> searchOpt pprefs w p <|> searchArg pprefs arg p
+  Nothing -> searchArg pprefs arg p
 stepParser pprefs _ arg p = case parseWord arg of
   Just w -> searchOpt pprefs w p
-  Nothing -> searchArg arg p
+  Nothing -> searchArg pprefs arg p
 
 
 -- | Apply a 'Parser' to a command line, and return a result and leftover

Options/Applicative/Types.hs

@@ -9,6 +9,7 @@ module Options.Applicative.Types (
   OptReader(..),
   OptProperties(..),
   OptVisibility(..),
+  Backtracking(..),
   ReadM(..),
   readerAsk,
   readerAbort,
@@ -95,19 +96,25 @@ data ParserInfo a = ParserInfo
 instance Functor ParserInfo where
   fmap f i = i { infoParser = fmap f (infoParser i) }
 
+data Backtracking
+  = Backtrack
+  | NoBacktrack
+  | SubparserInline
+  deriving (Eq, Show)
+
 -- | Global preferences for a top-level 'Parser'.
 data ParserPrefs = ParserPrefs
-  { prefMultiSuffix :: String    -- ^ metavar suffix for multiple options
-  , prefDisambiguate :: Bool     -- ^ automatically disambiguate abbreviations
-                                 -- (default: False)
-  , prefShowHelpOnError :: Bool  -- ^ always show help text on parse errors
-                                 -- (default: False)
-  , prefShowHelpOnEmpty :: Bool  -- ^ show the help text for a command or subcommand
-                                 -- if it fails with no input (default: False)
-  , prefBacktrack :: Bool        -- ^ backtrack to parent parser when a
-                                 -- subcommand fails (default: True)
-  , prefColumns :: Int           -- ^ number of columns in the terminal, used to
-                                 -- format the help page (default: 80)
+  { prefMultiSuffix :: String     -- ^ metavar suffix for multiple options
+  , prefDisambiguate :: Bool      -- ^ automatically disambiguate abbreviations
+                                  -- (default: False)
+  , prefShowHelpOnError :: Bool   -- ^ always show help text on parse errors
+                                  -- (default: False)
+  , prefShowHelpOnEmpty :: Bool   -- ^ show the help text for a command or subcommand
+                                  -- if it fails with no input (default: False)
+  , prefBacktrack :: Backtracking -- ^ backtrack to parent parser when a
+                                  -- subcommand fails (default: Backtrack)
+  , prefColumns :: Int            -- ^ number of columns in the terminal, used to
+                                  -- format the help page (default: 80)
   } deriving (Eq, Show)
 
 data OptName = OptShort !Char

tests/test.hs

@@ -393,6 +393,16 @@ prop_backtracking = once $
       result = execParserPure (prefs noBacktrack) i ["c", "-b"]
   in assertError result $ \_ -> property succeeded
 
+prop_subparser_inline :: Property
+prop_subparser_inline = once $
+  let p2 = switch (short 'a')
+      p1 = (,)
+        <$> subparser (command "c" (info p2 idm))
+        <*> switch (short 'b')
+      i = info (p1 <**> helper) idm
+      result = execParserPure (prefs subparserInline) i ["c", "-b", "-a" ]
+  in assertResult result ((True, True) ===)
+
 prop_error_context :: Property
 prop_error_context = once $
   let p = pk <$> option auto (long "port")