Add noIntersperse preference (fix #22).

pcapriotti · Oct 17, 2013 · 35b1854 · 35b1854
1 parent a7d5014
commit 35b1854
Show file tree

Hide file tree

Showing 4 changed files with 35 additions and 6 deletions.
diff --git a/Options/Applicative/Builder.hs b/Options/Applicative/Builder.hs
@@ -78,6 +78,7 @@ module Options.Applicative.Builder (
   disambiguate,
   showHelpOnError,
   noBacktrack,
+  noIntersperse,
   prefs,
 
   -- * Types
@@ -345,14 +346,18 @@ showHelpOnError = PrefsMod $ \p -> p { prefShowHelpOnError = True }
 noBacktrack :: PrefsMod
 noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False }
 
+noIntersperse :: PrefsMod
+noIntersperse = PrefsMod $ \p -> p { prefIntersperse = False }
+
 prefs :: PrefsMod -> ParserPrefs
 prefs m = applyPrefsMod m base
   where
     base = ParserPrefs
       { prefMultiSuffix = ""
       , prefDisambiguate = False
       , prefShowHelpOnError = False
-      , prefBacktrack = True }
+      , prefBacktrack = True
+      , prefIntersperse = True }
 
 -- convenience shortcuts
 

diff --git a/Options/Applicative/Common.hs b/Options/Applicative/Common.hs
@@ -96,7 +96,9 @@ argMatches opt arg = case opt of
       setContext (Just arg) subp
       prefs <- getPrefs
       let runSubparser
-            | prefBacktrack prefs = runParser SkipOpts
+            | prefBacktrack prefs = \p a -> do
+                policy <- getPolicy
+                runParser policy p a
             | otherwise = \p a
             -> (,) <$> runParserFully p a <*> pure []
       runSubparser (infoParser subp) args
@@ -224,9 +226,17 @@ parseError arg = errorP . ErrorMsg $ msg
       ('-':_) -> "Invalid option `" ++ arg ++ "'"
       _       -> "Invalid argument `" ++ arg ++ "'"
 
+getPolicy :: MonadP m => m ArgPolicy
+getPolicy = do
+  prefs <- getPrefs
+  return $ if prefIntersperse prefs
+             then SkipOpts
+             else AllowOpts
+
 runParserFully :: MonadP m => Parser a -> Args -> m a
 runParserFully p args = do
-  (r, args') <- runParser SkipOpts p args
+  policy <- getPolicy
+  (r, args') <- runParser policy p args
   guard $ null args'
   return r
 

diff --git a/Options/Applicative/Types.hs b/Options/Applicative/Types.hs
@@ -64,9 +64,14 @@ instance Functor ParserInfo where
 -- | 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)
-  , prefBacktrack :: Bool        -- ^ backtrack to parent parser when a subcommand fails (default: True)
+  , prefDisambiguate :: Bool     -- ^ automatically disambiguate abbreviations
+                                 -- (default: False)
+  , prefShowHelpOnError :: Bool  -- ^ always show help text on parse errors
+                                 -- (default: False)
+  , prefBacktrack :: Bool        -- ^ backtrack to parent parser when a
+                                 -- subcommand fails (default: True)
+  , prefIntersperse :: Bool      -- ^ allow regular options and flags to occur
+                                 -- after arguments (default: True)
   }
 
 data OptName = OptShort !Char

diff --git a/tests/Tests.hs b/tests/Tests.hs
@@ -343,5 +343,14 @@ case_issue_50 = do
       result = run (info p idm) ["--version", "test"]
   assertRight result $ \r -> "test" @=? r
 
+case_intersperse_1 :: Assertion
+case_intersperse_1 = do
+  let p = arguments str (metavar "ARGS")
+          <* switch (short 'x')
+      result = execParserPure (prefs noIntersperse)
+                              (info p idm)
+                              ["a", "-x", "b"]
+  assertRight result $ \args -> ["a", "-x", "b"] @=? args
+
 main :: IO ()
 main = $(defaultMainGenerator)