diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2011-2012 Omari Norman.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in
+ the documentation and/or other materials provided with the
+ distribution.
+
+ * Neither the name of Omari Norman nor the names of its
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/System/Console/MultiArg.hs b/System/Console/MultiArg.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg.hs
@@ -0,0 +1,169 @@
+-- | A combinator library for building command-line parsers.
+
+module System.Console.MultiArg (
+
+ -- | To say this library is inspired by Parsec would probably insult the
+ -- creators of Parsec, as this library could not possibly be as
+ -- elegant or throughly considered as Parsec is. Nevertheless this
+ -- library can be used in a similar style as Parsec, but is
+ -- specialized for parsing command lines.
+ --
+ -- This parser was built because I could not find anything that would
+ -- readily parse command lines where the options took more than one
+ -- argument. For example, for the @tail@ command on GNU systems, the
+ -- --lines option takes one argument to specify how many lines you
+ -- want to see. Well, what if you want to build a program with an
+ -- option that takes /two/ arguments, like @--foo bar baz@? I found no
+ -- such library so I built this one. Nevertheless, using this library
+ -- you can build parsers to parse a variety of command line
+ -- vocabularies, from simple to complex.
+
+ -- * Terminology
+
+ -- | Some terms are used throughout multiarg:
+ --
+ -- [@word@] When you run your program from the Unix shell prompt,
+ -- your shell is responsible for splitting the command line into
+ -- words. Typically you separate words with spaces, although quoting
+ -- can affect this. multiarg parses lists of words. Each word can
+ -- consist of a single long option, a single long option and an
+ -- accompanying option argument, a single short option, multiple
+ -- short options, and even one or more multiple short options and an
+ -- accompanying short option argument. Or, a word can be a
+ -- positional argument or a stopper. All these are described below.
+ --
+ -- [@option@] Options allow a user to specify ways to tune the
+ -- operation of a program. Typically options are indeed optional,
+ -- although some programs do sport \"required options\" (a bit of an
+ -- oxymoron). Options can be either short options or long
+ -- options. Also, options can take arguments.
+ --
+ -- [@short option@] An option that is specified with a single hyphen
+ -- and a single letter. For example, for the program @tail(1)@,
+ -- possible short options include @n@ and @v@. With multiarg it is
+ -- possible to easily parse short options that are specified in
+ -- different words or in the same word. For example, if a user wants
+ -- to run @tail@ with two options, he might type @tail -v -f@ or he
+ -- might type @tail -vf@.
+ --
+ -- [@long option@] An option that is specified using two hyphens and
+ -- what is usually a mnemonic word, though it could be as short as a
+ -- single letter. For example, @tail(1)@ has long options including
+ -- @follow@ and @verbose@. The user would specify these on the
+ -- command line by typing @tail --follow --verbose@.
+ --
+ -- [@option argument@] Some options take additional arguments that
+ -- are specific to the option and change what the option does. For
+ -- instance, the @lines@ option to @tail(1)@ takes a single,
+ -- optional argument, which is the number of lines to show. Option
+ -- arguments can be optional or required, and a single option can
+ -- take a mulitple, fixed number of arguments and it can take a
+ -- variable number of arguments. Option arguments can be given in
+ -- various ways. They can be specified in the same word as a long
+ -- option by using an equals sign; they can also be specified in the
+ -- same word as a short option simply by placing them in the same
+ -- word, or they can be specified in the following word. For
+ -- example, these different command lines all mean the same thing;
+ -- @tail --verbose --lines=20@, @tail --verbose --lines 20@, @tail
+ -- -vn 20@, @tail -v -n20@, @tail -vn20@, and @tail -v -n 20@, and
+ -- numerous other combinations also have the same meaning.
+ --
+ -- [@GNU-style option argument@] A long option with an argument
+ -- given with an equal sign, such as [@lines=20@].
+ --
+ -- [@positional argument@] A word on the command line that is not an
+ -- option or an argument to an option. For instance, with @tail(1)@,
+ -- you specify the files you want to see by using positional
+ -- arguments. In the command @tail -n 10 myfile@, @myfile@ is a
+ -- positional argument. For some programs, such as @git@ or @darcs@,
+ -- a positional argument might be a \"command\" or a \"mode\", such
+ -- as the @commit@ in @git commit@ or the @whatsnew@ in @darcs
+ -- whatsnew@. multiarg has no primitive parsers that treat these
+ -- positional arguments specially but it is trivial to build a
+ -- parser for command lines such as this, too.
+ --
+ -- [@stopper@] A single word consisting solely of two hyphens,
+ -- @--@. The user types this to indicate that all subsequent words
+ -- on the command line are positional arguments, even if they begin
+ -- with hyphens and therefore look like they might be options.
+ --
+ -- [@pending@] The user might specify more than one short option, or
+ -- a short option and a short option argument, in a single word. For
+ -- example, she might type @tail -vl20@. After parsing the @v@
+ -- option, the Parser makes @l20@ into a \"pending\". The next
+ -- parser can then treat @l20@ as an option argument to the @v@
+ -- option (which is probably not what was wanted) or the next parser
+ -- can parse @l@ as a short option. This would result in a
+ -- \"pending\" of @20@. Then, the next parser can treat @20@ as an
+ -- option argument. After that parse there will be no pendings.
+
+ -- * Getting started
+
+ -- |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.
+ --
+ -- 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.
+
+ -- * Non-features and shortcomings
+ --
+ -- | multiarg isn't perfect; no software is. multiarg does not
+ -- automatically make online help for your command line
+ -- parsers. Getting this right would be tricky given the nature of
+ -- the code and I don't even want to bother trying, as I just write
+ -- my own online help in a text editor.
+ --
+ -- multiarg partially embraces \"The Tao of Option Parsing\" that
+ -- Python's Optik () follows. Read
+ -- \"The Tao of Option Parsing\" here:
+ --
+ --
+ --
+ -- multiarg's philosophy is similar to that of Optik, which
+ -- means you won't be able to use multiarg to (easily) build a clone
+ -- to the UNIX @find(1)@ command. (You could do it, but multiarg won't
+ -- help you very much.)
+ --
+ -- multiarg can be complicated, although I'd like to believe this is
+ -- because it addresses a complicated problem in a flexible way.
+ --
+ -- Internally the combinators in "System.Console.MultiArg.Prim" use
+ -- strict "Data.Text" values rather than "String"s. That is because
+ -- this library was built for an application that sometimes parses an
+ -- enormous amount of command line data, and I thought that using
+ -- Data.Text would yield some memory savings while retaining Unicode
+ -- safety. Though I cannot remember whether this actually yielded any
+ -- space savings (it did not lead to more space usage, at least) it
+ -- also made the parser consistent with the rest of that program,
+ -- which also uses Data.Text. I have considered making this library
+ -- use either Data.Text or Strings but that makes it a lot more
+ -- complicated for little gain. The SimpleParser module, however,
+ -- wraps the "Data.Text" values up and exposes only Strings in the
+ -- interface, keeping things nice and simple. This does mean that
+ -- Strings have to be converted to Data.Text and back again, but the
+ -- performance hit will not be significant unless you are parsing an
+ -- obscene amount of data--and if you're doing that, you might want to
+ -- use Data.Text anyway :)
+
+ module System.Console.MultiArg.SimpleParser ) where
+
+import System.Console.MultiArg.SimpleParser
diff --git a/System/Console/MultiArg/Combinator.hs b/System/Console/MultiArg/Combinator.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/Combinator.hs
@@ -0,0 +1,364 @@
+-- | Combinators that are useful for building command-line
+-- parsers. These build off the functions in
+-- "System.Console.MultiArg.Prim". Unlike those functions, these
+-- functions have no access to the internals of the parser.
+module System.Console.MultiArg.Combinator (
+ -- * Parser combinators
+ option,
+ optionMaybe,
+ notFollowedBy,
+
+ -- * Short options
+ shortNoArg,
+ shortOptionalArg,
+ shortOneArg,
+ shortTwoArg,
+ shortVariableArg,
+
+ -- * Long options
+ nonGNUexactLongOpt,
+ matchApproxLongOpt,
+ matchNonGNUApproxLongOpt,
+ longNoArg,
+ longOptionalArg,
+ longOneArg,
+ longTwoArg,
+ longVariableArg,
+
+ -- * Mixed options
+ mixedNoArg,
+ mixedOptionalArg,
+ mixedOneArg,
+ mixedTwoArg,
+ mixedVariableArg,
+
+ -- * Other words
+ matchApproxWord ) where
+
+import Data.Text ( Text, isPrefixOf )
+import Data.Set ( Set )
+import qualified Data.Set as Set
+import Control.Monad ( liftM )
+
+import System.Console.MultiArg.Prim
+ ( ParserT, throw, try, approxLongOpt,
+ nextArg, pendingShortOptArg, nonOptionPosArg,
+ pendingShortOpt, nonPendingShortOpt,
+ exactLongOpt, nextArg, ())
+import System.Console.MultiArg.Option
+ ( LongOpt, ShortOpt )
+import qualified System.Console.MultiArg.Error as E
+import System.Console.MultiArg.Error
+ ( Error, parseErr )
+import Control.Applicative ((<|>), many)
+import Control.Monad ( void )
+import Data.Monoid ( mconcat )
+
+-- | @option x p@ runs parser p. If p fails without consuming any
+-- input, returns x. Otherwise, returns p.
+option :: (Error e, Monad m) =>
+ a
+ -> ParserT s e m a
+ -> ParserT s e m a
+option x p = p <|> return x
+
+-- | @optionMaybe p@ runs parser p. If p fails without returning any
+-- input, returns Nothing. If p succeeds, returns the result of p
+-- wrapped in a Just. If p fails but consumes input, optionMaybe
+-- fails.
+optionMaybe :: (Error e, Monad m)
+ => ParserT s e m a
+ -> ParserT s e m (Maybe a)
+optionMaybe p = option Nothing (liftM Just p)
+
+-- | @notFollowedBy p@ succeeds only if parser p fails. If p fails,
+-- notFollowedBy succeeds without consuming any input. If p succeeds
+-- and consumes input, notFollowedBy fails and consumes input. If p
+-- succeeds and does not consume any input, notFollowedBy fails and
+-- does not consume any input.
+notFollowedBy :: (Error e, Monad m)
+ => ParserT s e m a
+ -> ParserT s e m ()
+notFollowedBy p =
+ void $ ((try p >> throw (E.parseErr E.ExpNotFollowedBy E.SawFollowedBy))
+ <|> return ())
+
+
+-- | Parses only a non-GNU style long option (that is, one that does
+-- not take option arguments by attaching them with an equal sign,
+-- such as @--lines=20@).
+nonGNUexactLongOpt :: (Error e, Monad m)
+ => LongOpt
+ -> ParserT s e m LongOpt
+nonGNUexactLongOpt l = try $ do
+ (lo, maybeArg) <- exactLongOpt l
+ case maybeArg of
+ Nothing -> return lo
+ (Just t) ->
+ throw (parseErr (E.ExpNonGNUExactLong l)
+ (E.SawGNULongOptArg t))
+
+-- | Takes a long option and a set of long options. If the next word
+-- on the command line unambiguously starts with the name of the long
+-- option given, returns the actual text found on the command line,
+-- the long option, and the text of any GNU-style option
+-- argument. Make sure that the long option you are looking for is
+-- both the first argument and that it is included in the set;
+-- otherwise this parser will always fail.
+matchApproxLongOpt :: (Error e, Monad m)
+ => LongOpt
+ -> Set LongOpt
+ -> ParserT s e m (Text, LongOpt, Maybe Text)
+matchApproxLongOpt l s = try $ do
+ a@(t, lo, _) <- approxLongOpt s
+ if lo == l
+ then return a
+ else throw (parseErr (E.ExpMatchingApproxLong l s)
+ (E.SawNotMatchingApproxLong t lo))
+
+-- | Like matchApproxLongOpt but only parses non-GNU-style long
+-- options.
+matchNonGNUApproxLongOpt :: (Error e, Monad m)
+ => LongOpt
+ -> Set LongOpt
+ -> ParserT s e m (Text, LongOpt)
+matchNonGNUApproxLongOpt l s = try $ do
+ (t, lo, arg) <- matchApproxLongOpt l s
+ let err b = throw (parseErr (E.ExpNonGNUMatchingApproxLong l s)
+ (E.SawMatchingApproxLongWithArg b))
+ maybe (return (t, lo)) err arg
+
+-- | 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 :: (Error e, Monad m)
+ => Set Text
+ -> ParserT s e m (Text, Text)
+matchApproxWord s = try $ do
+ a <- nextArg
+ let p t = a `isPrefixOf` t
+ matches = Set.filter p s
+ err saw = throw (parseErr (E.ExpApproxWord s) saw)
+ case Set.toList matches of
+ [] -> err (E.SawNoMatches a)
+ (x:[]) -> return (a, x)
+ _ -> err (E.SawMultipleApproxMatches matches a)
+
+-- | Parses short options that do not take any argument. (It is
+-- however okay for the short option to be combined with other short
+-- options in the same word.)
+shortNoArg :: (Error e, Monad m)
+ => ShortOpt
+ -> ParserT s e m ShortOpt
+shortNoArg s = pendingShortOpt s <|> nonPendingShortOpt s
+
+-- | Parses short options that take an optional argument. The argument
+-- can be combined in the same word with the short option (@-c42@) or
+-- can be in the ext word (@-c 42@).
+shortOptionalArg :: (Error e, Monad m)
+ => ShortOpt
+ -> ParserT s e m (ShortOpt, Maybe Text)
+shortOptionalArg s = do
+ so <- shortNoArg s
+ a <- optionMaybe (pendingShortOptArg <|> nonOptionPosArg)
+ return (so, a)
+
+-- | Parses short options that take a required argument. The argument
+-- can be combined in the same word with the short option (@-c42@) or
+-- can be in the ext word (@-c 42@).
+shortOneArg :: (Error e, Monad m) =>
+ ShortOpt
+ -> ParserT s e m (ShortOpt, Text)
+shortOneArg s = do
+ so <- shortNoArg s
+ a <- pendingShortOptArg <|> nextArg
+ return (so, a)
+
+-- | Parses short options that take two required arguments. The first
+-- argument can be combined in the same word with the short option
+-- (@-c42@) or can be in the ext word (@-c 42@). The next argument
+-- will have to be in a separate word.
+shortTwoArg :: (Error e, Monad m)
+ => ShortOpt
+ -> ParserT s e m (ShortOpt, Text, Text)
+shortTwoArg s = do
+ (so, a1) <- shortOneArg s
+ a2 <- nextArg
+ return (so, a1, a2)
+
+-- | Parses short options that take a variable number of
+-- arguments. This will keep on parsing option arguments until it
+-- encounters one that does not "look like" an option--that is, until
+-- it encounters one that begins with a dash. Therefore, the only way
+-- to terminate a variable argument option if it is the last option is
+-- with a stopper. The first argument can be combined in the same word
+-- with the short option (@-c42@) or can be in the ext word (@-c
+-- 42@). Subsequent arguments will have to be in separate words.
+shortVariableArg :: (Error e, Monad m)
+ => ShortOpt
+ -> ParserT s e m (ShortOpt, [Text])
+shortVariableArg s = do
+ so <- shortNoArg s
+ firstArg <- optionMaybe pendingShortOptArg
+ rest <- many nonOptionPosArg
+ let result = maybe rest ( : rest ) firstArg
+ return (so, result)
+
+-- | Parses long options that do not take any argument.
+longNoArg :: (Error e, Monad m)
+ => LongOpt
+ -> ParserT s e m LongOpt
+longNoArg = nonGNUexactLongOpt
+
+-- | Parses long options that take a single, optional argument. The
+-- single argument can be given GNU-style (@--lines=20@) or non-GNU
+-- style in separate words (@lines 20@).
+longOptionalArg :: (Error e, Monad m)
+ => LongOpt
+ -> ParserT s e m (LongOpt, Maybe Text)
+longOptionalArg = exactLongOpt
+
+-- | Parses long options that take a single, required argument. The
+-- single argument can be given GNU-style (@--lines=20@) or non-GNU
+-- style in separate words (@lines 20@).
+longOneArg :: (Error e, Monad m)
+ => LongOpt
+ -> ParserT s e m (LongOpt, Text)
+longOneArg l = do
+ (lo, mt) <- longOptionalArg l
+ case mt of
+ (Just t) -> return (lo, t)
+ Nothing -> do
+ a <- nextArg E.parseErr E.ExpLongOptArg E.SawNoArgsLeft
+ return (l, a)
+
+-- | Parses long options that take a double, required argument. The
+-- first argument can be given GNU-style (@--lines=20@) or non-GNU
+-- style in separate words (@lines 20@). The second argument will have
+-- to be in a separate word.
+longTwoArg :: (Error e, Monad m)
+ => LongOpt
+ -> ParserT s e m (LongOpt, Text, Text)
+longTwoArg l = do
+ (lo, mt) <- longOptionalArg l
+ case mt of
+ (Just t) -> do
+ a2 <- nextArg
+ return (lo, t, a2)
+ Nothing -> do
+ a1 <- nextArg
+ a2 <- nextArg
+ return (lo, a1, a2)
+
+-- | Parses long options that take a variable number of
+-- arguments. This will keep on parsing option arguments until it
+-- encounters one that does not "look like" an option--that is, until
+-- it encounters one that begins with a dash. Therefore, the only way
+-- to terminate a variable argument option if it is the last option is
+-- with a stopper. The first argument can be combined in the same word
+-- with the short option (@--lines=20@) or can be in the ext word
+-- (@--lines 42@). Subsequent arguments will have to be in separate
+-- words.
+longVariableArg :: (Error e, Monad m)
+ => LongOpt
+ -> ParserT s e m (LongOpt, [Text])
+longVariableArg l = do
+ (lo, mt) <- longOptionalArg l
+ rest <- many nonOptionPosArg
+ return (lo, maybe rest (:rest) mt)
+
+-- | Parses at least one long option and a variable number of short
+-- and long options that take no arguments.
+mixedNoArg :: (Error e, Monad m)
+ => LongOpt
+ -> [LongOpt]
+ -> [ShortOpt]
+ -> ParserT s e m (Either ShortOpt LongOpt)
+mixedNoArg l ls ss = mconcat ([f] ++ longs ++ shorts) where
+ toLong lo = do
+ r <- longNoArg lo
+ return $ Right r
+ toShort so = do
+ s <- shortNoArg so
+ return $ Left s
+ f = toLong l
+ longs = map toLong ls
+ shorts = map toShort ss
+
+-- | Parses at least one long option and a variable number of short
+-- and long options that take an optional argument.
+mixedOptionalArg ::
+ (Error e, Monad m)
+ => LongOpt
+ -> [LongOpt]
+ -> [ShortOpt]
+ -> ParserT s e m ((Either ShortOpt LongOpt), Maybe Text)
+mixedOptionalArg l ls ss = mconcat ([f] ++ longs ++ shorts) where
+ toLong lo = do
+ (o, a) <- longOptionalArg lo
+ return $ (Right o, a)
+ toShort so = do
+ (o, a) <- shortOptionalArg so
+ return $ (Left o, a)
+ f = toLong l
+ longs = map toLong ls
+ shorts = map toShort ss
+
+-- | Parses at least one long option and additional long and short
+-- options that take one argument.
+mixedOneArg ::
+ (Error e, Monad m)
+ => LongOpt
+ -> [LongOpt]
+ -> [ShortOpt]
+ -> ParserT s e m ((Either ShortOpt LongOpt), Text)
+mixedOneArg l ls ss = mconcat ([f] ++ longs ++ shorts) where
+ toLong lo = do
+ (o, a) <- longOneArg lo
+ return (Right o, a)
+ toShort lo = do
+ (o, a) <- shortOneArg lo
+ return (Left o, a)
+ f = toLong l
+ longs = map toLong ls
+ shorts = map toShort ss
+
+-- | Parses at least one long option and additonal long and short
+-- options that take two arguments.
+mixedTwoArg ::
+ (Error e, Monad m)
+ => LongOpt
+ -> [LongOpt]
+ -> [ShortOpt]
+ -> ParserT s e m ((Either ShortOpt LongOpt), Text, Text)
+mixedTwoArg l ls ss = mconcat ([f] ++ longs ++ shorts) where
+ toLong lo = do
+ (o, a1, a2) <- longTwoArg lo
+ return (Right o, a1, a2)
+ toShort lo = do
+ (o, a1, a2) <- shortTwoArg lo
+ return (Left o, a1, a2)
+ f = toLong l
+ longs = map toLong ls
+ shorts = map toShort ss
+
+-- | Parses at least one long option and additional long and short
+-- options that take a variable number of arguments.
+mixedVariableArg ::
+ (Error e, Monad m)
+ => LongOpt
+ -> [LongOpt]
+ -> [ShortOpt]
+ -> ParserT s e m ((Either ShortOpt LongOpt), [Text])
+mixedVariableArg l ls ss = mconcat ([f] ++ longs ++ shorts) where
+ toLong lo = do
+ (o, a) <- longVariableArg lo
+ return (Right o, a)
+ toShort lo = do
+ (o, a) <- shortVariableArg lo
+ return (Left o, a)
+ f = toLong l
+ longs = map toLong ls
+ shorts = map toShort ss
+
diff --git a/System/Console/MultiArg/Error.hs b/System/Console/MultiArg/Error.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/Error.hs
@@ -0,0 +1,274 @@
+-- | Errors. Parsing a command line when a user has entered it
+-- correctly is easy; doing something sensible when an incorrect line
+-- has been entered is a bit more difficult. This module exports an
+-- 'Error' typeclass, which you can declare instances of in order to
+-- have your own type to represent errors. Or you can use
+-- 'SimpleError', which is already an instance of 'Error'.
+module System.Console.MultiArg.Error where
+
+import System.Console.MultiArg.Option
+ ( LongOpt, ShortOpt, unLongOpt, unShortOpt )
+import System.Console.MultiArg.TextNonEmpty
+ ( TextNonEmpty ( TextNonEmpty ) )
+import Data.Text ( Text, pack, append, singleton, intercalate,
+ snoc )
+import Data.Set ( Set )
+import qualified Data.Set as Set
+import Test.QuickCheck ( Arbitrary ( arbitrary ),
+ choose )
+import System.Console.MultiArg.QuickCheckHelpers
+ ( randSet, randText )
+import Control.Monad ( liftM, liftM2 )
+
+-- | Instances of this typeclass represent multiarg errors. You can
+-- declare instances of this typeclass so that you can use your own
+-- type for errors. This makes multiarg easy to integrate into your
+-- own programs. Then you can also easily add other errors, which you
+-- can report from the parsers you build by calling
+-- 'System.Console.MultiArg.Prim.throw'.
+class Error e where
+ -- | Store an error in your Error instance.
+ parseErr :: Expecting -> Saw -> e
+
+-- | A simple type that is already an instance of 'Error'.
+data SimpleError = SimpleError Expecting Saw deriving (Show, Eq)
+
+-- | Generates error messages.
+printError :: SimpleError -> Text
+printError (SimpleError e s) =
+ pack "Error parsing command line input.\n"
+ `append` pack "expected to see: "
+ `append` printExpecting e `snoc` '\n'
+ `append` pack "actually saw: "
+ `append` printSaw s `snoc` '\n'
+
+instance Error SimpleError where
+ parseErr = SimpleError
+
+instance Arbitrary SimpleError where
+ arbitrary = liftM2 SimpleError arbitrary arbitrary
+
+-- | Each error consists of two parts: what the parser was expecting
+-- to see, and what it actually saw. This type holds what the parser
+-- expected to see. If you just want to give some text to be used in
+-- an error message, use 'ExpTextError'. To generate a generic error,
+-- use 'ExpOtherFailure'.
+data Expecting = ExpPendingShortOpt ShortOpt
+ | ExpExactLong LongOpt
+ | ExpApproxLong (Set LongOpt)
+ | ExpLongOptArg
+ | ExpPendingShortArg
+ | ExpStopper
+ | ExpNextArg
+ | ExpNonOptionPosArg
+ | ExpEnd
+ | ExpNonGNUExactLong LongOpt
+ | ExpMatchingApproxLong LongOpt (Set LongOpt)
+ | ExpNonGNUMatchingApproxLong LongOpt (Set LongOpt)
+ | ExpApproxWord (Set Text)
+ | ExpOptionOrPosArg
+ | ExpTextError Text
+ | ExpNonPendingShortOpt ShortOpt
+ | ExpNotFollowedBy
+ | ExpOtherFailure
+ deriving (Show, Eq)
+
+-- | Generates an error message from an Expecting.
+printExpecting :: Expecting -> Text
+printExpecting e = case e of
+ (ExpPendingShortOpt s) ->
+ (pack "short option: ") `append` (singleton . unShortOpt $ s)
+ (ExpExactLong l) ->
+ (pack "long option: ") `append` (unLongOpt $ l)
+ (ExpApproxLong ls) ->
+ (pack "approximate long option matching one of: ") `append`
+ intercalate (pack ", ") (map unLongOpt . Set.toList $ ls)
+ ExpLongOptArg -> pack "argument to long option"
+ ExpPendingShortArg -> pack "argument to short option"
+ ExpStopper -> pack "stopper (\"--\")"
+ ExpNextArg -> pack "next word on command line"
+ ExpNonOptionPosArg ->
+ pack "word on command line not starting with a hyphen"
+ ExpEnd -> pack "end of command line input"
+ (ExpNonGNUExactLong lo) ->
+ pack "long option without an included argument: "
+ `append` (unLongOpt lo)
+ (ExpMatchingApproxLong l ls) ->
+ pack "abbreviated long option named: " `append` (unLongOpt l)
+ `append` pack "from possible abbreviated long options named: "
+ `append` (intercalate (pack ", ")
+ (map unLongOpt . Set.toList $ ls))
+ (ExpNonGNUMatchingApproxLong l ls) ->
+ pack "abbreviated long without an included argument named: "
+ `append` (unLongOpt l)
+ `append` pack "from possible abbreviated long options named: "
+ `append` (intercalate (pack ", ")
+ (map unLongOpt . Set.toList $ ls))
+ (ExpApproxWord ws) ->
+ pack "one of these abbreviated words: "
+ `append` (intercalate (pack ", ") (Set.toList $ ws))
+ ExpOptionOrPosArg ->
+ pack "option or positional argument"
+ (ExpTextError t) -> t
+ (ExpNonPendingShortOpt s) ->
+ (pack "short option: ") `append` (singleton . unShortOpt $ s)
+ ExpNotFollowedBy ->
+ pack "not followed by"
+ (ExpOtherFailure) -> pack "general failure"
+
+
+
+instance Arbitrary Expecting where
+ arbitrary = do
+ i <- choose (0, (17 :: Int))
+ case i of
+ 0 -> liftM ExpPendingShortOpt arbitrary
+ 1 -> liftM ExpExactLong arbitrary
+ 2 -> liftM ExpApproxLong randSet
+ 3 -> return ExpLongOptArg
+ 4 -> return ExpPendingShortArg
+ 5 -> return ExpStopper
+ 6 -> return ExpNextArg
+ 7 -> return ExpNonOptionPosArg
+ 8 -> return ExpEnd
+ 9 -> liftM ExpNonGNUExactLong arbitrary
+ 10 -> liftM2 ExpMatchingApproxLong arbitrary randSet
+ 11 -> liftM2 ExpNonGNUMatchingApproxLong arbitrary randSet
+ 12 -> liftM ExpApproxWord
+ (liftM (Set.fromList . map pack) arbitrary)
+ 13 -> return ExpOptionOrPosArg
+ 14 -> liftM ExpTextError randText
+ 15 -> liftM ExpNonPendingShortOpt arbitrary
+ 16 -> return ExpNotFollowedBy
+ 17 -> return ExpOtherFailure
+ _ -> error "should never happen"
+
+-- | What the parser actually saw. To give some text to be used in the
+-- error message, use 'SawTextError'. To generate a generic error, use
+-- 'SawOtherFailure'.
+data Saw = SawNoPendingShorts
+ | SawWrongPendingShort Char
+ | SawNoArgsLeft
+ | SawEmptyArg
+ | SawSingleDashArg
+ | SawStillPendingShorts TextNonEmpty
+ | SawNotShortArg Text
+ | SawWrongShortArg Char
+ | SawNotLongArg Text
+ | SawWrongLongArg Text
+ | SawNoMatches Text
+ | SawMultipleMatches (Set LongOpt) Text
+ | SawNoPendingShortArg
+ | SawAlreadyStopper
+ | SawNewStopper
+ | SawNotStopper
+ | SawLeadingDashArg Text
+ | SawMoreInput
+ | SawGNULongOptArg Text
+ | SawNotMatchingApproxLong Text LongOpt
+ | SawMatchingApproxLongWithArg Text -- Text of the argument
+ | SawMultipleApproxMatches (Set Text) Text
+ | SawNoOption
+ | SawNoOptionOrPosArg
+ | SawTextError Text
+ | SawFollowedBy
+ | SawOtherFailure
+ deriving (Show, Eq)
+
+-- | Generates error messages from a 'Saw'.
+printSaw :: Saw -> Text
+printSaw s = case s of
+ SawNoPendingShorts -> pack "no pending short options"
+ (SawWrongPendingShort c) ->
+ pack "unexpected short option: " `snoc` c
+ SawNoArgsLeft -> pack "no command line words remaining"
+ SawEmptyArg -> pack "command line word that is the empty string"
+ SawSingleDashArg ->
+ pack "command line word that is a single hyphen (\"-\")"
+ (SawStillPendingShorts (TextNonEmpty first rest)) ->
+ pack "pending short options: " `snoc` first
+ `append` rest
+ (SawNotShortArg t) ->
+ pack "word that is not a short option: " `append` t
+ (SawWrongShortArg c) ->
+ pack "wrong short option: " `snoc` c
+ (SawNotLongArg t) ->
+ pack "word that is not a long option: " `append` t
+ (SawWrongLongArg t) ->
+ pack "wrong long option: " `append` t
+ (SawNoMatches t) ->
+ pack "word that does not match the available choices: "
+ `append` t
+ (SawMultipleMatches ss t) ->
+ pack "word matches more than one of the available choices. "
+ `append` pack "word given: " `append` t
+ `append` pack " matches these words: "
+ `append` (intercalate (pack ", ") (map unLongOpt . Set.toList $ ss))
+ SawNoPendingShortArg -> pack "no short argument"
+ SawAlreadyStopper ->
+ pack "already seen a stopper (\"--\")"
+ SawNewStopper ->
+ pack "new stopper (\"--\")"
+ SawNotStopper ->
+ pack "word that is not a stopper (\"--\")"
+ (SawLeadingDashArg t) ->
+ pack "word with a leading hyphen: " `append` t
+ SawMoreInput ->
+ pack "additional words remaining on command line"
+ (SawGNULongOptArg t) ->
+ pack "attached argument for option that does not take one: "
+ `append` t
+ (SawNotMatchingApproxLong t lo) ->
+ pack "long argument that does not match expected one. "
+ `append` pack "argument given: " `append` t
+ `append` pack "argument expected: " `append` unLongOpt lo
+ (SawMatchingApproxLongWithArg t) ->
+ pack "long argument that matches expected long argument, but it "
+ `append` pack "has an attached argument. Text of argument: "
+ `append` t
+ (SawMultipleApproxMatches ms m) ->
+ pack "multiple words match the one given. Word given: " `append` m
+ `append` pack "possible matches: "
+ `append` (intercalate (pack ", ") (Set.toList ms))
+ SawNoOption ->
+ pack "word that is not an option"
+ SawNoOptionOrPosArg ->
+ pack "not an option or positional argument"
+ (SawTextError t) -> t
+ SawFollowedBy -> pack "followed by"
+ (SawOtherFailure) -> pack "general failure"
+
+instance Arbitrary Saw where
+ arbitrary = do
+ i <- choose (0, (26 :: Int))
+ case i of
+ 0 -> return SawNoPendingShorts
+ 1 -> liftM SawWrongPendingShort arbitrary
+ 2 -> return SawNoArgsLeft
+ 3 -> return SawEmptyArg
+ 4 -> return SawSingleDashArg
+ 5 -> liftM SawStillPendingShorts arbitrary
+ 6 -> liftM SawNotShortArg randText
+ 7 -> liftM SawWrongShortArg arbitrary
+ 8 -> liftM SawNotLongArg randText
+ 9 -> liftM SawWrongLongArg randText
+ 10 -> liftM SawNoMatches randText
+ 11 -> liftM2 SawMultipleMatches randSet randText
+ 12 -> return SawNoPendingShortArg
+ 13 -> return SawAlreadyStopper
+ 14 -> return SawNewStopper
+ 15 -> return SawNotStopper
+ 16 -> liftM SawLeadingDashArg randText
+ 17 -> return SawMoreInput
+ 18 -> liftM SawGNULongOptArg randText
+ 19 -> liftM2 SawNotMatchingApproxLong randText arbitrary
+ 20 -> liftM SawMatchingApproxLongWithArg randText
+ 21 -> liftM2 SawMultipleApproxMatches
+ (liftM (Set.fromList . map pack) arbitrary)
+ randText
+ 22 -> return SawNoOption
+ 23 -> return SawNoOptionOrPosArg
+ 24 -> liftM SawTextError randText
+ 25 -> return SawFollowedBy
+ 26 -> return SawOtherFailure
+ _ -> error "should never happen"
diff --git a/System/Console/MultiArg/GetArgs.hs b/System/Console/MultiArg/GetArgs.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/GetArgs.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE CPP #-}
+
+-- | Get the arguments from the command line, ensuring they are
+-- properly encoded into Unicode.
+--
+-- base 4.3.1.0 has a System.Environment.getArgs that does not return
+-- a Unicode string. Instead, it simply puts each octet into a
+-- different Char. Thus its getArgs is broken on UTF-8 and nearly any
+-- non-ASCII encoding. As a workaround I use
+-- System.Environment.UTF8. The downside of this is that it requires
+-- that the command line be encoded in UTF8, regardless of what the
+-- default system encoding is.
+--
+-- Unlike base 4.3.1.0, base 4.4.0.0 actually returns a proper Unicode
+-- string when you call System.Environment.getArgs. (base 4.3.1.0
+-- comes with ghc 7.0.4; base 4.4.0.0 comes with ghc 7.2.) The string
+-- is encoded depending on the default system locale. The only problem
+-- is that System.Environment.UTF8 apparently simply uses
+-- System.Environment.getArgs and then assumes that the string it
+-- returns has not been decoded. In other words,
+-- System.Environment.UTF8 assumes that System.Environment.getArgs is
+-- broken, and when System.Environment.getArgs was fixed in base
+-- 4.4.0.0, it likely will break System.Environment.UTF8.
+--
+-- One obvious solution to this problem is to find some other way to
+-- get the command line that will not break when base is updated. But
+-- it was not easy to find such a thing. The other libraries I saw on
+-- hackage (as of January 6, 2012) had problems, such as breakage on
+-- ghc 7.2. There is a package that has a simple interface to the UNIX
+-- setlocale(3) function, but I'm not sure that what it returns easily
+-- and reliably maps to character encodings that you can use with,
+-- say, iconv.
+--
+-- So by use of Cabal and preprocessor macors, the code uses
+-- utf8-string if base is less than 4.4, and uses
+-- System.Environment.getArgs if base is at least 4.4.
+--
+-- The GHC bug is here:
+--
+--
+
+module System.Console.MultiArg.GetArgs ( getArgs, getProgName ) where
+
+#if MIN_VERSION_base(4,4,0)
+import qualified System.Environment as E ( getArgs, getProgName )
+#else
+import qualified System.Environment.UTF8 as E ( getArgs, getProgName )
+#endif
+
+-- | Gets the command-line arguments supplied by the program's
+-- user. If the @base@ package is older than version 4.4, then this
+-- function assumes the command line is encoded in UTF-8, which is
+-- true for many newer Unix systems; however, many older systems may
+-- use single-byte encodings like ISO-8859. In such cases, this
+-- function will give erroneous results.
+--
+-- If the @base@ package is version 4.4.0 or newer, this function
+-- simply uses the getArgs that comes with @base@. That getArgs
+-- detects the system's default encoding and uses that, so it should
+-- give accurate results on most systems.
+getArgs :: IO [String]
+getArgs = E.getArgs
+
+-- | Gets the name of the program that the user invoked. See
+-- documentation for 'getArgs' for important caveats that also apply
+-- to this function.
+getProgName :: IO String
+getProgName = E.getProgName
diff --git a/System/Console/MultiArg/Option.hs b/System/Console/MultiArg/Option.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/Option.hs
@@ -0,0 +1,72 @@
+-- | These types represent options. They are abstract and in a
+-- separate module to prevent you from accidentally making an option
+-- with an invalid name. Option names cannot have a dash as their
+-- first or second character, and long option names cannot have an
+-- equals sign anywhere in the name.
+module System.Console.MultiArg.Option (
+ ShortOpt,
+ unShortOpt,
+ makeShortOpt,
+ LongOpt,
+ unLongOpt,
+ makeLongOpt )
+ where
+
+import Test.QuickCheck ( Arbitrary ( arbitrary ),
+ suchThat )
+import qualified Data.Text as X
+import Data.Text ( Text, unpack, index )
+import Control.Monad ( when )
+import System.Console.MultiArg.QuickCheckHelpers ( randText )
+
+-- | Short options. Options that are preceded with a single dash on
+-- the command line and consist of a single letter. That single letter
+-- cannot be a dash. Any other Unicode character is good (including
+-- pathological ones like newlines).
+newtype ShortOpt = ShortOpt { unShortOpt :: Char } deriving (Show, Eq, Ord)
+instance Arbitrary ShortOpt where
+ arbitrary = do
+ c <- suchThat arbitrary (/= '-')
+ return $ ShortOpt c
+
+-- | This function is partial. It calls error if its argument is a
+-- single dash. This is the only way to make a short option so it
+-- prevents you from making one that is invalid.
+makeShortOpt :: Char -> ShortOpt
+makeShortOpt c = case c of
+ '-' -> error "short option must not be a dash"
+ x -> ShortOpt x
+
+-- | Long options. Options that are preceded with two dashes on the
+-- command line and typically consist of an entire mnemonic word, such
+-- as @lines@. However, anything that is at least one letter long is
+-- fine for a long option name. The name must not have a dash as
+-- either the first or second character and it must be at least one
+-- character long. It cannot have an equal sign anywhere in its
+-- name. Otherwise any Unicode character is good (including
+-- pathological ones like newlines).
+data LongOpt = LongOpt { unLongOpt :: Text } deriving (Show, Eq, Ord)
+instance Arbitrary LongOpt where
+ arbitrary = do
+ t <- suchThat randText isValidLongOptText
+ return $ LongOpt t
+
+-- | This function is partial. It calls error if its argument contains
+-- text that is not a valid long option. This is the only way to make
+-- a long option so it prevents you from making invalid ones.
+makeLongOpt :: Text -> LongOpt
+makeLongOpt t = case isValidLongOptText t of
+ True -> LongOpt t
+ False -> error $ "invalid long option: " ++ unpack t
+
+isValidLongOptText :: Text -> Bool
+isValidLongOptText t = maybe False (const True) $ do
+ when (X.null t) Nothing
+ when ((t `index` 0) == '-') Nothing
+ when ((X.length t > 1) && ((t `index` 1) == '-')) Nothing
+ case X.find (== '=') t of
+ (Just _) -> Nothing
+ Nothing -> return ()
+ return ()
+
+
diff --git a/System/Console/MultiArg/Prim.hs b/System/Console/MultiArg/Prim.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/Prim.hs
@@ -0,0 +1,847 @@
+-- | Parser primitives. These are the only functions that have access
+-- to the internals of the parser.
+module System.Console.MultiArg.Prim (
+ -- * Parser types
+ Parser,
+ ParserE,
+ ParserSE,
+ ParserT,
+
+ -- * Running a parser
+
+ -- | Each parser runner is applied to a list of Text, which are the
+ -- command line arguments to parse. 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'.
+ parse,
+ parseE,
+ parseSE,
+ parseT,
+
+ -- * Higher-level parser combinators
+ parserMap,
+ good,
+ apply,
+ choice,
+ combine,
+ lookAhead,
+
+ -- ** Running parsers multiple times
+ several,
+ manyTill,
+
+ -- ** Monad lifting
+ parserLift,
+ parserIO,
+
+ -- ** Failure and errors
+ throw,
+ throwString,
+ genericThrow,
+ (),
+ try,
+
+ -- * Parsers
+ -- ** Short options and arguments
+ pendingShortOpt,
+ nonPendingShortOpt,
+ pendingShortOptArg,
+
+ -- ** Long options and arguments
+ exactLongOpt,
+ approxLongOpt,
+
+ -- ** Stoppers
+ stopper,
+
+ -- ** Positional (non-option) arguments
+ nextArg,
+ nonOptionPosArg,
+
+ -- ** Miscellaneous
+ end,
+
+ -- * User state
+ get,
+ put,
+ modify
+ ) where
+
+
+import qualified System.Console.MultiArg.Error as E
+import System.Console.MultiArg.Option
+ (ShortOpt,
+ unShortOpt,
+ LongOpt,
+ unLongOpt )
+import System.Console.MultiArg.TextNonEmpty
+ ( TextNonEmpty ( TextNonEmpty ) )
+import Control.Applicative ( Applicative, Alternative )
+import qualified Control.Applicative
+import Control.Monad.Exception.Synchronous
+ (Exceptional(Success, Exception), switch )
+import qualified Control.Monad.Exception.Synchronous as S
+import Data.Functor.Identity ( runIdentity )
+import Data.Text ( Text, pack, isPrefixOf, cons )
+import qualified Data.Text as X
+import qualified Data.Set as Set
+import Data.Set ( Set )
+import Control.Monad ( when, MonadPlus(mzero, mplus) )
+import Control.Monad.Trans.Class ( lift )
+import Data.Maybe ( isNothing )
+import Data.Monoid ( Monoid ( mempty, mappend ) )
+import Data.Functor.Identity ( Identity )
+import Control.Monad.Trans.Class ( MonadTrans )
+import Control.Monad.IO.Class ( MonadIO ( liftIO ) )
+
+-- | Takes the head of a Text. Returns Nothing if the Text is empty.
+textHead :: Text -> Maybe (Char, Text)
+textHead t = case X.null t of
+ True -> Nothing
+ False -> Just (X.head t, X.tail t)
+
+-- | Converts a Text to a TextNonEmpty. Returns Nothing if the Text is
+-- empty.
+toTextNonEmpty :: Text -> Maybe TextNonEmpty
+toTextNonEmpty t = case textHead t of
+ Nothing -> Nothing
+ (Just (c, r)) -> Just $ TextNonEmpty c r
+
+-- | 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 s = ParseSt { pendingShort :: Maybe TextNonEmpty
+ , remaining :: [Text]
+ , sawStopper :: Bool
+ , userState :: s
+ , counter :: Int
+ } deriving (Show, Eq)
+
+-- | Load up the ParseSt with an initial user state and a list of
+-- commmand line arguments.
+defaultState :: s -> [Text] -> ParseSt s
+defaultState s ts = ParseSt { pendingShort = Nothing
+ , remaining = ts
+ , sawStopper = False
+ , userState = s
+ , counter = 0 }
+
+-- | Carries the result of each parse.
+data Result e a = Bad e | Good a
+
+-- | @ParserT s e m a@ is a parser with user state s, error type e,
+-- underlying monad m, and result type a. Internally the parser is a
+-- state monad which keeps track of what is remaining to be
+-- parsed. Since the parser has an internal state anyway, the user can
+-- add to this state (this is called the user state.) The parser
+-- ignores this user state so you can use it however you wish. If you
+-- do not need a user state, just make it the unit type ().
+--
+-- The parser also includes the notion of failure. Any parser can
+-- fail; a failed parser affects the behavior of combinators such as
+-- combine. The failure type should be a instance of
+-- System.Console.MultiArg.Error.Error. This allows you to define your
+-- own type and use it for the failure type, which can be useful when
+-- combining MultiArg with your own program.
+--
+-- The underlying monad is m. This makes ParserT into a monad
+-- transformer; you can layer it on top of other monads. For instance
+-- you might layer it on top of the IO monad so that your parser can
+-- perform IO (for example, by examining the disk to see if arguments
+-- that specify files are valid.) If you don't need a monad
+-- transformer, just layer ParserT on top of Identity.
+data ParserT s e m a =
+ ParserT { runParserT :: ParseSt s -> m (Result e a, ParseSt s) }
+
+instance (Monad m) => Functor (ParserT s e m) where
+ fmap = parserMap
+
+instance (Monad m) => Applicative (ParserT s e m) where
+ pure = good
+ (<*>) = apply
+
+instance (Monad m, E.Error e) => Monoid (ParserT s e m a) where
+ mempty = genericThrow
+ mappend = choice
+
+instance (Monad m, E.Error e) => Alternative (ParserT s e m) where
+ empty = genericThrow
+ (<|>) = choice
+ many = several
+
+instance (E.Error e, Monad m) => Monad (ParserT s e m) where
+ (>>=) = combine
+ return = good
+ fail = throwString
+
+instance (Monad m, E.Error e) => MonadPlus (ParserT s e m) where
+ mzero = genericThrow
+ mplus = choice
+
+instance MonadTrans (ParserT s e) where
+ lift = parserLift
+
+instance (MonadIO m, E.Error e) => MonadIO (ParserT s e m) where
+ liftIO = parserIO
+
+-- | @ParserSE s e a@ is a parser with user state s, error type e,
+-- underlying monad Identity, and result type a.
+type ParserSE s e a = ParserT s e Identity a
+
+-- | @ParserE e a@ is a parser with user state (), error type e,
+-- underlying monad Identity, and result type a.
+type ParserE e a = ParserT () e Identity a
+
+-- | @Parser a@ is a parser with user state (), error type
+-- SimpleError, underlying monad Identity, and result type a.
+type Parser a = ParserT () E.SimpleError Identity a
+
+-- | Runs a parser that has a user state and an underlying monad
+-- Identity.
+parseSE ::
+ s
+ -- ^ The initial user state
+
+ -> [Text]
+ -- ^ Command line arguments
+
+ -> ParserSE s e a
+ -- ^ Parser to run
+
+ -> (Exceptional e a, s)
+ -- ^ Success or failure, and the final user state
+
+parseSE s ts p =
+ let r = runIdentity (runParserT p (defaultState s ts))
+ (result, st') = r
+ in case result of
+ (Good g) -> (Success g, userState st')
+ (Bad e) -> (Exception e, userState st')
+
+-- | Runs a parser that has no user state and an underlying monad of
+-- Identity and is parameterized on the error type.
+parseE ::
+ [Text]
+ -- ^ Command line arguments to parse
+
+ -> ParserE e a
+ -- ^ Parser to run
+
+ -> Exceptional e a
+ -- ^ Success or failure
+
+parseE ts p =
+ let r = runIdentity (runParserT p (defaultState () ts))
+ (result, _) = r
+ in case result of
+ (Good g) -> Success g
+ (Bad e) -> Exception e
+
+-- | The simplest parser runner; has no user state, an underlying
+-- monad Identity, and error type SimpleError.
+parse :: [Text]
+ -- ^ Command line arguments to parse
+
+ -> Parser a
+ -- ^ Parser to run
+
+ -> Exceptional E.SimpleError a
+ -- ^ Successful result or an error
+parse = parseE
+
+-- | The most complex parser runner. Runs a parser with a user-defined
+-- state, error type, and underlying monad. Returns the final parse
+-- result and the final user state, inside of the underlying monad.
+parseT ::
+ (Monad m)
+ => s
+ -- ^ Initial user state
+
+ -> [Text]
+ -- ^ Command line arguments to parse
+
+ -> ParserT s e m a
+ -- ^ Parser to run
+
+ -> m (Exceptional e a, s)
+ -- ^ Success or failure and the final user state, inside of the
+ -- underlying monad
+
+parseT s ts p = runParserT p (defaultState s ts) >>= \r ->
+ let (result, st') = r
+ in case result of
+ (Good g) -> return (Success g, userState st')
+ (Bad e) -> return (Exception e, userState st')
+
+-- | Lifts a computation of the underlying monad into the ParserT
+-- monad. This provides the implementation for
+-- 'Control.Monad.Trans.Class.lift'.
+parserLift ::
+ Monad m
+ => m a
+ -> ParserT s e m a
+parserLift c = ParserT $ \s ->
+ c >>= \a -> return (Good a, s)
+
+-- | Lifts a computation from the IO monad into the ParserT
+-- monad. This provides the implementation for
+-- 'Control.Monad.IO.Class.liftIO'.
+parserIO ::
+ (MonadIO m, E.Error e)
+ => IO a
+ -> ParserT s e m a
+parserIO c = parserLift . liftIO $ c
+
+-- | Combines two parsers into a single parser. The second parser can
+-- optionally depend upon the result from the first parser.
+--
+-- This applies the first parser. If the first parser succeeds,
+-- combine then takes the result from the first parser, applies the
+-- function given to the result from the first parser, and then
+-- applies the resulting parser.
+--
+-- If the first parser fails, combine will not apply the second
+-- function but instead will bypass the second parser.
+--
+-- This provides the implementation for '>>=' in
+-- 'Control.Monad.Monad'.
+combine ::
+ (Monad m)
+ => ParserT s e m a
+ -> (a -> ParserT s e m b)
+ -> ParserT s e m b
+combine (ParserT l) f = ParserT $ \s ->
+ l s >>= \(r, s') ->
+ case r of
+ (Bad e) -> return (Bad e, s')
+ (Good g) ->
+ let (ParserT fr) = f g
+ in fr 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 ::
+ (Monad m)
+ => ParserT s e m a
+ -> ParserT s e m a
+lookAhead (ParserT p) = ParserT $ \s ->
+ p s >>= \(r, s') ->
+ return $ case r of
+ (Good g) -> (Good g, s)
+ (Bad e) -> (Bad e, s')
+
+-- | @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 ::
+ (Monad m)
+ => a
+ -> ParserT s e m a
+good a = ParserT $ \s ->
+ return (Good a, s)
+
+-- | @throwString 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 ::
+ (E.Error e, Monad m)
+ => String
+ -> ParserT s e m a
+throwString e = ParserT $ \s ->
+ return (Bad (E.parseErr E.ExpOtherFailure
+ (E.SawTextError (pack e))), 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 ::
+ (Monad m)
+ => (a -> b)
+ -> ParserT s e m a
+ -> ParserT s e m b
+parserMap f (ParserT l) = ParserT $ \s ->
+ l s >>= \r ->
+ let (result, st') = r
+ in case result of
+ (Good g) -> return (Good (f g), st')
+ (Bad e) -> return (Bad e, st')
+
+-- | 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 ::
+ (Monad m)
+ => ParserT s e m (a -> b)
+ -> ParserT s e m a
+ -> ParserT s e m b
+apply (ParserT x) (ParserT y) = ParserT $ \s ->
+ x s >>= \r ->
+ let (result, st') = r
+ in case result of
+ (Good f) -> y st' >>= \r' ->
+ let (result', st'') = r'
+ in case result' of
+ (Good a) -> return (Good (f a), st'')
+ (Bad e) -> return (Bad e, st'')
+ (Bad e) -> return (Bad e, st')
+
+-- | Fail with an unhelpful error message. Usually throw is more
+-- useful, but this is handy to implement some typeclass instances.
+genericThrow ::
+ (Monad m, E.Error e)
+ => ParserT s e m a
+genericThrow = throw (E.parseErr E.ExpOtherFailure E.SawOtherFailure)
+
+-- | throw e always fails without consuming any input and returns a
+-- failed parser with error state e.
+throw :: (Monad m) => e -> ParserT s e m a
+throw e = ParserT $ \s ->
+ return (Bad e, s)
+
+noConsumed :: ParseSt s -> ParseSt s -> Bool
+noConsumed old new = counter old >= counter new
+
+-- | Runs the first parser. If it fails without consuming any input,
+-- then runs the second parser. If the first parser succeeds, then
+-- returns the result of the first parser. If the first parser fails
+-- and consumes input, then returns the result of the first
+-- parser. This provides the implementation for
+-- '<|>' in 'Control.Applicative.Alternative'.
+choice ::
+ (Monad m)
+ => ParserT s e m a
+ -> ParserT s e m a
+ -> ParserT s e m a
+choice (ParserT l) (ParserT r) = ParserT $ \sOld ->
+ l sOld >>= \(a, s') ->
+ case a of
+ (Good g) -> return (Good g, s')
+ (Bad e) ->
+ if noConsumed sOld s'
+ then r sOld
+ else return (Bad e, s')
+
+-- | 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 changes
+-- the error using the function given.
+() ::
+ (Monad m)
+ => ParserT s e m a
+ -> e
+ -> ParserT s e m a
+() (ParserT l) e = ParserT $ \s ->
+ l s >>= \(r, s') ->
+ case r of
+ (Good g) -> return (Good g, s')
+ (Bad err) ->
+ if noConsumed s s'
+ then return (Bad e, s)
+ else return (Bad err, s')
+
+infix 0
+
+increment :: ParseSt s -> ParseSt s
+increment old = old { counter = succ . counter $ old }
+
+-- | 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; returns the short option parsed.
+pendingShortOpt ::
+ (Monad m, E.Error e)
+ => ShortOpt
+ -> ParserT s e m ShortOpt
+pendingShortOpt so = ParserT $ \s ->
+ let err saw = return (Bad (E.parseErr (E.ExpPendingShortOpt so) saw), s)
+ gd (res, newSt) = return (Good res, newSt)
+ in switch err gd $ do
+ when (sawStopper s) $ S.throw E.SawAlreadyStopper
+ (TextNonEmpty first rest) <-
+ maybe (S.throw E.SawNoPendingShorts) return (pendingShort s)
+ when (unShortOpt so /= first)
+ (S.throw $ E.SawWrongPendingShort first)
+ return (so, increment s { pendingShort = toTextNonEmpty rest })
+
+-- | Parses only non-pending short options. Fails without consuming
+-- any input if, in order:
+--
+-- * there are pending short options
+--
+-- * there has already been a stopper
+--
+-- * there are no arguments left to parse
+--
+-- * the next argument is an empty string
+--
+-- * the next argument does not begin with a dash
+--
+-- * the next argument is a single dash
+--
+-- * the next argument is a short option but it does not match
+-- the one given
+--
+-- * the next argument is a stopper
+--
+-- Otherwise, consumes the next argument, puts any remaining letters
+-- from the argument into a pending short, and removes the first word
+-- from remaining arguments to be parsed. Returns the short option
+-- parsed.
+nonPendingShortOpt ::
+ (E.Error e, Monad m)
+ => ShortOpt
+ -> ParserT s e m ShortOpt
+nonPendingShortOpt so = ParserT $ \s ->
+ let err saw =
+ return (Bad (E.parseErr (E.ExpNonPendingShortOpt so) saw), s)
+ gd (g, n) = return (Good g, n)
+ in switch err gd $ do
+ maybe (return ()) (S.throw . E.SawStillPendingShorts) (pendingShort s)
+ when (sawStopper s) (S.throw E.SawAlreadyStopper)
+ (a:as) <- case remaining s of
+ [] -> S.throw E.SawNoArgsLeft
+ x -> return x
+ (maybeDash, word) <- case textHead a of
+ Nothing -> S.throw E.SawEmptyArg
+ (Just w) -> return w
+ when (maybeDash /= '-') $ S.throw (E.SawNotShortArg a)
+ (letter, arg) <- case textHead word of
+ Nothing -> S.throw E.SawSingleDashArg
+ (Just w) -> return w
+ when (letter /= unShortOpt so) $ S.throw (E.SawWrongShortArg letter)
+ when (letter == '-') $ S.throw E.SawNewStopper
+ let s' = increment s { pendingShort = toTextNonEmpty arg
+ , remaining = as }
+ return (so, s')
+
+-- | 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
+-- 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
+-- argument. If there is an equal sign but there is nothing after it,
+-- returns @Just \"\"@ for the argument.
+--
+-- If you do not want your long option to have equal signs and
+-- GNU-style option arguments, wrap this parser in something that will
+-- fail if there is an option argument.
+--
+-- Fails without consuming any input if:
+--
+-- * there are pending short options
+--
+-- * a stopper has been parsed
+--
+-- * there are no arguments left on the command line
+--
+-- * the next argument on the command line does not begin with
+-- two dashes
+--
+-- * the next argument on the command line is @--@ (a stopper)
+--
+-- * 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 ::
+ (E.Error e, Monad m)
+ => LongOpt
+ -> ParserT s e m (LongOpt, Maybe Text)
+exactLongOpt lo = ParserT $ \s ->
+ let err saw = return (Bad (E.parseErr (E.ExpExactLong lo) saw), s)
+ gd (g, n) = return (Good g, n)
+ in switch err gd $ do
+ maybe (return ()) (S.throw . E.SawStillPendingShorts) (pendingShort s)
+ when (sawStopper s) (S.throw E.SawAlreadyStopper)
+ (x:xs) <- case remaining s of
+ [] -> S.throw E.SawNoArgsLeft
+ ls -> return ls
+ let (pre, word, afterEq) = splitLongWord x
+ when (pre /= pack "--") $ S.throw (E.SawNotLongArg x)
+ when (X.null word && isNothing afterEq) (S.throw E.SawNewStopper)
+ when (word /= unLongOpt lo) $ S.throw (E.SawWrongLongArg word)
+ let s' = increment s { remaining = xs }
+ return ((lo, afterEq), s')
+
+-- | Takes a single Text 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
+-- there is no equal sign, or Just Text with everything after the
+-- equal sign if there is one.
+splitLongWord :: Text -> (Text, Text, Maybe Text)
+splitLongWord t = (f, s, r) where
+ (f, rest) = X.splitAt 2 t
+ (s, withEq) = X.break (== '=') rest
+ r = case textHead withEq of
+ Nothing -> Nothing
+ (Just (_, afterEq)) -> Just afterEq
+
+-- | Examines the next word. If it matches a Text in the set
+-- unambiguously, returns a tuple of the word actually found and the
+-- matching word in the set.
+approxLongOpt ::
+ (E.Error e, Monad m)
+ => Set LongOpt
+ -> ParserT s e m (Text, LongOpt, Maybe Text)
+approxLongOpt ts = ParserT $ \s ->
+ let err saw = return (Bad (E.parseErr (E.ExpApproxLong ts) saw), s)
+ gd (g, newSt) = return (Good g, newSt)
+ in switch err gd $ do
+ maybe (return ()) (S.throw . E.SawStillPendingShorts) (pendingShort s)
+ (x:xs) <- case remaining s of
+ [] -> S.throw E.SawNoArgsLeft
+ r -> return r
+ let (pre, word, afterEq) = splitLongWord x
+ when (pre /= pack "--") (S.throw (E.SawNotLongArg x))
+ when (X.null word && isNothing afterEq) (S.throw E.SawNewStopper)
+ let p t = word `isPrefixOf` (unLongOpt t)
+ matches = Set.filter p ts
+ case Set.toList matches of
+ [] -> S.throw (E.SawNoMatches word)
+ (m:[]) -> let s' = increment s { remaining = xs }
+ in return ((word, m, afterEq), s')
+ _ -> S.throw (E.SawMultipleMatches matches word)
+
+-- | 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
+-- because it was in the same command line argument as the @-c@.
+--
+-- Fails without consuming any input if:
+--
+-- * a stopper has already been parsed
+--
+-- * there are no pending short option arguments
+--
+-- On success, returns the text of the pending short option argument
+-- (this text cannot be empty).
+pendingShortOptArg ::
+ (E.Error e, Monad m)
+ => ParserT s e m Text
+pendingShortOptArg = ParserT $ \s ->
+ let err saw = return (Bad (E.parseErr E.ExpPendingShortArg saw), s)
+ gd (g, newSt) = return (Good g, newSt)
+ in switch err gd $ do
+ when (sawStopper s) (S.throw E.SawAlreadyStopper)
+ let f (TextNonEmpty c t) = return (c `cons` t)
+ a <- maybe (S.throw E.SawNoPendingShortArg) f (pendingShort s)
+ let newSt = increment s { pendingShort = Nothing }
+ return (a, newSt)
+
+-- | Parses a "stopper" - that is, a double dash. Changes the internal
+-- state of the parser to reflect that a stopper has been seen.
+stopper ::
+ (E.Error e, Monad m)
+ => ParserT s e m ()
+stopper = ParserT $ \s ->
+ let err saw = return (Bad (E.parseErr E.ExpStopper saw), s)
+ gd (g, newSt) = return (Good g, newSt)
+ in switch err gd $ do
+ maybe (return ()) (S.throw . E.SawStillPendingShorts) (pendingShort s)
+ when (sawStopper s) $ S.throw E.SawAlreadyStopper
+ (x:xs) <- case remaining s of
+ [] -> S.throw E.SawNoArgsLeft
+ r -> return r
+ when (not $ pack "--" `isPrefixOf` x) (S.throw E.SawNotStopper)
+ when (X.length x /= 2) (S.throw E.SawNotStopper)
+ let s' = increment s { sawStopper = True
+ , remaining = xs }
+ return ((), s')
+
+-- | try p behaves just like p, but if p fails, try p will not consume
+-- any input.
+try :: Monad m => ParserT s e m a -> ParserT s e m a
+try (ParserT l) = ParserT $ \s ->
+ l s >>= \(r, s') ->
+ case r of
+ (Good g) -> return (Good g, s')
+ (Bad e) -> return (Bad e, s)
+
+-- | 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 ::
+ (E.Error e, Monad m)
+ => ParserT s e m Text
+nextArg = ParserT $ \s ->
+ let err saw = return (Bad (E.parseErr E.ExpNextArg saw), s)
+ gd (g, newSt) = return (Good g, newSt)
+ in switch err gd $ do
+ maybe (return ()) (S.throw . E.SawStillPendingShorts) (pendingShort s)
+ (x:xs) <- case remaining s of
+ [] -> S.throw E.SawNoArgsLeft
+ r -> return r
+ let newSt = increment s { remaining = xs }
+ return (x, newSt)
+
+-- | Returns the next string on the command line as long as there are
+-- no pendings and as long as the next string does not begin with a
+-- dash. If there has already been a stopper, then will return the
+-- next string even if it starts with a dash.
+nonOptionPosArg ::
+ (E.Error e, Monad m)
+ => ParserT s e m Text
+nonOptionPosArg = ParserT $ \s ->
+ let err saw = return (Bad (E.parseErr E.ExpNonOptionPosArg saw), s)
+ gd (g, newSt) = return (Good g, newSt)
+ in switch err gd $ do
+ maybe (return ()) (S.throw . E.SawStillPendingShorts) (pendingShort s)
+ (x:xs) <- case remaining s of
+ [] -> S.throw E.SawNoArgsLeft
+ r -> return r
+ result <- if sawStopper s
+ then return x
+ else case textHead x of
+ Just ('-', _) -> S.throw $ E.SawLeadingDashArg x
+ _ -> return x
+ let newSt = increment s { remaining = xs }
+ return (result, newSt)
+
+-- | 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 ::
+ Monad m
+ => ParserT s e m a
+ -> ParserT s e m end
+ -> ParserT s e m [a]
+manyTill (ParserT r) (ParserT f) = ParserT $ \s ->
+ parseTill s r f >>= \till ->
+ case lastFailure till of
+ Nothing -> return (Good (goods till), lastSt till)
+ (Just e) -> return (Bad e, lastSt till)
+
+data Till s e a =
+ Till { goods :: [a]
+ , lastSt :: ParseSt s
+ , lastFailure :: Maybe e }
+
+parseTill ::
+ (Monad m)
+ => ParseSt s
+ -> (ParseSt s -> m (Result e a, ParseSt s))
+ -> (ParseSt s -> m (Result e b, ParseSt s))
+ -> m (Till s e a)
+parseTill s fr ff = ff s >>= \r ->
+ case r of
+ (Good _, s') -> return $ Till [] s' Nothing
+ (Bad _, _) ->
+ fr s >>= \r' ->
+ case r' of
+ (Bad e, s') -> return $ Till [] s' (Just e)
+ (Good g, s') ->
+ parseTill s' fr ff >>= \r'' ->
+ let (Till gs lS lF) = r''
+ in if counter s' == counter s
+ then error "parseTill applied to parser that takes empty list"
+ else return $ Till (g:gs) lS lF
+
+-- | 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.
+several ::
+ (Monad m)
+ => ParserT s e m a
+ -> ParserT s e m [a]
+several (ParserT l) = ParserT $ \s ->
+ parseRepeat s l >>= \r ->
+ let (result, finalGoodSt, failure, finalBadSt) = r
+ in if noConsumed finalGoodSt finalBadSt
+ then return (Good result, finalGoodSt)
+ else return (Bad failure, finalBadSt)
+
+parseRepeat ::
+ (Monad m)
+ => ParseSt s
+ -> (ParseSt s -> m (Result e a, ParseSt s))
+ -> m ([a], ParseSt s, e, ParseSt s)
+parseRepeat st1 f = f st1 >>= \r ->
+ case r of
+ (Good a, st') ->
+ if noConsumed st1 st'
+ then error "parseRepeat applied to parser that takes empty list"
+ else parseRepeat st' f >>= \r' ->
+ let (ls, finalGoodSt, failure, finalBadSt) = r'
+ in return (a : ls, finalGoodSt, failure, finalBadSt)
+ (Bad e, st') -> return ([], st1, e, st')
+
+-- | Succeeds if there is no more input left.
+end ::
+ (E.Error e, Monad m)
+ => ParserT s e m ()
+end = ParserT $ \s ->
+ let err saw = return (Bad (E.parseErr E.ExpEnd saw), s)
+ gd (g, newSt) = return (Good g, newSt)
+ in switch err gd $ do
+ maybe (return ()) (S.throw . E.SawStillPendingShorts) (pendingShort s)
+ when (not . null . remaining $ s) (S.throw E.SawMoreInput)
+ return ((), s)
+
+-- | Gets the user state.
+get ::
+ (Monad m)
+ => ParserT s e m s
+get = ParserT $ \s ->
+ return (Good (userState s), s)
+
+-- | Puts a new user state.
+put ::
+ (Monad m)
+ => s
+ -> ParserT s e m ()
+put newUserSt = ParserT $ \s ->
+ return (Good (), s { userState = newUserSt })
+
+-- | Modify the user state.
+modify ::
+ (Monad m)
+ => (s -> s)
+ -> ParserT s e m ()
+modify f = ParserT $ \s ->
+ return (Good (), s { userState = f (userState s) })
diff --git a/System/Console/MultiArg/QuickCheckHelpers.hs b/System/Console/MultiArg/QuickCheckHelpers.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/QuickCheckHelpers.hs
@@ -0,0 +1,24 @@
+module System.Console.MultiArg.QuickCheckHelpers where
+
+import Test.QuickCheck ( Arbitrary ( arbitrary ),
+ Gen,
+ CoArbitrary ( coarbitrary ),
+ coarbitraryShow )
+import Data.Text ( Text, pack )
+import qualified Data.Set as Set
+import Control.Monad ( liftM )
+
+randText :: Gen Text
+randText = liftM pack arbitrary
+
+randSet :: (Ord a, Arbitrary a) => Gen (Set.Set a)
+randSet = liftM Set.fromList arbitrary
+
+newtype WText = WText { unWText :: Text }
+ deriving Show
+
+instance Arbitrary WText where
+ arbitrary = liftM WText randText
+
+instance CoArbitrary WText where
+ coarbitrary (WText a) gc = coarbitraryShow a gc
diff --git a/System/Console/MultiArg/SampleParser.hs b/System/Console/MultiArg/SampleParser.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/SampleParser.hs
@@ -0,0 +1,30 @@
+-- | This is sample code using "System.Console.MultiArg". This could
+-- be a command-line parser for the version of the Unix command @tail@
+-- that is included with GNU coreutils version 8.5. "main" simply gets
+-- the command line arguments, parses them, and prints out what was
+-- parsed. To test it out, there is a @sample.hs@ file in the
+-- @binaries@ directory of the multiarg archive that you can compile.
+module System.Console.MultiArg.SampleParser where
+
+import System.Console.MultiArg
+
+specs :: [OptSpec]
+
+specs = [ OptSpec "bytes" "c" [] oneArg
+ , OptSpec "follow" "f" [] optionalArg
+ , OptSpec "follow-retry" "F" [] noArg
+ , OptSpec "lines" "n" [] oneArg
+ , OptSpec "max-unchanged-stats" "" [] oneArg
+ , OptSpec "pid" "" [] oneArg
+ , OptSpec "quiet" "q" ["silent"] noArg
+ , OptSpec "sleep-interval" "s" [] oneArg
+ , OptSpec "verbose" "v" [] noArg
+ , OptSpec "help" "" [] noArg
+ , OptSpec "version" "" [] noArg
+ ]
+
+sampleMain :: IO ()
+sampleMain = do
+ as <- getArgs
+ let r = parse Intersperse specs as
+ print r
diff --git a/System/Console/MultiArg/SimpleParser.hs b/System/Console/MultiArg/SimpleParser.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/SimpleParser.hs
@@ -0,0 +1,255 @@
+-- | 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
+-- 'System.Console.MultiArg.SampleParser'.
+module System.Console.MultiArg.SimpleParser (
+ OptSpec(..),
+ Intersperse(..),
+ Result(..),
+ Args(..),
+ noArg,
+ optionalArg,
+ oneArg,
+ twoArg,
+ variableArg,
+ SimpleError,
+ getArgs,
+ System.Console.MultiArg.SimpleParser.parse ) where
+
+import System.Console.MultiArg.Prim (
+ Parser, manyTill, lookAhead, nextArg, nonOptionPosArg,
+ end, (), stopper, nonOptionPosArg, try )
+import qualified System.Console.MultiArg.Prim as Prim
+import System.Console.MultiArg.Combinator (
+ mixedNoArg, mixedOptionalArg, mixedOneArg, mixedTwoArg,
+ mixedVariableArg )
+import System.Console.MultiArg.Option (
+ makeLongOpt, makeShortOpt )
+import Control.Monad.Exception.Synchronous ( toEither )
+import System.Console.MultiArg.Error ( SimpleError )
+import Data.Text ( pack, unpack )
+import System.Environment ( getArgs )
+import Data.Monoid ( mconcat )
+import Control.Applicative ( many, (<|>) )
+
+-- | Specifies each option that your program accepts.
+data OptSpec = OptSpec {
+ longOpt :: String
+ -- ^ Each option must have at least one long option, which you
+ -- specify here. Your program's users specify long options by
+ -- preceding them with two dashes, such as @--verbose@. When writing
+ -- your code you omit the dashes, so you would specify @verbose@
+ -- here; including the dashes in your code results in a runtime
+ -- error.
+
+ , shortOpts :: [Char]
+ -- ^ Additional, synonymous short options may be specified
+ -- here. For instance if you want your users to be able to specify
+ -- @-v@ in addition to @--verbose@, include @v@ in this list.
+
+ , longOpts :: [String]
+ -- ^ Additional synonymous long options may be specified here. For
+ -- instance, if you specified @quiet@ for @longOpt@, you might
+ -- want to include @silent@ in this list.
+
+ , argSpec :: Args
+ -- ^ Specifies what arguments, if any, this option takes.
+ }
+ deriving Show
+
+-- | This datatype does dual duty. When part of an 'OptSpec', you use
+-- it to specify how many arguments, if any, an option takes. When you
+-- use it for this purpose, it only matters which data constructor you
+-- use; the fields can be any value, even 'undefined'.
+--
+-- When part of a Result, 'Args' indicates what arguments the user
+-- supplied to the option.
+data Args =
+ NoArg
+ -- ^ This option takes no arguments
+
+ | OptionalArg { oArg :: Maybe String }
+
+ -- ^ This option takes an optional argument. As noted in \"The Tao
+ -- of Option Parsing\", optional arguments can result in some
+ -- ambiguity. (Read it here:
+ -- ) If option @a@
+ -- takes an optional argument, and @b@ is also an option, what
+ -- does @-ab@ mean? SimpleParser resolves this ambiguity by
+ -- assuming that @b@ is an argument to @a@. If the user does not
+ -- like this, she can specify @-a -b@ (in such an instance @-b@ is
+ -- not parsed as an option to @-a@, because @-b@ begins with a
+ -- hyphen and therefore \"looks like\" an option.) Certainly
+ -- though, optional arguments lead to ambiguity, so if you don't
+ -- like it, don't use them :)
+
+ | OneArg { sArg1 :: String }
+ -- ^ This option takes one argument. Here, if option @a@ takes one
+ -- argument, @-a -b@ will be parsed with @-b@ being an argument to
+ -- option @a@, even though @-b@ starts with a hyphen and therefore
+ -- \"looks like\" an option.
+
+ | TwoArg { tArg1 :: String
+ , tArg2 :: String }
+ -- ^ This option takes two arguments. Parsed similarly to 'OneArg'.
+
+ | VariableArg { vArgs :: [String] }
+ -- ^ This option takes a variable number of arguments--zero or
+ -- more. Option arguments continue until the command line contains
+ -- a word that begins with a hyphen. For example, if option @a@
+ -- takes a variable number of arguments, then @-a one two three
+ -- -b@ will be parsed as @a@ taking three arguments, and @-a -b@
+ -- will be parsed as @a@ taking no arguments. If the user enters
+ -- @-a@ as the last option on the command line, then the only way
+ -- to indicate the end of arguments for @a@ and the beginning of
+ -- positional argments is with a stopper.
+
+ deriving Show
+
+-- | Specify that this option takes no arguments.
+noArg :: Args
+noArg = NoArg
+
+-- | Specify that this option takes an optional argument.
+optionalArg :: Args
+optionalArg = OptionalArg Nothing
+
+-- | Specify that this option takes one argument.
+oneArg :: Args
+oneArg = OneArg ""
+
+-- | Specify that this option takes two arguments.
+twoArg :: Args
+twoArg = TwoArg "" ""
+
+-- | Specify that this option takes a variable number of arguments.
+variableArg :: Args
+variableArg = VariableArg []
+
+-- | Holds the result of command line parsing. Each option (along with
+-- its option arguments) or positional argument is assigned to its own
+-- Result.
+data Result =
+ PosArg { posArg :: String }
+ | Stopper
+ | Option {
+ label :: String
+ -- ^ Each option must have at least one long option. So that you
+ -- can distinguish one option from another, the name of that long
+ -- option is returned here.
+ , args :: Args }
+ deriving Show
+
+-- | 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.
+data Intersperse =
+ Intersperse
+ -- ^ Additional options are allowed on the command line after
+ -- encountering the first positional argument. For example, if @a@
+ -- and @b@ are options, in the command line @-a posarg -b@, @b@ will
+ -- be parsed as an option. If @b@ is /not/ an option and the same
+ -- command line is entered, then @-b@ will result in an error
+ -- because @-b@ starts with a hyphen and therefore \"looks like\" an
+ -- option.
+
+ | StopOptions
+ -- ^ No additional options will be parsed after encountering the
+ -- first positional argument. For example, if @a@ and @b@ are
+ -- options, in the command line @-a posarg -b@, @b@ will be parsed
+ -- as a positional argument rather than as an option.
+
+-- | Parse a command line.
+parse ::
+ Intersperse
+ -> [OptSpec]
+ -> [String]
+ -- ^ The command line to parse. This function correctly handles
+ -- Unicode strings; however, because 'System.Environment.getArgs'
+ -- does not always correctly handle Unicode strings, consult the
+ -- documentation in 'System.Console.MultiArg.GetArgs' and consider
+ -- using the functions in there if there is any chance that you will
+ -- be parsing command lines that have non-ASCII strings.
+
+ -> Either SimpleError [Result]
+parse i os ss = toEither $ Prim.parse (map pack ss) (f os) where
+ f = case i of Intersperse -> parseIntersperse
+ StopOptions -> parseNoIntersperse
+
+parseNoIntersperse :: [OptSpec] -> Parser [Result]
+parseNoIntersperse os = do
+ let opts = mconcat . map optSpec $ os
+ rs <- manyTill opts (try $ lookAhead afterArgs)
+ firstArg <- afterArgs
+ case firstArg of
+ EndOfInput -> return rs
+ (FirstArg s) -> do
+ as <- noIntersperseArgs
+ let first = PosArg s
+ return $ rs ++ ( first : as )
+ AAStopper -> do
+ as <- noIntersperseArgs
+ let first = Stopper
+ return $ rs ++ ( first : as )
+
+noIntersperseArgs :: Parser [Result]
+noIntersperseArgs = do
+ as <- many nextArg
+ let r = map PosArg . map unpack $ as
+ return r
+
+data AfterArgs = EndOfInput | FirstArg String | AAStopper
+
+afterArgs :: Parser AfterArgs
+afterArgs = parseFirst <|> parseEnd <|> parseStopper where
+ parseFirst = do
+ a <- nonOptionPosArg
+ let aS = unpack a
+ return $ FirstArg aS
+ parseEnd = do
+ end
+ return EndOfInput
+ parseStopper = do
+ _ <- stopperParser
+ return AAStopper
+
+parseIntersperse :: [OptSpec] -> Parser [Result]
+parseIntersperse os = do
+ let optsAndStopper = foldl1 (<|>) $ optSpecs ++ rest
+ rest = [stopperParser, posArgParser]
+ optSpecs = map optSpec os
+ rs <- manyTill optsAndStopper end
+ end error "the end parser should always succeed"
+ return rs
+
+stopperParser :: Parser Result
+stopperParser = stopper >> return Stopper
+
+posArgParser :: Parser Result
+posArgParser = do
+ a <- nonOptionPosArg
+ return $ PosArg (unpack a)
+
+optSpec :: OptSpec -> Parser Result
+optSpec o = let
+ lo = makeLongOpt . pack . longOpt $ o
+ ss = map makeShortOpt . shortOpts $ o
+ ls = map makeLongOpt . map pack . longOpts $ o
+ opt = return . Option (longOpt o)
+ in case argSpec o of
+ NoArg -> do
+ _ <- mixedNoArg lo ls ss
+ opt NoArg
+ (OptionalArg {}) -> do
+ (_, a) <- mixedOptionalArg lo ls ss
+ opt (OptionalArg . fmap unpack $ a)
+ (OneArg {}) -> do
+ (_, a) <- mixedOneArg lo ls ss
+ opt (OneArg . unpack $ a)
+ (TwoArg {}) -> do
+ (_, a1, a2) <- mixedTwoArg lo ls ss
+ opt (TwoArg (unpack a1) (unpack a2))
+ (VariableArg {}) -> do
+ (_, as) <- mixedVariableArg lo ls ss
+ opt (VariableArg . map unpack $ as)
+
diff --git a/System/Console/MultiArg/TextNonEmpty.hs b/System/Console/MultiArg/TextNonEmpty.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/TextNonEmpty.hs
@@ -0,0 +1,23 @@
+module System.Console.MultiArg.TextNonEmpty where
+
+import Test.QuickCheck
+ ( Arbitrary ( arbitrary ), CoArbitrary ( coarbitrary ),
+ (><) )
+import System.Console.MultiArg.QuickCheckHelpers
+ ( randText, WText(WText) )
+
+import Data.Text ( Text )
+
+data TextNonEmpty = TextNonEmpty Char Text
+ deriving (Show, Eq)
+
+instance Arbitrary TextNonEmpty where
+ arbitrary = do
+ c <- arbitrary
+ t <- randText
+ return $ TextNonEmpty c t
+
+instance CoArbitrary TextNonEmpty where
+ coarbitrary (TextNonEmpty c t) = vc >< vt where
+ vc = coarbitrary c
+ vt = coarbitrary (WText t)
diff --git a/binaries/sample.hs b/binaries/sample.hs
new file mode 100644
--- /dev/null
+++ b/binaries/sample.hs
@@ -0,0 +1,4 @@
+import System.Console.MultiArg.SampleParser
+
+main :: IO ()
+main = sampleMain
diff --git a/multiarg.cabal b/multiarg.cabal
new file mode 100644
--- /dev/null
+++ b/multiarg.cabal
@@ -0,0 +1,72 @@
+Name: multiarg
+Version: 0.1.0.0
+Cabal-version: >=1.8
+Build-Type: Simple
+License: MIT
+Copyright: 2011-2012 Omari Norman.
+author: Omari Norman
+maintainer: omari@smileystation.com
+stability: Experimental
+homepage: https://github.com/massysett/multiarg
+bug-reports: omari@smileystation.com
+Category: Console, Parsing
+License-File: LICENSE
+synopsis: Combinators to build command line parsers
+extra-source-files:
+ binaries/sample.hs
+
+description: multiarg is a parser combinator library to build command
+ line parsers. With it you can easily create parsers with options
+ that take more than one option argument--for example, I created
+ multiarg due to the apparent lack of such ability amongst other
+ parsers. Its basic design is loosely inspired by Parsec.
+ .
+ Provides ParserT, a monad you use to build parsers. ParserT is a monad
+ transformer, so you can layer it on top of other monads. For instance
+ you could layer it on the IO monad so that your parser can perform IO.
+ .
+ It also has a simple, pre-built parser built with the underlying
+ combinators, which works for many situtations and shields you from the
+ underlying complexity if you don't need it.
+ .
+ See the documentation in the System.Console.MultiArg module for
+ details.
+
+Flag newbase
+ Description: Builds package with base >= 4.4.0.0.
+
+source-repository head
+ type: git
+ location: git://github.com/massysett/multiarg.git
+
+Library
+ Build-depends:
+ base ==4.*,
+ text ==0.11.*,
+ explicit-exception ==0.1.*,
+ containers ==0.4.*,
+ QuickCheck ==2.4.*,
+ transformers == 0.2.*
+
+ -- See documentation in System.Console.MultiArg.GetArgs for details
+ if flag(newbase)
+ Build-depends:
+ base >= 4.4 && < 5
+ else
+ Build-depends:
+ base < 4.4,
+ utf8-string == 0.3.7
+
+ Exposed-modules:
+ System.Console.MultiArg,
+ System.Console.MultiArg.Combinator,
+ System.Console.MultiArg.Error,
+ System.Console.MultiArg.GetArgs,
+ System.Console.MultiArg.Option,
+ System.Console.MultiArg.Prim,
+ System.Console.MultiArg.QuickCheckHelpers,
+ System.Console.MultiArg.SampleParser,
+ System.Console.MultiArg.SimpleParser,
+ System.Console.MultiArg.TextNonEmpty
+
+ ghc-options: -Wall