Skip to content
This repository
Browse code

Add option to disable backtracking (fixes #31).

  • Loading branch information...
commit 2ed50522b8fad8e7f9e56ab9d7d0f583714901e6 1 parent 6f2a01d
Paolo Capriotti authored December 23, 2012
7  Options/Applicative/Builder.hs
@@ -70,6 +70,7 @@ module Options.Applicative.Builder (
70 70
   PrefsMod,
71 71
   multiSuffix,
72 72
   disambiguate,
  73
+  noBacktrack,
73 74
   prefs
74 75
   ) where
75 76
 
@@ -284,13 +285,17 @@ multiSuffix s = PrefsMod $ \p -> p { prefMultiSuffix = s }
284 285
 disambiguate :: PrefsMod
285 286
 disambiguate = PrefsMod $ \p -> p { prefDisambiguate = True }
286 287
 
  288
+noBacktrack :: PrefsMod
  289
+noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False }
  290
+
287 291
 prefs :: PrefsMod -> ParserPrefs
288 292
 prefs m = applyPrefsMod m base
289 293
   where
290 294
     base = ParserPrefs
291 295
       { prefMultiSuffix = ""
292 296
       , prefDisambiguate = False
293  
-      , prefShowHelpOnError = False }
  297
+      , prefShowHelpOnError = False
  298
+      , prefBacktrack = True }
294 299
 
295 300
 -- convenience shortcuts
296 301
 
7  Options/Applicative/Common.hs
@@ -99,7 +99,12 @@ optMatches disambiguate opt arg = case opt of
99 99
   CmdReader _ f ->
100 100
     flip fmap (f arg) $ \subp args -> do
101 101
       setContext (Just arg) subp
102  
-      runParser (infoParser subp) args
  102
+      prefs <- getPrefs
  103
+      let runSubparser
  104
+            | prefBacktrack prefs = runParser
  105
+            | otherwise = \p a
  106
+            -> (,) <$> runParserFully p a <*> pure []
  107
+      runSubparser (infoParser subp) args
103 108
   where
104 109
     parsed =
105 110
       case arg of
5  Options/Applicative/Types.hs
@@ -59,8 +59,9 @@ instance Functor ParserInfo where
59 59
 -- | Global preferences for a top-level 'Parser'.
60 60
 data ParserPrefs = ParserPrefs
61 61
   { prefMultiSuffix :: String    -- ^ metavar suffix for multiple options
62  
-  , prefDisambiguate :: Bool     -- ^ automatically disambiguate abbreviations
63  
-  , prefShowHelpOnError :: Bool  -- ^ always show help text on parse errors
  62
+  , prefDisambiguate :: Bool     -- ^ automatically disambiguate abbreviations (default: False)
  63
+  , prefShowHelpOnError :: Bool  -- ^ always show help text on parse errors (default: False)
  64
+  , prefBacktrack :: Bool        -- ^ backtrack to parent parser when a subcommand fails (default: True)
64 65
   }
65 66
 
66 67
 data OptName = OptShort !Char
12  tests/Tests.hs
@@ -126,7 +126,7 @@ case_alt_help = do
126 126
 
127 127
 case_nested_commands :: Assertion
128 128
 case_nested_commands = do
129  
-  let p3 = strOption (short 'a'<> metavar "A")
  129
+  let p3 = strOption (short 'a' <> metavar "A")
130 130
       p2 = subparser (command "b" (info p3 idm))
131 131
       p1 = subparser (command "c" (info p2 idm))
132 132
       i = info (p1 <**> helper) idm
@@ -232,5 +232,15 @@ case_issue_35 = do
232 232
     Right val ->
233 233
       assertFailure $ "unexpected result " ++ show val
234 234
 
  235
+case_backtracking :: Assertion
  236
+case_backtracking = do
  237
+  let p2 = switch (short 'a')
  238
+      p1 = (,)
  239
+        <$> subparser (command "c" (info p2 idm))
  240
+        <*> switch (short 'b')
  241
+      i = info (p1 <**> helper) idm
  242
+      result = execParserPure (prefs noBacktrack) i ["c", "-b"]
  243
+  assertLeft result $ \ _ -> return ()
  244
+
235 245
 main :: IO ()
236 246
 main = $(defaultMainGenerator)

0 notes on commit 2ed5052

Please sign in to comment.
Something went wrong with that request. Please try again.