diff --git a/NEWS b/NEWS
new file mode 100644
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,14 @@
+Release 0.2.0.0, April 2, 2012
+Changes since release 0.1.0.0:
+
+* Henceforth all public releases will have only even numbers in their
+ release numbers (e.g. 0.2.0.0, 0.2.0.2, etc.) If a release has any
+ odd numbers in its version, it is a development release.
+
+* QuickCheck tests are removed. Eventually I will reimplement these in
+ a separate library package.
+
+* Added Feed function to System.Console.MultiArg.Prim; this allows you
+ to carry out stateful parses without using a user state. Sometimes
+ this aids in composability--for instance, I use it when combining
+ parsers from different parts of the same program.
diff --git a/System/Console/MultiArg.hs b/System/Console/MultiArg.hs
deleted file mode 100644
--- a/System/Console/MultiArg.hs
+++ /dev/null
@@ -1,169 +0,0 @@
--- | 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
deleted file mode 100644
--- a/System/Console/MultiArg/Combinator.hs
+++ /dev/null
@@ -1,364 +0,0 @@
--- | 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
deleted file mode 100644
--- a/System/Console/MultiArg/Error.hs
+++ /dev/null
@@ -1,274 +0,0 @@
--- | 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
deleted file mode 100644
--- a/System/Console/MultiArg/GetArgs.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/System/Console/MultiArg/Option.hs
+++ /dev/null
@@ -1,72 +0,0 @@
--- | 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
deleted file mode 100644
--- a/System/Console/MultiArg/Prim.hs
+++ /dev/null
@@ -1,847 +0,0 @@
--- | 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
deleted file mode 100644
--- a/System/Console/MultiArg/QuickCheckHelpers.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-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
deleted file mode 100644
--- a/System/Console/MultiArg/SampleParser.hs
+++ /dev/null
@@ -1,30 +0,0 @@
--- | 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
deleted file mode 100644
--- a/System/Console/MultiArg/SimpleParser.hs
+++ /dev/null
@@ -1,255 +0,0 @@
--- | 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
deleted file mode 100644
--- a/System/Console/MultiArg/TextNonEmpty.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-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
deleted file mode 100644
--- a/binaries/sample.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-import System.Console.MultiArg.SampleParser
-
-main :: IO ()
-main = sampleMain
diff --git a/doc/sample.hs b/doc/sample.hs
new file mode 100644
--- /dev/null
+++ b/doc/sample.hs
@@ -0,0 +1,4 @@
+import System.Console.MultiArg.SampleParser
+
+main :: IO ()
+main = sampleMain
diff --git a/lib/System/Console/MultiArg.hs b/lib/System/Console/MultiArg.hs
new file mode 100644
--- /dev/null
+++ b/lib/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/lib/System/Console/MultiArg/Combinator.hs b/lib/System/Console/MultiArg/Combinator.hs
new file mode 100644
--- /dev/null
+++ b/lib/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/lib/System/Console/MultiArg/Error.hs b/lib/System/Console/MultiArg/Error.hs
new file mode 100644
--- /dev/null
+++ b/lib/System/Console/MultiArg/Error.hs
@@ -0,0 +1,215 @@
+-- | 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
+
+-- | 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
+
+instance Error Text where
+ parseErr e s =
+ pack "command line parser error.\n"
+ `append` pack "expecting: " `append` printExpecting e
+ `snoc` '\n'
+ `append` pack "saw: " `append` printSaw s
+ `snoc` '\n'
+
+-- | 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
+
+-- | 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"
+
+
+
+-- | 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"
+
diff --git a/lib/System/Console/MultiArg/GetArgs.hs b/lib/System/Console/MultiArg/GetArgs.hs
new file mode 100644
--- /dev/null
+++ b/lib/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/lib/System/Console/MultiArg/Option.hs b/lib/System/Console/MultiArg/Option.hs
new file mode 100644
--- /dev/null
+++ b/lib/System/Console/MultiArg/Option.hs
@@ -0,0 +1,61 @@
+-- | 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 qualified Data.Text as X
+import Data.Text ( Text, unpack, index )
+import Control.Monad ( when )
+
+-- | 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)
+
+-- | 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)
+
+-- | 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/lib/System/Console/MultiArg/Prim.hs b/lib/System/Console/MultiArg/Prim.hs
new file mode 100644
--- /dev/null
+++ b/lib/System/Console/MultiArg/Prim.hs
@@ -0,0 +1,962 @@
+-- | 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,
+ feed,
+
+ -- ** 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
+
+-- It is impossible to implement several and manyTill in terms of
+-- feed, as there is no easy way to specify what the starting value of
+-- the state for feed would be.
+
+-- | 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 ::
+ (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 $ "several applied to parser that succeeds without"
+ ++ " consuming any input"
+ 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')
+
+-- | feed runs in a recursive loop. Each loop starts with three
+-- variables: a function @f@ that takes an input @i@ and returns a
+-- parser @p@, a function @g@ that takes an input @i@ and returns a
+-- parser @e@ that must succeed for the recursion to end, and an
+-- initial input @i@. This proceeds as follows:
+--
+-- 1. Apply @g@ to @i@ and run resulting parser @e@. If this parser
+-- succeeds, feed succeeds and returns a list of all successful runs
+-- of @p@. The result of @e@ is not returned, but otherwise the parser
+-- returned reflects the updated internal parser state from the
+-- running of @e@. (If that is a problem, wrap @e@ in 'lookAhead'.) If
+-- @e@ fails and consumes input, feed fails and returns a failed
+-- parser whose internal state reflects the state after @e@ fails. If
+-- @e@ fails without consuming any input, proceed with the following
+-- steps.
+--
+-- 2. Apply function @f@ to input @i@, yielding a parser @p@. Run
+-- parser @p@. If @p@ fails, feed also fails. If @p@ succeeds, it
+-- yields a new input, @i'@.
+--
+-- 3. If @p@ succeeded without consuming any input, an infinite loop
+-- will result, so apply @error@.
+--
+-- 4. Repeat from step 1, but with the new input retured from @p@,
+-- @i'@.
+--
+-- For the initial application of feed, you supply the function @f@,
+-- the end parser @e@, and the initial state @i@.
+--
+-- This function is useful for running multiple times a parser that
+-- depends on the result of previous runs of the parser. You could
+-- implement something similar using the user state feature, but for
+-- various reasons sometimes it is more useful to use 'feed' instead.
+
+feed ::
+ Monad m
+ => (a -> ParserT s e m a)
+ -> (a -> ParserT s e m end)
+ -> a
+ -> ParserT s e m [a]
+feed f e i = ParserT $ \s ->
+ feedRecurse s f e i >>= \(s', lf) ->
+ let res = case lf of
+ EndFailure err -> Bad err
+ RepeatFailure err -> Bad err
+ RepeatSuccess ls -> Good ls
+ in return (res, s')
+
+data LastFeed e a =
+ EndFailure e
+ -- ^ The last run of the end parser failed and consumed input.
+
+ | RepeatFailure e
+ -- ^ The last run of the repetitive parser failed (whether or not
+ -- it consumed any input).
+
+ | RepeatSuccess [a]
+ -- ^ The last run of the repetitive parser succeeded; here are all
+ -- the results.
+
+-- | Takes an initial state, a function @f@ that returns a parser @p@
+-- to run repetitively, a parser @e@ that must succeed to stop the
+-- recursion, and an input for @f@. Returns: @m (s, ei)@, where:
+--
+-- * @m@ is the inner monad
+--
+-- * @s@ is the state after the last application of either @e@ or @p@.
+--
+-- * @lf@ is a 'LastFeed' (see above).
+feedRecurse ::
+ Monad m
+ => ParseSt s
+ -> (a -> ParserT s e m a)
+ -> (a -> ParserT s e m end)
+ -> a
+ -> m (ParseSt s, LastFeed e a)
+feedRecurse st f fe i =
+ runParserT (fe i) st >>= \(eResult, eSt) ->
+ case eResult of
+ Good _ -> return (eSt, RepeatSuccess [])
+ Bad b ->
+ if noConsumed st eSt
+ then
+ runParserT (f i) st >>= \(pResult, pSt) ->
+ case pResult of
+ Good g ->
+ if noConsumed st pSt
+ then feedRecurseError
+ else
+ feedRecurse pSt f fe g >>= \(recSt, lf) ->
+ let res = case lf of
+ RepeatSuccess ls -> RepeatSuccess (g:ls)
+ failed -> failed
+ in return (recSt, res)
+ Bad badRepeat -> return (pSt, RepeatFailure badRepeat)
+ else
+ return (eSt, EndFailure b)
+
+feedRecurseError :: a
+feedRecurseError =
+ error $ "feedRecurse applied to parser that succeeds without"
+ ++ " consuming any input"
+
+
+-- | 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/lib/System/Console/MultiArg/SampleParser.hs b/lib/System/Console/MultiArg/SampleParser.hs
new file mode 100644
--- /dev/null
+++ b/lib/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/lib/System/Console/MultiArg/SimpleParser.hs b/lib/System/Console/MultiArg/SimpleParser.hs
new file mode 100644
--- /dev/null
+++ b/lib/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/lib/System/Console/MultiArg/TextNonEmpty.hs b/lib/System/Console/MultiArg/TextNonEmpty.hs
new file mode 100644
--- /dev/null
+++ b/lib/System/Console/MultiArg/TextNonEmpty.hs
@@ -0,0 +1,6 @@
+module System.Console.MultiArg.TextNonEmpty where
+
+import Data.Text ( Text )
+
+data TextNonEmpty = TextNonEmpty Char Text
+ deriving (Show, Eq)
diff --git a/multiarg.cabal b/multiarg.cabal
--- a/multiarg.cabal
+++ b/multiarg.cabal
@@ -1,5 +1,5 @@
Name: multiarg
-Version: 0.1.0.0
+Version: 0.2.0.0
Cabal-version: >=1.8
Build-Type: Simple
License: MIT
@@ -13,7 +13,7 @@
License-File: LICENSE
synopsis: Combinators to build command line parsers
extra-source-files:
- binaries/sample.hs
+ doc/sample.hs, NEWS
description: multiarg is a parser combinator library to build command
line parsers. With it you can easily create parsers with options
@@ -40,12 +40,13 @@
location: git://github.com/massysett/multiarg.git
Library
+ hs-source-dirs: lib
+
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
@@ -64,7 +65,6 @@
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