diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -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. diff --git a/System/Console/MultiArg.hs b/System/Console/MultiArg.hs --- a/System/Console/MultiArg.hs +++ b/System/Console/MultiArg.hs @@ -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. 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 - -- . - 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 diff --git a/System/Console/MultiArg/Combinator.hs b/System/Console/MultiArg/Combinator.hs --- a/System/Console/MultiArg/Combinator.hs +++ b/System/Console/MultiArg/Combinator.hs @@ -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 "" + diff --git a/System/Console/MultiArg/Prim.hs b/System/Console/MultiArg/Prim.hs --- a/System/Console/MultiArg/Prim.hs +++ b/System/Console/MultiArg/Prim.hs @@ -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 +-- . 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) diff --git a/System/Console/MultiArg/SampleParser.hs b/System/Console/MultiArg/SampleParser.hs --- a/System/Console/MultiArg/SampleParser.hs +++ b/System/Console/MultiArg/SampleParser.hs @@ -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 diff --git a/System/Console/MultiArg/SimpleParser.hs b/System/Console/MultiArg/SimpleParser.hs --- a/System/Console/MultiArg/SimpleParser.hs +++ b/System/Console/MultiArg/SimpleParser.hs @@ -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 diff --git a/multiarg.cabal b/multiarg.cabal --- a/multiarg.cabal +++ b/multiarg.cabal @@ -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)