multiarg 0.6.0.0 → 0.8.0.0

raw patch · 8 files changed

+637/−581 lines, 8 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• LICENSE +2/−2
• NEWS +27/−0
• System/Console/MultiArg.hs +32/−25
• System/Console/MultiArg/Combinator.hs +47/−47
• System/Console/MultiArg/Prim.hs +397/−464
• System/Console/MultiArg/SampleParser.hs +18/−21
• System/Console/MultiArg/SimpleParser.hs +110/−18
• multiarg.cabal +4/−4

@@ -1,4 +1,4 @@-Copyright (c) 2011-2012 Omari Norman.+Copyright (c) 2011-2013 Omari Norman. All rights reserved.  Redistribution and use in source and binary forms, with or without@@ -13,7 +13,7 @@     the documentation and/or other materials provided with the     distribution. -    * Neither the name of Omari Norman nor the names of its+    * Neither the name of Omari Norman nor the names of any     contributors may be used to endorse or promote products derived     from this software without specific prior written permission. 

@@ -37,3 +37,30 @@ * Add Functor instances for OptSpec, ArgSpec  * Add ThreeArg and ChoiceArg ArgSpecs++Release 0.8.0.0, January 8, 2013+Changes since release 0.6.0.0:++* Added a multi-mode parser to SimpleParser++* All modules (except SampleParser) are now re-exported from+  System.Console.MultiArg. Therefore one import will bring in all of+  MultiArg. However, this introduced a naming conflict, because+  SimpleParser and Prim both had functions named "parse". Therefore I+  renamed SimpleParser.parse to "simple".++* Removed the <??> combinator from Prim and replaced it with+  <?>. Removed <?> from Combinator. The new <?> behaves as one would+  expect from Parsec.++* Simplified errors. There is now just one type of error message, and+  that is a string. Reversed error messages when Prim.parse returns+  (this way they are in the order the user would expect.)++* Client code written for 0.6.0.0 will probably break with this+  release, mostly because of changes to the export lists.  Combinator+  no longer re-exports from other modules, because now the expectation+  is that if you want to import everything you just import+  System.Console.MultiArg. So fixing that is just a matter of changing+  imports in client code. Other breakage will be limited to error+  handling code.

@@ -102,27 +102,26 @@   -- |If your needs are simple to moderately complicated just look at the   -- "System.Console.MultiArg.SimpleParser" module, which uses the   -- underlying combinators to build a simple parser for you. That-  -- module is already exported from this module for easy usage. For-  -- maximum flexibility you will want to start with the-  -- "System.Console.MultiArg.Prim" module.+  -- module is already exported from this module for easy usage.   ---  -- Using the parsers and combinators in-  -- "System.Console.MultiArg.Prim", you can easily build parsers that-  -- are quite complicated. The parsers can check for errors along the-  -- way, simplifying the sometimes complex task of ensuring that data-  -- a user supplied on the command line is good. You can easily build-  -- parsers for programs that take no options, take dozens of-  -- options, require that options be given in a particular order,-  -- require that some options be given, or bar some combinations of-  -- options. You might also require particular positional-  -- arguments. You can also easily parse command lines for programs-  -- that have multiple \"modes\", like @git@ or @darcs@. If you're-  -- doing this, of course first start by reading the documentation-  -- for "System.Console.MultiArg.Prim" and-  -- "System.Console.MultiArg.Combinator". You will also want to look-  -- at the source code for "System.Console.MultiArg.Combinator" and-  -- "System.Console.Multiarg.SimpleParser", as these show some ways-  -- to use the primitive parsers and combinators.+  -- "System.Console.MultiArg.SimpleParser" also has a parser that can+  -- handle multi-mode commands (examples include @git@, @darcs@, and+  -- @cvs@.)+  --+  -- For maximum flexibility you will want to start with the+  -- "System.Console.MultiArg.Prim" module. Using those parsers you+  -- can easily build parsers that are quite complicated. The parsers+  -- can check for errors along the way, simplifying the sometimes+  -- complex task of ensuring that data a user supplied on the command+  -- line is good. You can easily build parsers for programs that take+  -- no options, take dozens of options, require that options be given+  -- in a particular order, require that some options be given, or bar+  -- some combinations of options. You might also require particular+  -- positional arguments. Other helpful functions are in+  -- "System.Console.MultiArg.Combinator". You will also want to+  -- examine the source code for "System.Console.MultiArg.Combinator"+  -- and "System.Console.MultiArg.SimpleParser" as these show some+  -- ways to use the primitive parsers and combinators.    -- * Non-features and shortcomings   --@@ -152,11 +151,19 @@   -- system. <http://hackage.haskell.org/package/penny-lib> The code   -- using multiarg is woven throughout the system; for example, see   -- the Penny.Liberty module.-  ---  -- * multiarg was originally written for Pantry, which I have yet to-  -- polish for release, but which is available on Github at-  -- <https://github.com/massysett/Pantry>. -  module System.Console.MultiArg.SimpleParser ) where +    module System.Console.MultiArg.Combinator+  , module System.Console.MultiArg.GetArgs+  , module System.Console.MultiArg.Option+  , module System.Console.MultiArg.Prim+  , module System.Console.MultiArg.SimpleParser+  , module Control.Monad.Exception.Synchronous+  ) where++import System.Console.MultiArg.Combinator+import System.Console.MultiArg.GetArgs+import System.Console.MultiArg.Option+import System.Console.MultiArg.Prim import System.Console.MultiArg.SimpleParser+import Control.Monad.Exception.Synchronous

@@ -5,7 +5,6 @@ module System.Console.MultiArg.Combinator (   -- * Parser combinators   notFollowedBy,-  (<?>),    -- * Combined long and short option parser   OptSpec(OptSpec, longOpts, shortOpts, argSpec),@@ -13,26 +12,27 @@           ThreeArg, VariableArg, ChoiceArg),   parseOption, -  -- * Other words-  matchApproxWord ) where+  -- * Formatting errors+  formatError+  ) where -import Data.List (isPrefixOf, intersperse, nubBy, intercalate)+import Data.List (isPrefixOf, intersperse, nubBy) import Data.Set ( Set ) import qualified Data.Set as Set import Control.Applicative        ((<$>), (<*>), optional, (<$), (*>), (<|>), many)  import System.Console.MultiArg.Prim-  ( Parser, throw, try, approxLongOpt,-    nextArg, pendingShortOptArg, nonOptionPosArg,-    pendingShortOpt, nonPendingShortOpt, nextArg,-    Message(Expected, Replaced), (<??>))+  ( Parser, try, approxLongOpt,+    nextWord, pendingShortOptArg, nonOptionPosArg,+    pendingShortOpt, nonPendingShortOpt, nextWord, (<?>),+    Error(..), Description(..)) import System.Console.MultiArg.Option   ( LongOpt, ShortOpt, unLongOpt,     makeLongOpt, makeShortOpt, unShortOpt ) import qualified Data.Map as M import Data.Map ((!))-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid ( mconcat )  @@ -47,34 +47,6 @@          <|> return ())  --- | Runs the parser given. If it succeeds, then returns the result of--- the parser. If it fails and consumes input, returns the result of--- the parser. If it fails without consuming any input, then removes--- all previous errors, replacing them with a single error of type--- Replaced containing the string given.-(<?>) :: Parser a -> String -> Parser a-(<?>) l e = l <??> const [Replaced e]--infix 0 <?>---- | Examines the possible words in Set. If there are no pendings,--- then get the next word and see if it matches one of the words in--- Set. If so, returns the word actually parsed and the matching word--- from Set. If there is no match, fails without consuming any input.-matchApproxWord :: Set String -> Parser (String, String)-matchApproxWord s = try $ do-  a <- nextArg-  let p t = a `isPrefixOf` t-      matches = Set.filter p s-      err = throw $ Expected-            ("word matching one of: "-             ++ (intercalate ", " $ Set.toList s))-  case Set.toList matches of-    [] -> err-    (x:[]) -> return (a, x)-    _ -> err-- unsafeShortOpt :: Char -> ShortOpt unsafeShortOpt c =   fromMaybe (error $ "invalid short option: " ++ [c])@@ -234,7 +206,7 @@ longOpt set mp = do   (_, lo, maybeArg) <- approxLongOpt set   let spec = mp ! lo-      maybeNextArg = maybe nextArg return maybeArg+      maybeNextArg = maybe nextWord return maybeArg   case spec of     NoArg a -> case maybeArg of       Nothing -> return a@@ -242,8 +214,8 @@                   ++ " does not take argument"     OptionalArg f -> return (f maybeArg)     OneArg f -> f <$> maybeNextArg-    TwoArg f -> f <$> maybeNextArg <*> nextArg-    ThreeArg f -> f <$> maybeNextArg <*> nextArg <*> nextArg+    TwoArg f -> f <$> maybeNextArg <*> nextWord+    ThreeArg f -> f <$> maybeNextArg <*> nextWord <*> nextWord     VariableArg f -> do       as <- many nonOptionPosArg       return . f $ case maybeArg of@@ -274,11 +246,15 @@ -- | Parses a short option without an argument, either pending or -- non-pending. Fails with a single error message rather than two. nextShort :: ShortOpt -> Parser ()-nextShort o = p <??> e where-  p = pendingShortOpt o <|> nonPendingShortOpt o-  err = Expected ("short option: " ++ [unShortOpt o])-  e ls = err : (drop 2 ls)+nextShort o = p <?> ("short option: -" ++ [unShortOpt o])+  where+    p = do+      r1 <- optional $ pendingShortOpt o+      case r1 of+        Just () -> return ()+        Nothing -> nonPendingShortOpt o + shortVariableArg :: ([String] -> a) -> Parser a shortVariableArg f = do   maybeSameWordArg <- optional pendingShortOptArg@@ -294,7 +270,7 @@  firstShortArg :: Parser String firstShortArg =-  optional pendingShortOptArg >>= maybe nextArg return+  optional pendingShortOptArg >>= maybe nextWord return   shortChoiceArg :: ShortOpt -> [(String, a)] -> Parser a@@ -309,10 +285,10 @@   shortTwoArg :: (String -> String -> a) -> Parser a-shortTwoArg f = f <$> firstShortArg <*> nextArg+shortTwoArg f = f <$> firstShortArg <*> nextWord  shortThreeArg :: (String -> String -> String -> a) -> Parser a-shortThreeArg f = f <$> firstShortArg <*> nextArg <*> nextArg+shortThreeArg f = f <$> firstShortArg <*> nextWord <*> nextWord  shortOptionalArg :: (Maybe String -> a) -> Parser a shortOptionalArg f = do@@ -339,4 +315,28 @@         (_, a):[] -> return a         _ -> Nothing +-- | Formats error messages for nice display.+formatError+  :: String+  -- ^ Pass the name of your program here. Displayed at the beginning+  -- of the error message. +  -> Error+  -> String+formatError p (Error loc ls) =+  p ++ ": error: could not parse command line.\n"+  ++ "Error at: " ++ loc ++ "\n"+  ++ expError+  ++ genError+  ++ unk+  where+    toExp m = case m of { Expected s -> Just s; _ -> Nothing }+    expc = unlines . mapMaybe toExp $ ls+    expError = if null expc then "" else "Expecting:\n" ++ expc+    toGeneral m = case m of { General s -> Just s; _ -> Nothing }+    gen = unlines . mapMaybe toGeneral $ ls+    genError = if null gen+               then ""+               else "Other errors:\n" ++ gen+    unk = if any (== Unknown) ls then "Unknown error\n" else ""+    

@@ -4,6 +4,10 @@ -- will want to look at "System.Console.MultiArg.SimpleParser" or -- "System.Console.MultiArg.Combinator", which do a lot of grunt work -- for you.+--+-- Internal design, especially the error handling, is based in large+-- part on Parsec, as described in the paper at+-- <http://legacy.cs.uu.nl/daan/pubs.html#parsec>. module System.Console.MultiArg.Prim (     -- * Parser types   Parser,@@ -15,22 +19,20 @@   parse,    -- * Higher-level parser combinators-  parserMap,   good,-  apply,   choice,-  combine,+  bind,   lookAhead,    -- ** Running parsers multiple times   several,+  several1,   manyTill,    -- ** Failure and errors-  throw,-  throwString,+  failString,   genericThrow,-  (<??>),+  (<?>),   try,    -- * Parsers@@ -48,16 +50,18 @@   resetStopper,    -- ** Positional (non-option) arguments-  nextArg,+  nextWord,+  nextWordIs,   nonOptionPosArg,+  matchApproxWord,    -- ** Miscellaneous   end,    -- * Errors-  Message(Expected, StrMsg, Replaced, UnknownError),+  Description(..),   Error(Error),-  Location+  InputDesc    ) where @@ -68,73 +72,17 @@     LongOpt,     unLongOpt,     makeLongOpt )-import Control.Applicative ( Applicative, Alternative )-import qualified Control.Applicative-import Control.Monad.Exception.Synchronous-  (Exceptional(Success, Exception))+import Control.Applicative ( Applicative, Alternative, optional )+import qualified Control.Applicative as A+import qualified Control.Monad.Exception.Synchronous as Ex import qualified Data.Set as Set import Data.Set ( Set )-import Control.Monad ( when, MonadPlus(mzero, mplus), guard )+import qualified Control.Monad+import Control.Monad ( when, MonadPlus(mzero, mplus), guard, liftM )+import Data.Maybe (mapMaybe) import Data.Monoid ( Monoid ( mempty, mappend ) ) import qualified Data.List as L-import Data.List (isPrefixOf, intercalate)--type Location = String---- | An Error contains a list of Messages and a String indicating--- where the error happened.-data Error = Error [Message] Location deriving Show---- | Extract a Location from a ParseSt for use in error messages.-location :: ParseSt -> Location-location st = pending ++ next ++ stop where-  pending-    | null (pendingShort st) = ""-    | otherwise = "short option or short option argument: "-                  ++ pendingShort st ++ " "-  next = case remaining st of-    [] -> "no words remaining"-    x:_ -> "next word: " ++ x-  stop = if sawStopper st then " (stopper already seen)" else ""---- | Error messages.-data Message =-  Expected String-  -- ^ The parser expected to see one thing, but it actually saw-  -- something else. The string indicates what was expected.-  | StrMsg String-    -- ^ The 'fromString' function was applied.--  | Replaced String-    -- ^ A previous list of error messages was replaced with this error message.--  | UnknownError-    -- ^ Any other error; used by 'genericThrow'.--  deriving Show---- | Carries the internal state of the parser. The counter is a simple--- way to determine whether the remaining list one ParseSt has been--- modified from another. When parsers modify remaining, they--- increment the counter.-data ParseSt = ParseSt { pendingShort :: String-                       , remaining :: [String]-                       , sawStopper :: Bool-                       , counter :: Int-                       , errors :: [Message]-                       } deriving Show---- | Load up the ParseSt with an initial user state and a list of--- commmand line arguments.-defaultState :: [String] -> ParseSt-defaultState ts = ParseSt { pendingShort = ""-                          , remaining = ts-                          , sawStopper = False-                          , counter = 0-                          , errors = [] }---- | Carries the result of each parse.-data Result a = Bad | Good a+import Data.List (isPrefixOf)  -- | Parsers. Internally the parser tracks what input remains to be -- parsed, whether there are any pending short options, and whether a@@ -142,66 +90,59 @@ -- -- The parser also includes the notion of failure. Any parser can -- fail; a failed parser affects the behavior of combinators such as--- combine.-data Parser a =-  Parser { runParser :: ParseSt -> (Result a, ParseSt) }+-- choice.+newtype Parser a = Parser { runParser :: State -> Consumed a } +instance Monad Parser where+  (>>=) = bind+  return = good+  fail = failString+ instance Functor Parser where-  fmap = parserMap+  fmap = liftM  instance Applicative Parser where-  pure = good-  (<*>) = apply--instance Monoid (Parser a) where-  mempty = genericThrow-  mappend = choice+  (<*>) = Control.Monad.ap+  pure = return  instance Alternative Parser where   empty = genericThrow   (<|>) = choice+  some = several1   many = several -instance Monad Parser where-  (>>=) = combine-  return = good-  fail = throwString+instance Monoid (Parser a) where+  mempty = genericThrow+  mappend = choice  instance MonadPlus Parser where   mzero = genericThrow   mplus = choice +type PendingShort = String+type Remaining = [String]+type SawStopper = Bool+data State = State PendingShort Remaining SawStopper --- | Runs a parser. This is the only way to change a value of type--- @Parser a@ into a value of type @a@ (that is, it is the only way to--- \"get out of the Parser monad\" or to \"escape the Parser monad\".)-parse ::-  [String]-  -- ^ Command line arguments to parse. Presumably you got these from-  -- 'getArgs'. If there is any chance that you will be parsing-  -- Unicode strings, see the documentation in-  -- "System.Console.MultiArg.GetArgs" before you use-  -- 'System.Environment.getArgs'.+type InputDesc = String+data Description = Unknown | General String | Expected String+  deriving (Eq, Show, Ord) -  -> Parser a-  -- ^ Parser to run+data Error = Error InputDesc [Description]+  deriving (Eq, Show, Ord) -  -> Exceptional Error a-  -- ^ Success or failure. Any parser might fail; for example, the-  -- command line might not have any values left to parse. Use of the-  -- 'choice' combinator can lead to a list of failures. If multiple-  -- parsers are tried one after another using the 'choice' combinator,-  -- and each fails without consuming any input, then multiple Error-  -- will result, one for each failure.+data Reply a = Ok a State Error+             | Fail Error -parse ts p =-  let (result, st') = runParser p (defaultState ts)-  in case result of-    Good g -> Success g-    Bad ->-      let e = Error (errors st') (location st')-      in Exception e+data Consumed a = Consumed (Reply a)+                | Empty (Reply a) +-- | @good a@ always succeeds without consuming any input and has+-- result a. This provides the implementation for+-- 'Control.Monad.Monad.return' and+-- 'Control.Applicative.Applicative.pure'.+good :: a -> Parser a+good x = Parser $ \st -> Empty (Ok x st (Error (descLocation st) []))  -- | Combines two parsers into a single parser. The second parser can -- optionally depend upon the result from the first parser.@@ -216,91 +157,46 @@ -- -- This provides the implementation for '>>=' in -- 'Control.Monad.Monad'.-combine :: Parser a -> (a -> Parser b) -> Parser b-combine a k = Parser $ \s ->-  let (r, s') = runParser a s-  in case r of-    Bad -> (Bad, s')-    Good g -> runParser (k g) s'----- | @lookAhead p@ runs parser p. If p succeeds, lookAhead p succeeds--- without consuming any input. If p fails without consuming any--- input, so does lookAhead. If p fails and consumes input, lookAhead--- also fails and consumes input. If this is undesirable, combine with--- "try".-lookAhead :: Parser a -> Parser a-lookAhead a = Parser $ \s ->-  let (r, s') = runParser a s-  in case r of-    Good g -> (Good g, s)-    Bad -> (Bad, s')-+bind :: Parser a -> (a -> Parser b) -> Parser b+bind (Parser p) f = Parser $ \s ->+  case p s of+    Empty r1 -> case r1 of+      Ok x s' _ -> runParser (f x) s'+      Fail m -> Empty (Fail m)+    Consumed r1 -> Consumed $+      case r1 of+        Ok x s' _ -> case runParser (f x) s' of+          Consumed r -> r+          Empty r -> r+        Fail e -> Fail e --- | @good a@ always succeeds without consuming any input and has--- result a. This provides the implementation for--- 'Control.Monad.Monad.return' and--- 'Control.Applicative.Applicative.pure'.-good :: a -> Parser a-good a = Parser $ \s -> (Good a, s)+descLocation :: State -> InputDesc+descLocation (State ps rm st) = pending ++ next ++ stop+  where+    pending+      | null ps = ""+      | otherwise = "short option or short option argument: "+                  ++ ps ++ " "+    next = case rm of+      [] -> "no words remaining"+      x:_ -> "next word: " ++ x+    stop = if st then " (stopper already seen)" else ""  --- | @throwString s@ always fails without consuming any input. The+-- | @failString s@ always fails without consuming any input. The -- failure contains a record of the string passed in by s. This -- provides the implementation for 'Control.Monad.Monad.fail'.-throwString :: String -> Parser a-throwString e = Parser $ \s ->-  let err = StrMsg e-      s' = s { errors = err : errors s }-  in (Bad, s')----- | @parserMap f p@ applies function f to the result of parser--- p. First parser p is run. If it succeeds, function f is applied to--- the result and another parser is returned with the result. If it--- fails, f is not applied and a failed parser is returned. This--- provides the implementation for 'Prelude.Functor.fmap'.-parserMap :: (a -> b) -> Parser a -> Parser b-parserMap f l = Parser $ \s ->-  let (r, s') = runParser l s-  in case r of-    Good g -> (Good (f g), s')-    Bad -> (Bad, s')----- | apply l r applies the function found in parser l to the result of--- parser r. First the l parser is run. If it succeeds, it has a--- resulting function. Then the r parser is run. If it succeeds, the--- function from the l parser is applied to the result of the r--- parser, and a new parser is returned with the result. If either--- parser l or parser r fails, then a failed parser is returned. This--- provides the implementation for '<*>' in--- 'Control.Applicative.Applicative'.-apply :: Parser (a -> b) -> Parser a -> Parser b-apply fa a = Parser $ \s ->-  let (r, s') = runParser fa s-  in case r of-    Good g ->-      let (ra, sa) = runParser a s'-      in case ra of-        Good ga -> (Good (g ga), sa)-        Bad -> (Bad, sa)-    Bad -> (Bad, s')+failString :: String -> Parser a+failString str = Parser $ \s ->+  Empty (Fail (Error (descLocation s) [General str]))  --- | Fail with an unhelpful error message. Usually throw is more--- useful, but this is handy to implement some typeclass instances.+-- | Fail with an unhelpful error message. Usually 'throwString' is+-- more useful, but this is handy to implement some typeclass+-- instances. genericThrow :: Parser a-genericThrow = throw UnknownError---- | throw e always fails without consuming any input and returns a--- failed parser with error state e.-throw :: Message -> Parser a-throw e = Parser $ \s ->-  (Bad, s { errors = e : errors s })--noConsumed :: ParseSt -> ParseSt -> Bool-noConsumed old new = counter old >= counter new+genericThrow = Parser $ \s ->+  Empty (Fail (Error (descLocation s) [Unknown]))  -- | Runs the first parser. If it fails without consuming any input, -- then runs the second parser. If the first parser succeeds, then@@ -309,65 +205,159 @@ -- parser. This provides the implementation for -- '<|>' in 'Control.Applicative.Alternative'. choice :: Parser a -> Parser a -> Parser a-choice a b = Parser $ \sOld ->-  let (ra, sa) = runParser a sOld-  in case ra of-    Good g ->-      let sNew = sa { errors = [] }-      in (Good g, sNew)-    Bad ->-      if noConsumed sOld sa-      then let sNew = sOld { errors = errors sa }-               (rb, sb) = runParser b sNew-           in case rb of-             Good g' -> let sb' = sb { errors = [] }-                        in (Good g', sb')-             Bad -> (Bad, sb)-      else (Bad, sa)+choice p q = Parser $ \s ->+  case runParser p s of+    Empty (Fail msg1) ->+      case runParser q s of+        Empty (Fail msg2) -> mergeError msg1 msg2+        Empty (Ok x s' msg2) -> mergeOk x s' msg1 msg2+        c -> c+    Empty (Ok x s' msg1) ->+      case runParser q s of+        Empty (Fail msg2) -> mergeOk x s' msg1 msg2+        Empty (Ok _ _ msg2) -> mergeOk x s' msg1 msg2+        c -> c+    c -> c+  where+    mergeOk x s msg1 msg2 = Empty (Ok x s (merge msg1 msg2))+    mergeError msg1 msg2 = Empty (Fail (merge msg1 msg2))+    merge (Error loc exp1) (Error _ exp2) =+      Error loc (exp1 ++ exp2) +-- | Applies 'error' if a parser would succeed without consuming any+-- input. Useful for preventing infinite loops on parsers like+-- 'several1'.+crashOnEmptyOk+  :: String+  -- ^ Use this label when applying 'error' --- | Runs the parser given. If it fails /without consuming any input/,--- then applies the given function to the list of messages and replaces--- the list of messages with the list returned by the--- function. Otherwise, returns the result of the parser.-(<??>) :: Parser a -> ([Message] -> [Message]) -> Parser a-(<??>) l f = Parser $ \s ->-  let (r, s') = runParser l s-  in case r of-    Good g -> (Good g, s')-    Bad ->-      if noConsumed s s'-      then let s'' = s' { errors = f $ errors s' }-           in (Bad, s'')-      else (Bad, s')+  -> Parser a+  -> Parser a+crashOnEmptyOk str p = Parser $ \s ->+  case runParser p s of+    Empty r -> case r of+      Ok _ _ _ ->+         error $ "multiarg: error: " ++ str+               ++ " applied to parser that succeeds without "+               ++ "consuming any input. Aborted to prevent "+               ++ "an infinite loop."+      e -> Empty e+    o -> o+                -infix 0 <??>+-- | Runs a parser one or more times. Runs the parser once and then+-- applies 'several'.+several1 :: Parser a -> Parser [a]+several1 p = do+  r1 <- p+  rs <- several p+  return $ r1:rs -increment :: ParseSt -> ParseSt-increment old = old { counter = succ . counter $ old } +-- | Runs a parser zero or more times. If the last run of the parser+-- fails without consuming any input, this parser succeeds without+-- consuming any input. If the last run of the parser fails while+-- consuming input, this parser fails while consuming input. This+-- provides the implementation for 'many' in Control.Applicative.+several :: Parser a -> Parser [a]+several unwrapped =+  let p = crashOnEmptyOk "several" unwrapped+  in do+    maybeA <- optional p+    case maybeA of+      Nothing -> return []+      Just a -> do+        rest <- several unwrapped+        return $ a:rest+  ++-- | Runs the parser given. If it fails without consuming any input,+-- replaces all Expected messages with the one given. Otherwise,+-- returns the result of the parser unchanged.+(<?>) :: Parser a -> String -> Parser a+p <?> str = Parser $ \s ->+  case runParser p s of+    Empty (Fail m) -> Empty (Fail (expect m str))+    Empty (Ok x s' m) -> Empty (Ok x s' (expect m str))+    x -> x+  where+    expect (Error pos ls) s =+      let ls' = mapMaybe notExpected ls+          notExpected d = case d of+            Expected _ -> Nothing+            x -> Just x+      in Error pos ((Expected s) : ls')++infix 0 <?>++-- | Runs a parser. This is the only way to change a value of type+-- @Parser a@ into a value of type @a@ (that is, it is the only way to+-- \"get out of the Parser monad\" or to \"escape the Parser monad\".)+parse+  :: [String]+  -- ^ Command line arguments to parse. Presumably you got these from+  -- 'getArgs'. If there is any chance that you will be parsing+  -- Unicode strings, see the documentation in+  -- "System.Console.MultiArg.GetArgs" before you use+  -- 'System.Environment.getArgs'.++  -> Parser a+  -- ^ Parser to run++  -> Ex.Exceptional Error a+  -- ^ Success or failure. Any parser might fail; for example, the+  -- command line might not have any values left to parse. Use of the+  -- 'choice' combinator can lead to a list of failures.++parse ss p =+  let s = State "" ss False+      procReply r = case r of+        Ok x _ _ -> Ex.Success x+        Fail m -> Ex.Exception m+  in case runParser p s of+      Consumed r -> procReply r+      Empty r -> procReply r+ -- | Parses only pending short options. Fails without consuming any -- input if there has already been a stopper or if there are no -- pending short options. Fails without consuming any input if there -- is a pending short option, but it does not match the short option -- given. Succeeds and consumes a pending short option if it matches -- the short option given.- pendingShortOpt :: ShortOpt -> Parser ()-pendingShortOpt so = Parser $ \s ->-  let err = Expected ("pending short option: " ++ [unShortOpt so])-      es = (Bad, s { errors = err : errors s })-      gd newSt = (Good (), newSt)-  in maybe es gd $ do-    when (sawStopper s) Nothing-    (first, rest) <- case pendingShort s of-      [] -> Nothing+pendingShortOpt so = Parser $ \s@(State pends rm stop) ->+  let msg = Error (descLocation s)+        [Expected ("pending short option: -" ++ [unShortOpt so])]+      gd s' = Consumed (Ok () s' msg)+      err = Empty (Fail msg)+  in maybe err gd $ do+    guard $ not stop+    (first, rest) <- case pends of+      [] -> mzero       x:xs -> return (x, xs)-    when (unShortOpt so /= first) Nothing-    return (increment s { pendingShort = rest })+    when (unShortOpt so /= first) mzero+    return $ State rest rm stop +-- | @lookAhead p@ runs parser p. If p succeeds, lookAhead p succeeds+-- without consuming any input. If p fails without consuming any+-- input, so does lookAhead. If p fails and consumes input, lookAhead+-- also fails and consumes input. If this is undesirable, combine with+-- "try".+lookAhead :: Parser a -> Parser a+lookAhead p = Parser $ \s ->+  case runParser p s of+    Consumed r -> case r of+      Ok x _ e -> Empty (Ok x s e)+      e -> Consumed e+    e -> e++nextW :: Remaining -> Maybe (String, Remaining)+nextW rm = case rm of+  [] -> Nothing+  x:xs -> Just (x, xs)+ -- | Parses only non-pending short options. Fails without consuming--- any input if, in order:+-- any input if: -- -- * there are pending short options --@@ -390,29 +380,30 @@ -- from the argument into a pending short, and removes the first word -- from remaining arguments to be parsed. nonPendingShortOpt :: ShortOpt -> Parser ()-nonPendingShortOpt so = Parser $ \s ->-  let err = Expected (msg ++ [unShortOpt so])-      msg = "non pending short option: "-      errRet = (Bad, s { errors = err : errors s })-      gd n = (Good (), n)+nonPendingShortOpt so = Parser $ \s@(State ps rm stop) ->+  let dsc = [Expected+            $ "non pending short option: -" ++ [unShortOpt so]]+      err = Error (descLocation s) dsc+      errRet = Empty (Fail err)+      gd (ps'', rm'') = Consumed (Ok () (State ps'' rm'' stop) err)   in maybe errRet gd $ do-    guard (noPendingShorts s)-    guard (noStopper s)-    (a, s') <- nextWord s+    guard $ null ps+    guard $ not stop+    (a, rm') <- nextW rm     (maybeDash, word) <- case a of-      [] -> Nothing+      [] -> mzero       x:xs -> return (x, xs)     guard (maybeDash == '-')     (letter, arg) <- case word of-      [] -> Nothing+      [] -> mzero       x:xs -> return (x, xs)     guard (letter == unShortOpt so)-    let s'' = s' { pendingShort = arg }-    return s''+    return (arg, rm') + -- | Parses an exact long option. That is, the text of the -- command-line option must exactly match the text of the--- option. Returns the option, and any argument that is attached to+-- option. Returns any argument that is attached to -- the same word of the option with an equal sign (for example, -- @--follow=\/dev\/random@ will return @Just \"\/dev\/random\"@ for the -- argument.) If there is no equal sign, returns Nothing for the@@ -438,20 +429,29 @@ -- -- * the next argument on the command line does begin with two --   dashes but its text does not match the argument we're looking for+ exactLongOpt :: LongOpt -> Parser (Maybe String)-exactLongOpt lo = Parser $ \s ->-  let ert = (Bad, err)-      err = s { errors = Expected msg : errors s } where-        msg = "long option: " ++ unLongOpt lo-      gd (g, n) = (Good g, n)-  in maybe ert gd $ do-    guard (noPendingShorts s)-    guard (noStopper s)-    (x, s') <- nextWord s+exactLongOpt lo = Parser $ \s@(State ps rm sp) ->+  let msg = Error (descLocation s)+            [Expected ("long option: --" ++ unLongOpt lo)]+      gd (arg, newRm) = Consumed (Ok arg (State ps newRm sp) msg)+      err = Empty (Fail msg)+  in maybe err gd $ do+    guard $ null ps+    guard $ not sp+    (x, rm') <- nextW rm     (word, afterEq) <- getLongOption x     guard (word == unLongOpt lo)-    return (afterEq, s')+    return (afterEq, rm')+     +getLongOption :: String -> Maybe (String, Maybe String)+getLongOption str = do+  guard (str /= "--")+  let (pre, word, afterEq) = splitLongWord str+  guard (pre == "--")+  return (word, afterEq)+ -- | Takes a single String and returns a tuple, where the first element -- is the first two letters, the second element is everything from the -- third letter to the equal sign, and the third element is Nothing if@@ -465,65 +465,42 @@     [] -> Nothing     _:xs -> Just xs --noPendingShorts :: ParseSt -> Bool-noPendingShorts st = case pendingShort st of-  [] -> True-  _ -> False--noStopper :: ParseSt -> Bool-noStopper = not . sawStopper--getLongOption :: String -> Maybe (String, Maybe String)-getLongOption str = do-  guard (str /= "--")-  let (pre, word, afterEq) = splitLongWord str-  guard (pre == "--")-  return (word, afterEq)+approxLongOptError :: [LongOpt] -> [Description]+approxLongOptError =+  map (Expected . ("long option: --" ++) . unLongOpt)  -nextWord :: ParseSt -> Maybe (String, ParseSt)-nextWord st = case remaining st of-  [] -> Nothing-  x:xs ->-    let s' = increment st { remaining = xs }-    in return (x, s')--approxLongOptError ::-  Set LongOpt-  -> ParseSt-  -> ParseSt-approxLongOptError set st = st { errors = newE : errors st } where-  newE = Expected ex-  ex = "a long option: " ++ longs-  longs = intercalate ", " opts-  opts = fmap unLongOpt . Set.toList $ set---- | Examines the next word. If it matches a Text in the set+-- | Examines the next word. If it matches a LongOpt in the set -- unambiguously, returns a tuple of the word actually found and the -- matching word in the set and the accompanying text after the equal -- sign (if any). If the Set is empty, this parser will always fail. approxLongOpt ::   Set LongOpt   -> Parser (String, LongOpt, Maybe String)-approxLongOpt ts = Parser $ \s ->-  let err = (Bad, approxLongOptError ts s)-      gd (g, newSt) = (Good g, newSt)-  in maybe err gd $ do-    guard (noPendingShorts s)-    (x, s') <- nextWord s-    (word, afterEq) <- getLongOption x-    opt <- makeLongOpt word+approxLongOpt ts = Parser $ \s@(State ps rm stop) ->+  let err ls = Error (descLocation s) (approxLongOptError ls)+      ert ls = Empty (Fail $ err ls)+      gd (found, opt, arg, rm'') =+        Consumed (Ok (found, opt, arg) (State ps rm'' stop)+                     (err allOpts))+      allOpts = Set.toList ts+  in Ex.switch ert gd $ do+    Ex.assert allOpts $ null ps+    Ex.assert allOpts $ not stop+    (x, rm') <- Ex.fromMaybe allOpts $ nextW rm+    (word, afterEq) <- Ex.fromMaybe allOpts $ getLongOption x+    opt <- Ex.fromMaybe allOpts $ makeLongOpt word     if Set.member opt ts-      then return ((word, opt, afterEq), s')+      then return (word, opt, afterEq, rm')       else do       let p t = word `isPrefixOf` unLongOpt t           matches = Set.filter p ts       case Set.toList matches of-        [] -> Nothing-        (m:[]) -> return ((word, m, afterEq), s')-        _ -> Nothing+        [] -> Ex.throw allOpts+        (m:[]) -> return (word, m, afterEq, rm')+        ls -> Ex.throw ls + -- | Parses only pending short option arguments. For example, for the -- @tail@ command, if you enter the option @-c25@, then after parsing -- the @-c@ option the @25@ becomes a pending short option argument@@ -538,70 +515,87 @@ -- On success, returns the String of the pending short option argument -- (this String will never be empty). pendingShortOptArg :: Parser String-pendingShortOptArg = Parser $ \s ->-  let ert = (Bad, err)-      err = s { errors = Expected msg : errors s } where-        msg = "pending short option argument"-      gd (g, newSt) = (Good g, newSt)+pendingShortOptArg = Parser $ \st@(State ps rm sp) ->+  let msg = [Expected "pending short option argument"]+      err = Error (descLocation st) msg+      ert = Empty (Fail err)+      gd str = Consumed (Ok str (State "" rm sp) err)   in maybe ert gd $ do-    guard (noStopper s)-    case pendingShort s of-      [] -> Nothing-      xs ->-        let newSt = increment s { pendingShort = "" }-        in return (xs, newSt)+     guard $ not sp+     case ps of+      [] -> mzero+      xs -> return xs   -- | Parses a \"stopper\" - that is, a double dash. Changes the internal -- state of the parser to reflect that a stopper has been seen. stopper :: Parser ()-stopper = Parser $ \s ->-  let err = s { errors = Expected msg : errors s } where-        msg = "stopper"-      ert = (Bad, err)-      gd (g, newSt) = (Good g, newSt)+stopper = Parser $ \s@(State ps rm sp) ->+  let err = Error (descLocation s)+        [Expected "stopper, \"--\""]+      ert = Empty (Fail err)+      gd rm'' = Consumed (Ok () (State ps rm'' True) err)   in maybe ert gd $ do-    guard (noPendingShorts s)-    guard (noStopper s)-    (x, s') <- nextWord s-    guard (x == "--")-    let s'' = s' { sawStopper = True }-    return ((), s'')+     guard $ not sp+     guard . not . null $ ps+     (x, rm') <- nextW rm+     guard $ x == "--"+     return rm' + -- | If a stopper has already been seen, change the internal state -- back to indicating that no stopper has been seen. resetStopper :: Parser ()-resetStopper = Parser $ \s ->-  let s' = s { sawStopper = False }-  in (Good (), s')+resetStopper = Parser $ \s@(State ps rm _) ->+  Empty (Ok () (State ps rm False) (Error (descLocation s) [])) + -- | try p behaves just like p, but if p fails, try p will not consume -- any input. try :: Parser a -> Parser a try a = Parser $ \s ->-  let (r, s') = runParser a s-  in case r of-    Good g -> (Good g, s')-    Bad -> (Bad, s'') where-      s'' = s { errors = errors s' }+  case runParser a s of+    Consumed r -> case r of+      Fail e -> Empty (Fail e)+      o -> Consumed o+    o -> o   -- | Returns the next string on the command line as long as there are--- no pendings. Be careful - this will return the next string even if--- it looks like an option (that is, it starts with a dash.) Consider--- whether you should be using nonOptionPosArg instead. However this--- can be useful when parsing command line options after a stopper.-nextArg :: Parser String-nextArg = Parser $ \s ->-  let ert = (Bad, err)-      err = s { errors = Expected msg : errors s } where-        msg = "next argument"-      gd (g, newSt) = (Good g, newSt)+-- no pendings. Succeeds even if a stopper is present. Be careful -+-- this will return the next string even if it looks like an option+-- (that is, it starts with a dash.) Consider whether you should be+-- using nonOptionPosArg instead. However this can be useful when+-- parsing command line options after a stopper.+nextWord :: Parser String+nextWord = Parser $ \s@(State ps rm sp) ->+  let err = Error (descLocation s) [dsc]+      dsc = Expected "next word"+      ert = Empty (Fail err)+      gd (str, rm'') = Consumed $ Ok str (State ps rm'' sp) err   in maybe ert gd $ do-    guard (noPendingShorts s)-    nextWord s+      guard $ null ps+      nextW rm+       +-- | Parses the next word on the command line, but only if it exactly+-- matches the word given. Otherwise, fails without consuming any+-- input. Also fails without consuming any input if there are pending+-- short options or if a stopper has already been parsed. Does not pay+-- any attention to whether a stopper is present.+nextWordIs :: String -> Parser ()+nextWordIs str = Parser $ \s@(State ps rm sp) ->+  let err = Error (descLocation s) [dsc]+      dsc = Expected $ "next argument \"" ++ str ++ "\""+      ert = Empty $ Fail err+      gd rm'' = Consumed $ Ok () (State ps rm'' sp) err+  in maybe ert gd $ do+      guard $ null ps+      (a, rm') <- nextW rm+      guard (a == str)+      return rm' + -- | If there are pending short options, fails without consuming any input. -- -- Otherwise, if a stopper has NOT already been parsed, then returns@@ -612,130 +606,69 @@ -- Otherwise, if a stopper has already been parsed, then returns the -- next word, regardless of whether it begins with a dash or not. nonOptionPosArg :: Parser String-nonOptionPosArg = Parser $ \s ->-  let ert = (Bad, err)-      err = s { errors = Expected msg : errors s } where-        msg = "non option positional argument"-      gd (g, newSt) = (Good g, newSt)+nonOptionPosArg = Parser $ \s@(State ps rm sp) ->+  let err = Error (descLocation s) [dsc]+      dsc = Expected "non option positional argument"+      ert = Empty $ Fail err+      gd (str, rm'') = Consumed $ Ok str (State ps rm'' sp) err   in maybe ert gd $ do-    guard (noPendingShorts s)-    (x, s') <- nextWord s-    result <--      if sawStopper s-      then return x-      else case x of-        [] -> return x-        '-':[] -> return "-"-        f:_ -> if f == '-'-               then Nothing-               else return x-    return (result, s')----- | manyTill p e runs parser p repeatedly until parser e succeeds.------ More precisely, first it runs parser e. If parser e succeeds, then--- manyTill returns the result of all the preceding successful parses--- of p. If parser e fails (it does not matter whether e consumed any--- input or not), manyTill runs parser p again. What happens next--- depends on whether p succeeded or failed. If p succeeded, then the--- loop starts over by running parser e again. If p failed (it does--- not matter whether it consumed any input or not), then manyTill--- fails. The state of the parser is updated to reflect its state--- after the failed run of p, and the parser is left in a failed--- state.------ Should parser e succeed (as it will on a successful application of--- manyTill), then the parser state will reflect that parser e--- succeeded--that is, if parser e consumes input, that input will be--- consumed in the parser that is returned. Wrap e inside of--- @lookAhead@ if that is undesirable.------ Be particularly careful to get the order of the arguments--- correct. Applying this function to reversed arguments will yield--- bugs that are very difficult to diagnose.-manyTill :: Parser a -> Parser end -> Parser [a]-manyTill (Parser r) (Parser f) = Parser $ \s ->-  let Till g lS lF = parseTill s r f-  in if lF then (Bad, lS) else (Good g, lS)---data Till a =-  Till { _goods :: [a]-       , _lastSt :: ParseSt-       , _lastRunFailed :: Bool }--parseTill ::-  ParseSt-  -> (ParseSt -> (Result a, ParseSt))-  -> (ParseSt -> (Result b, ParseSt))-  -> Till a-parseTill s fr ff =-  case ff s of-    (Good _, s') -> Till [] s' False-    (Bad, _) ->-      case fr s of-        (Bad, s'') -> Till [] s'' True-        (Good g, s'') ->-          let Till gs lS lF = parseTill s'' fr ff-          in if counter s'' == counter s-             then parseTillErr-             else Till (g:gs) lS lF--parseTillErr :: a-parseTillErr =-  error "parseTill applied to parser that takes empty list"+    guard $ null ps+    (x, rm') <- nextW rm+    result <- if sp+              then return x+              else case x of+                [] -> return x+                '-':[] -> return "-"+                f:_ -> if f == '-' then mzero else return x+    return (result, rm')  --- | several p runs parser p zero or more times and returns all the--- results. This proceeds like this: parser p is run and, if it--- succeeds, the result is saved and parser p is run--- again. Repeat. Eventually this will have to fail. If the last run--- of parser p fails without consuming any input, then several p runs--- successfully. The state of the parser is updated to reflect the--- successful runs of p. If the last run of parser p fails but it--- consumed input, then several p fails. The state of the parser is--- updated to reflect the state up to and including the run that--- partially consumed input. The parser is left in a failed state.------ This semantic can come in handy. For example you might run a parser--- multiple times that parses an option and arguments to the--- option. If the arguments fail to parse, then several will fail.------ This function provides the implementation for--- 'Control.Applicative.Alternative.many'.-several :: Parser a -> Parser [a]-several (Parser l) = Parser $ \s ->-  let (result, finalGoodSt, finalBadSt) = parseRepeat s l-  in if noConsumed finalGoodSt finalBadSt-     then (Good result, finalGoodSt)-     else (Bad, finalBadSt)+-- | Succeeds if there is no more input left.+end :: Parser ()+end = Parser $ \s@(State ps rm _) ->+  let err = Error (descLocation s) [dsc]+      dsc = Expected "end of input"+      ert = Empty $ Fail err+      gd = Empty $ Ok () s err+  in if null ps && null rm then gd else ert  -parseRepeat ::-  ParseSt-  -> (ParseSt -> (Result a, ParseSt))-  -> ([a], ParseSt, ParseSt)-parseRepeat st1 f =-  case f st1 of-    (Good a, st') ->-      if noConsumed st1 st'-      then error $ "several applied to parser that succeeds without"-           ++ " consuming any input"-      else-        let (ls, finalGoodSt, finalBadSt) = parseRepeat st' f-        in (a : ls, finalGoodSt, finalBadSt)-    (Bad, st') -> ([], st1, st')-+-- | Examines the possible words in Set. If there are no pendings,+-- then get the next word and see if it matches one of the words in+-- Set. If so, returns the word actually parsed and the matching word+-- from Set. If there is no match, fails without consuming any+-- input. Pays no attention to whether a stopper has been seen.+matchApproxWord :: Set String -> Parser (String, String)+matchApproxWord set = Parser $ \s@(State ps rm sp) ->+  let err = Error (descLocation s) . lsDsc+      lsDsc = map (Expected . ("next word: " ++))+      ert = Empty . Fail . err+      gd (act, mtch, rm'') =+        Consumed $ Ok (act, mtch) (State ps rm'' sp) (err allWords)+      allWords = Set.toList set+  in Ex.switch ert gd $ do+      Ex.assert allWords $ null ps+      (x, rm') <- Ex.fromMaybe allWords $ nextW rm+      let matches = Set.filter p set+          p t = x `isPrefixOf` t+      case Set.toList matches of+        [] -> Ex.throw allWords+        r:[] -> return (x, r, rm')+        xs -> Ex.throw xs+      +-- | @manyTill p end@ runs parser p zero or more times until parser+-- @end@ succeeds. If @end@ succeeds and consumes input, that input is+-- also consumed. in the result of @manyTill@. If that is a problem,+-- wrap it in @lookAhead@. Also, if @end@ fails and consumes input,+-- @manyTill@ fails and consumes input. If that is a problem, wrap+-- @end@ in @try@.+manyTill :: Parser a -> Parser end -> Parser [a]+manyTill p e = do+  maybeEnd <- optional e+  case maybeEnd of+    Just _ -> return []+    Nothing -> do+      a <- crashOnEmptyOk "manyTill" p+      rs <- manyTill p e+      return $ a:rs --- | Succeeds if there is no more input left.-end :: Parser ()-end = Parser $ \s ->-  let ert = (Bad, err)-      err = s { errors = Expected msg : errors s } where-        msg = "end of input"-      gd (g, newSt) = (Good g, newSt)-  in maybe ert gd $ do-    guard (noPendingShorts s)-    guard (null . remaining $ s)-    return ((), s)

@@ -16,14 +16,11 @@ -- The code in the module is the sample code; the sample code is not -- in the Haddock documentation! If you're reading this in Haddock, -- you will want to also take a look at the actual source code.-module System.Console.MultiArg.SampleParser (-  Flag(..)-  , specs-  , P.Intersperse(..)-  , sampleMain-  ) where+module System.Console.MultiArg.SampleParser where -import System.Console.MultiArg.SimpleParser as P+import qualified System.Console.MultiArg.Combinator as C+import System.Console.MultiArg.GetArgs (getArgs)+import qualified System.Console.MultiArg.SimpleParser as P  data Flag =   Bytes String@@ -40,24 +37,24 @@   | Filename String   deriving Show -specs :: [P.OptSpec Flag]+specs :: [C.OptSpec Flag]  specs =-  [ P.OptSpec ["bytes"]                     ['c']     (P.OneArg Bytes)-  , P.OptSpec ["follow"]                    ['f']     (P.OptionalArg Follow)-  , P.OptSpec ["follow-retry"]              ['F']     (P.NoArg Retry)-  , P.OptSpec ["lines"]                     ['n']     (P.OneArg Lines)-  , P.OptSpec ["max-unchanged-stats"]       []        (P.OneArg Stats)-  , P.OptSpec ["pid"]                       []        (P.OneArg Pid)-  , P.OptSpec ["quiet"]                     ['q']     (P.NoArg Quiet)-  , P.OptSpec ["sleep-interval"]            ['s']     (P.OneArg Sleep)-  , P.OptSpec ["verbose"]                   ['v']     (P.NoArg Verbose)-  , P.OptSpec ["help"]                      []        (P.NoArg Help)-  , P.OptSpec ["version"]                   []        (P.NoArg Version)+  [ C.OptSpec ["bytes"]                     ['c']     (C.OneArg Bytes)+  , C.OptSpec ["follow"]                    ['f']     (C.OptionalArg Follow)+  , C.OptSpec ["follow-retry"]              ['F']     (C.NoArg Retry)+  , C.OptSpec ["lines"]                     ['n']     (C.OneArg Lines)+  , C.OptSpec ["max-unchanged-stats"]       []        (C.OneArg Stats)+  , C.OptSpec ["pid"]                       []        (C.OneArg Pid)+  , C.OptSpec ["quiet"]                     ['q']     (C.NoArg Quiet)+  , C.OptSpec ["sleep-interval"]            ['s']     (C.OneArg Sleep)+  , C.OptSpec ["verbose"]                   ['v']     (C.NoArg Verbose)+  , C.OptSpec ["help"]                      []        (C.NoArg Help)+  , C.OptSpec ["version"]                   []        (C.NoArg Version)   ]  sampleMain :: P.Intersperse -> IO () sampleMain i = do-  as <- P.getArgs-  let r = P.parse i specs Filename as+  as <- getArgs+  let r = P.simple i specs Filename as   print r

@@ -1,3 +1,4 @@+{-# LANGUAGE ExistentialQuantification #-} -- | A simple command line parser that can parse options that take an -- optional argument, one or two arguments, or a variable number of -- arguments. For sample code that uses this parser, see@@ -6,30 +7,24 @@   -- * Interspersion control   Intersperse (Intersperse, StopOptions) -  -- * Option specifications-  , C.OptSpec (OptSpec, longOpts, shortOpts, argSpec)-  , C.ArgSpec (NoArg, OptionalArg, OneArg, TwoArg, VariableArg)--    -- * Exceptions-  , Ex.Exceptional (Exception, Success)-  , P.Error (Error)-  , P.Message (Expected, StrMsg, Replaced, UnknownError)--    -- * Get command line arguments-  , G.getArgs-     -- * The parser-  , parse+  , simple++    -- * Parsing multi-mode command lines+  , Mode(..)+  , modes   ) where  import qualified System.Console.MultiArg.Prim as P-import qualified System.Console.MultiArg.GetArgs as G import qualified System.Console.MultiArg.Combinator as C import qualified Control.Monad.Exception.Synchronous as Ex import Control.Applicative ( many, (<|>), optional,                              (<$), (<*>), (<*), (<$>))-import Data.Maybe (catMaybes)+import Data.List (find)+import Data.Maybe (catMaybes, fromJust)+import qualified Data.Set as Set + -- | What to do after encountering the first non-option, -- non-option-argument word on the command line? In either case, no -- more options are parsed after a stopper.@@ -50,7 +45,7 @@     -- as a positional argument rather than as an option.  -- | Parse a command line.-parse ::+simple ::   Intersperse   -- ^ What to do after encountering the first positional argument @@ -71,7 +66,7 @@   -- be parsing command lines that have non-ASCII strings.    -> Ex.Exceptional P.Error [a]-parse i os p as =+simple i os p as =   let optParser = C.parseOption os       parser = case i of         Intersperse -> parseIntersperse optParser p@@ -90,7 +85,7 @@   (\opts args -> opts ++ map p args)   <$> parseOptsNoIntersperse optParser   <* optional P.stopper-  <*> many P.nextArg+  <*> many P.nextWord   -- | @parseIntersperse o p@ parses options and positional arguments,@@ -103,3 +98,100 @@       ps = Nothing <$ P.stopper       parser = po <|> ps <|> pa   in catMaybes <$> P.manyTill parser P.end++-- | Provides information on each mode that you wish to parse.+data Mode result = forall b. Mode+  { mName :: String+    -- ^ How the user identifies the mode on the command line. For+    -- example, with @git@ this would be @commit@, @pull@, etc.++  , mIntersperse :: Intersperse+    -- ^ Each mode may have options and positional arguments; may+    -- these be interspersed?++  , mOpts :: [C.OptSpec b]+    -- ^ Options for this mode++  , mPosArgs :: String -> b+    -- ^ How to parse positional arguments for this mode++  , mProcess :: [b] -> result+    -- ^ Processes the options after they have been parsed.+  +  }++instance Functor Mode where+  fmap f (Mode nm i os pa p) =+    Mode nm i os pa (f . p)++processModeArgs :: Mode result -> P.Parser result+processModeArgs (Mode _ i os pa p) = do+  let prsr = case i of+        Intersperse -> parseIntersperse+        StopOptions -> parseStopOpts+  rs <- prsr (C.parseOption os) pa <* P.end+  return $ p rs++-- | Parses a command line that may feature options followed by a+-- mode followed by more options and then followed by positional+-- arguments.+modes+  :: [C.OptSpec a]+     -- ^ Global options. These come after the program name but before+     -- the mode name.++  -> ([a] -> Ex.Exceptional String b)+     -- ^ This function is applied to all the global options after+     -- they are parsed. To indicate a failure, return an Exception+     -- String; otherwise, return a successful value. This allows you+     -- to process the global options before the mode is parsed. (If+     -- you don't need to do any preprocessing, pass @return@ here.)+     -- If you indicate a failure here, parsing of the command line+     -- will stop and this error message will be returned.++  -> (b -> Either (String -> c) [Mode result])+     -- ^ This function determines whether modes will be parsed and,+     -- if so, which ones. The function is applied to the result of+     -- the pre-processing of the global options, so which modes are+     -- parsed and the behavior of those modes can vary depending on+     -- the global options. Return a Left to indicate that you do not+     -- want to parse modes at all. For instance, if the user passed a+     -- @--help@ option, you may not want to look for a mode after+     -- that. Otherwise, to parse modes, return a Right with a list of+     -- the modes.++  -> [String]+     -- ^ The command line to parse (presumably from 'getArgs')++  -> Ex.Exceptional P.Error (b, Either [c] result)+     -- ^ Returns an Exception if an error was encountered when+     -- parsing the command line (including if the global options+     -- procesor returned an Exception.) Otherwise, returns a+     -- pair. The first element of the pair is the result of the+     -- global options processor. The second element of the pair is an+     -- Either. It is Left if no modes were parsed, with a list of the+     -- positional arguments. It is a Right if modes were parsed, with+     -- the result of parsing the arguments to the mode.++modes globals lsToB getCmds ss = P.parse ss $ do+  gs <- P.manyTill (C.parseOption globals) endOrNonOpt+  b <- case lsToB gs of+    Ex.Exception e -> fail e+    Ex.Success g -> return g+  let cmds = getCmds b+  case cmds of+    Left fPa -> do+      posArgs <- (fmap (fmap fPa) $ many P.nextWord) <* P.end+      return (b, Left posArgs)+    Right cds -> do+      let cmdWords = Set.fromList . map mName $ cds+      (_, w) <- P.matchApproxWord cmdWords+      let cmd = fromJust . find (\c -> mName c == w) $ cds+      r <- processModeArgs cmd+      return (b, Right r)++-- | Looks at the next word. Succeeds if it is a non-option, or if we+-- are at the end of input. Fails otherwise.+endOrNonOpt :: P.Parser ()+endOrNonOpt = (P.lookAhead P.nonOptionPosArg >> return ())+              <|> P.end

@@ -1,9 +1,9 @@ Name: multiarg-Version: 0.6.0.0+Version: 0.8.0.0 Cabal-version: >=1.8 Build-Type: Simple-License: MIT-Copyright: 2011-2012 Omari Norman.+License: BSD3+Copyright: 2011-2013 Omari Norman. author: Omari Norman maintainer: omari@smileystation.com stability: Experimental@@ -38,9 +38,9 @@  Library     Build-depends:-        base ==4.*,         explicit-exception ==0.1.*,         containers ==0.4.*+      -- See documentation in System.Console.MultiArg.GetArgs for details     if flag(newbase)