diff --git a/NEWS b/NEWS
--- a/NEWS
+++ b/NEWS
@@ -12,3 +12,21 @@
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.
+
+Release 0.4.0.0, June 30, 2012
+Changes since release 0.2.0.0:
+
+* Code written for version 0.2.* will not work at all with this
+ version.
+
+* Removed dependency on text library. multiarg now only deals with
+ plain Strings. The memory usage concerns that originally led me to
+ use Texts were unfounded.
+
+* Dramatically simplified code for primitive parsers. No more custom
+ error types, monad transformers, or user states. This sort of
+ functionality is easily implemented in the parsers that you can
+ build; baking it into the primitive parsers makes things needlessly
+ complicated.
+
+* Reworked included combinators in Combinator module.
diff --git a/System/Console/MultiArg.hs b/System/Console/MultiArg.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg.hs
@@ -0,0 +1,151 @@
+-- | 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.
+
+ module System.Console.MultiArg.SimpleParser ) where
+
+import System.Console.MultiArg.SimpleParser
diff --git a/System/Console/MultiArg/Combinator.hs b/System/Console/MultiArg/Combinator.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/Combinator.hs
@@ -0,0 +1,284 @@
+-- | 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
+ notFollowedBy,
+ (),
+
+ -- * Combined long and short option parser
+ OptSpec(OptSpec, longOpts, shortOpts, argSpec),
+ ArgSpec(NoArg, OptionalArg, OneArg, TwoArg, VariableArg),
+ parseOption,
+
+ -- * Other words
+ matchApproxWord ) where
+
+import Data.List (isPrefixOf, intersperse)
+import Data.Set ( Set )
+import qualified Data.Set as Set
+import Control.Applicative ((<*>), optional, (<$))
+
+import System.Console.MultiArg.Prim
+ ( Parser, throw, try, approxLongOpt,
+ nextArg, pendingShortOptArg, nonOptionPosArg,
+ pendingShortOpt, nonPendingShortOpt, nextArg,
+ Message(Expected, Replaced), ())
+import System.Console.MultiArg.Option
+ ( LongOpt, ShortOpt, unLongOpt,
+ makeLongOpt, makeShortOpt, unShortOpt )
+import Control.Applicative ((<|>), many)
+import qualified Data.Map as M
+import Data.Map ((!))
+import Data.Monoid ( mconcat )
+
+
+-- | @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 :: Parser a -> Parser ()
+notFollowedBy p =
+ () <$ ((try p >> fail "notFollowedBy failed")
+ <|> return ())
+
+
+-- | Runs the parser given. If it succeeds, then returns the result of
+-- the parser. If it fails and consumes input, returns the result of
+-- the parser. If it fails without consuming any input, then removes
+-- all previous errors, replacing them with a single error of type
+-- Replaced containing the string given.
+() :: Parser a -> String -> Parser a
+() l e = l (const [Replaced e])
+
+infix 0
+
+-- | Examines the possible words in Set. If there are no pendings,
+-- then get the next word and see if it matches one of the words in
+-- Set. If so, returns the word actually parsed and the matching word
+-- from Set. If there is no match, fails without consuming any input.
+matchApproxWord :: Set String -> Parser (String, String)
+matchApproxWord s = try $ do
+ a <- nextArg
+ let p t = a `isPrefixOf` t
+ matches = Set.filter p s
+ err = throw $ Expected
+ ("word matching one of: "
+ ++ (concat . intersperse ", " $ Set.toList s))
+ case Set.toList matches of
+ [] -> err
+ (x:[]) -> return (a, x)
+ _ -> err
+
+
+unsafeShortOpt :: Char -> ShortOpt
+unsafeShortOpt c = case makeShortOpt c of
+ Nothing -> error $ "invalid short option: " ++ [c]
+ Just o -> o
+
+unsafeLongOpt :: String -> LongOpt
+unsafeLongOpt c = case makeLongOpt c of
+ Nothing -> error $ "invalid long option: " ++ c
+ Just o -> o
+
+
+-- |Specifies options for the 'parseOption' function. Each OptSpec
+-- represents one command-line option.
+data OptSpec a = OptSpec {
+ longOpts :: [String]
+ -- ^ Each String is a single long option, such as @version@. When
+ -- the user specifies long options on the command line, she must
+ -- type two dashes; however, do not include the dashes when you
+ -- specify the long option here. Strings you specify as long options
+ -- cannot include a dash as either the first or the second
+ -- character, and they cannot include an equal sign anywhere. If
+ -- your long option does not meet these conditions, a runtime error
+ -- will occur.
+
+
+ , shortOpts :: [Char]
+ -- ^ Each Char is a single short option, such as @v@. The
+ -- character cannot be a dash; if it is, a runtime error will occur.
+
+ , argSpec :: ArgSpec a
+ -- ^ What to do each time one of the given long options or
+ -- short options appears on the command line.
+ }
+
+-- | Specifies how many arguments each option takes. As with
+-- 'System.Console.GetOpt.ArgDescr', there are (at least) two ways to
+-- use this type. You can simply represent each possible option using
+-- different data constructors in an algebraic data type. Or you can
+-- have each ArgSpec yield a function that transforms a record. For an
+-- example that uses an algebraic data type, see
+-- "System.Console.MultiArg.SampleParser".
+data ArgSpec a =
+ NoArg a
+ -- ^ This option takes no arguments
+
+ | OptionalArg (Maybe String -> a)
+ -- ^ 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 (String -> a)
+ -- ^ 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 (String -> String -> a)
+ -- ^ This option takes two arguments. Parsed similarly to 'OneArg'.
+
+ | VariableArg ([String] -> a)
+ -- ^ 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.
+
+
+-- | Parses a single command line option. Examines all the options
+-- specified using multiple OptSpec and parses one option on the
+-- command line accordingly. Fails without consuming any input if the
+-- next word on the command line is not a recognized option. Allows
+-- the user to specify the shortest unambiguous match for long
+-- options; for example, the user could type @--verb@ for @--verbose@
+-- and @--vers@ for @--version@.
+--
+-- For an example that uses this function, see
+-- "System.Console.MultiArg.SimpleParser".
+parseOption :: [OptSpec a] -> Parser a
+parseOption os =
+ let longs = longOptParser os
+ in case mconcat ([shortOpt] <*> os) of
+ Nothing -> longs
+ Just shorts -> longs <|> shorts
+
+longOptParser :: [OptSpec a] -> Parser a
+longOptParser os = longOpt (longOptSet os) (longOptMap os)
+
+
+longOptSet :: [OptSpec a] -> Set LongOpt
+longOptSet = Set.fromList . concatMap toOpts where
+ toOpts = map unsafeLongOpt . longOpts
+
+longOptMap :: [OptSpec a] -> M.Map LongOpt (ArgSpec a)
+longOptMap = M.fromList . concatMap toPairs where
+ toPairs (OptSpec los _ as) = map (toPair as) los where
+ toPair a s = (unsafeLongOpt s, a)
+
+longOpt ::
+ Set LongOpt
+ -> M.Map LongOpt (ArgSpec a)
+ -> Parser a
+longOpt set mp = do
+ (_, lo, maybeArg) <- approxLongOpt set
+ let spec = mp ! lo
+ case spec of
+ NoArg a -> case maybeArg of
+ Nothing -> return a
+ Just _ -> fail $ "option " ++ unLongOpt lo
+ ++ " does not take argument"
+ OptionalArg f -> return (f maybeArg)
+ OneArg f -> case maybeArg of
+ Nothing -> do
+ a1 <- nextArg
+ return $ f a1
+ Just a -> return $ f a
+ TwoArg f -> case maybeArg of
+ Nothing -> do
+ a1 <- nextArg
+ a2 <- nextArg
+ return $ f a1 a2
+ Just a1 -> do
+ a2 <- nextArg
+ return $ f a1 a2
+ VariableArg f -> do
+ as <- many nonOptionPosArg
+ return . f $ case maybeArg of
+ Nothing -> as
+ Just a1 -> a1 : as
+
+
+shortOpt :: OptSpec a -> Maybe (Parser a)
+shortOpt o = mconcat parsers where
+ parsers = map mkParser . shortOpts $ o
+ mkParser c =
+ let opt = unsafeShortOpt c
+ in Just $ case argSpec o of
+ NoArg a -> a <$ nextShort opt
+ OptionalArg f -> shortOptionalArg opt f
+ OneArg f -> shortOneArg opt f
+ TwoArg f -> shortTwoArg opt f
+ VariableArg f -> shortVariableArg opt f
+
+-- | Parses a short option without an argument, either pending or
+-- non-pending. Fails with a single error message rather than two.
+nextShort :: ShortOpt -> Parser ()
+nextShort o = p e where
+ p = pendingShortOpt o <|> nonPendingShortOpt o
+ err = Expected ("short option: " ++ [unShortOpt o])
+ e ls = err : (drop 2 ls)
+
+shortVariableArg :: ShortOpt -> ([String] -> a) -> Parser a
+shortVariableArg opt f = do
+ nextShort opt
+ maybeSameWordArg <- optional pendingShortOptArg
+ args <- many nonOptionPosArg
+ case maybeSameWordArg of
+ Nothing -> return (f args)
+ Just arg1 -> return (f (arg1:args))
+
+
+shortTwoArg :: ShortOpt -> (String -> String -> a) -> Parser a
+shortTwoArg opt f = do
+ nextShort opt
+ maybeSameWordArg <- optional pendingShortOptArg
+ case maybeSameWordArg of
+ Nothing -> do
+ arg1 <- nextArg
+ arg2 <- nextArg
+ return (f arg1 arg2)
+ Just arg1 -> do
+ arg2 <- nextArg
+ return (f arg1 arg2)
+
+
+shortOneArg :: ShortOpt -> (String -> a) -> Parser a
+shortOneArg opt f = do
+ nextShort opt
+ maybeSameWordArg <- optional pendingShortOptArg
+ case maybeSameWordArg of
+ Nothing -> do
+ arg <- nextArg
+ return (f arg)
+ Just a -> return (f a)
+
+
+shortOptionalArg :: ShortOpt -> (Maybe String -> a) -> Parser a
+shortOptionalArg opt f = do
+ nextShort opt
+ maybeSameWordArg <- optional pendingShortOptArg
+ case maybeSameWordArg of
+ Nothing -> do
+ maybeArg <- optional nonOptionPosArg
+ case maybeArg of
+ Nothing -> return (f Nothing)
+ Just a -> return (f (Just a))
+ Just a -> return (f (Just a))
diff --git a/System/Console/MultiArg/GetArgs.hs b/System/Console/MultiArg/GetArgs.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/GetArgs.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE CPP #-}
+
+-- | Get the arguments from the command line, ensuring they are
+-- properly encoded into Unicode.
+--
+-- base 4.3.1.0 has a System.Environment.getArgs that does not return
+-- a Unicode string. Instead, it simply puts each octet into a
+-- different Char. Thus its getArgs is broken on UTF-8 and nearly any
+-- non-ASCII encoding. As a workaround I use
+-- System.Environment.UTF8. The downside of this is that it requires
+-- that the command line be encoded in UTF8, regardless of what the
+-- default system encoding is.
+--
+-- Unlike base 4.3.1.0, base 4.4.0.0 actually returns a proper Unicode
+-- string when you call System.Environment.getArgs. (base 4.3.1.0
+-- comes with ghc 7.0.4; base 4.4.0.0 comes with ghc 7.2.) The string
+-- is encoded depending on the default system locale. The only problem
+-- is that System.Environment.UTF8 apparently simply uses
+-- System.Environment.getArgs and then assumes that the string it
+-- returns has not been decoded. In other words,
+-- System.Environment.UTF8 assumes that System.Environment.getArgs is
+-- broken, and when System.Environment.getArgs was fixed in base
+-- 4.4.0.0, it likely will break System.Environment.UTF8.
+--
+-- One obvious solution to this problem is to find some other way to
+-- get the command line that will not break when base is updated. But
+-- it was not easy to find such a thing. The other libraries I saw on
+-- hackage (as of January 6, 2012) had problems, such as breakage on
+-- ghc 7.2. There is a package that has a simple interface to the UNIX
+-- setlocale(3) function, but I'm not sure that what it returns easily
+-- and reliably maps to character encodings that you can use with,
+-- say, iconv.
+--
+-- So by use of Cabal and preprocessor macors, the code uses
+-- utf8-string if base is less than 4.4, and uses
+-- System.Environment.getArgs if base is at least 4.4.
+--
+-- The GHC bug is here:
+--
+--
+
+module System.Console.MultiArg.GetArgs ( getArgs, getProgName ) where
+
+#if MIN_VERSION_base(4,4,0)
+import qualified System.Environment as E ( getArgs, getProgName )
+#else
+import qualified System.Environment.UTF8 as E ( getArgs, getProgName )
+#endif
+
+-- | Gets the command-line arguments supplied by the program's
+-- user. If the @base@ package is older than version 4.4, then this
+-- function assumes the command line is encoded in UTF-8, which is
+-- true for many newer Unix systems; however, many older systems may
+-- use single-byte encodings like ISO-8859. In such cases, this
+-- function will give erroneous results.
+--
+-- If the @base@ package is version 4.4.0 or newer, this function
+-- simply uses the getArgs that comes with @base@. That getArgs
+-- detects the system's default encoding and uses that, so it should
+-- give accurate results on most systems.
+getArgs :: IO [String]
+getArgs = E.getArgs
+
+-- | Gets the name of the program that the user invoked. See
+-- documentation for 'getArgs' for important caveats that also apply
+-- to this function.
+getProgName :: IO String
+getProgName = E.getProgName
diff --git a/System/Console/MultiArg/Option.hs b/System/Console/MultiArg/Option.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/Option.hs
@@ -0,0 +1,56 @@
+-- | These types represent options. 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 Data.List (find)
+
+-- | 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)
+
+-- | Creates a short option. Returns Nothing if the character is not
+-- valid for a short option.
+makeShortOpt :: Char -> Maybe ShortOpt
+makeShortOpt c = case c of
+ '-' -> Nothing
+ x -> Just $ 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 :: String } deriving (Show, Eq, Ord)
+
+-- | Makes a long option. Returns Nothing if the string is not a valid
+-- long option.
+makeLongOpt :: String -> Maybe LongOpt
+makeLongOpt t = case isValidLongOptText t of
+ True -> Just $ LongOpt t
+ False -> Nothing
+
+isValidLongOptText :: String -> Bool
+isValidLongOptText s = case s of
+ [] -> False
+ x:xs ->
+ if x == '-' || x == '='
+ then False
+ else case xs of
+ [] -> True
+ y:_ ->
+ if y == '-' || y == '='
+ then False
+ else maybe True (const False) (find (== '=') xs)
diff --git a/System/Console/MultiArg/Prim.hs b/System/Console/MultiArg/Prim.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/Prim.hs
@@ -0,0 +1,741 @@
+-- | Parser primitives. These are the only functions that have access
+-- to the internals of the parser. Use these functions if you want to
+-- build your own parser from scratch. If your needs are simpler, you
+-- will want to look at "System.Console.MultiArg.SimpleParser" or
+-- "System.Console.MultiArg.Combinator", which do a lot of grunt work
+-- for you.
+module System.Console.MultiArg.Prim (
+ -- * Parser types
+ Parser,
+
+ -- * Running a parser
+
+ -- | Each parser runner is applied to a list of Strings, which are the
+ -- command line arguments to parse.
+ parse,
+
+ -- * Higher-level parser combinators
+ parserMap,
+ good,
+ apply,
+ choice,
+ combine,
+ lookAhead,
+
+ -- ** Running parsers multiple times
+ several,
+ manyTill,
+
+ -- ** Failure and errors
+ throw,
+ throwString,
+ genericThrow,
+ (),
+ try,
+
+ -- * Parsers
+ -- ** Short options and arguments
+ pendingShortOpt,
+ nonPendingShortOpt,
+ pendingShortOptArg,
+
+ -- ** Long options and arguments
+ exactLongOpt,
+ approxLongOpt,
+
+ -- ** Stoppers
+ stopper,
+ resetStopper,
+
+ -- ** Positional (non-option) arguments
+ nextArg,
+ nonOptionPosArg,
+
+ -- ** Miscellaneous
+ end,
+
+ -- * Errors
+ Message(Expected, StrMsg, Replaced, UnknownError),
+ Error(Error),
+ Location
+
+ ) where
+
+
+import System.Console.MultiArg.Option
+ (ShortOpt,
+ unShortOpt,
+ LongOpt,
+ unLongOpt,
+ makeLongOpt )
+import Control.Applicative ( Applicative, Alternative )
+import qualified Control.Applicative
+import Control.Monad.Exception.Synchronous
+ (Exceptional(Success, Exception))
+import qualified Data.Set as Set
+import Data.Set ( Set )
+import Control.Monad ( when, MonadPlus(mzero, mplus), guard )
+import Data.Monoid ( Monoid ( mempty, mappend ) )
+import qualified Data.List as L
+import Data.List (isPrefixOf)
+
+type Location = String
+
+-- | An Error contains a list of Messages and a String indicating
+-- where the error happened.
+data Error = Error [Message] Location deriving Show
+
+-- | Extract a Location from a ParseSt for use in error messages.
+location :: ParseSt -> Location
+location st = pending ++ next ++ stop where
+ pending
+ | null (pendingShort st) = ""
+ | otherwise = "short option or short option argument: "
+ ++ pendingShort st ++ " "
+ next = case remaining st of
+ [] -> "no words remaining"
+ x:_ -> "next word: " ++ x
+ stop = if sawStopper st then " (stopper already seen)" else ""
+
+-- | Error messages.
+data Message =
+ Expected String
+ -- ^ The parser expected to see one thing, but it actually saw
+ -- something else. The string indicates what was expected.
+ | StrMsg String
+ -- ^ The 'fromString' function was applied.
+
+ | Replaced String
+ -- ^ A previous list of error messages was replaced with this error message.
+
+ | UnknownError
+ -- ^ Any other error; used by 'genericThrow'.
+
+ deriving Show
+
+-- | Carries the internal state of the parser. The counter is a simple
+-- way to determine whether the remaining list one ParseSt has been
+-- modified from another. When parsers modify remaining, they
+-- increment the counter.
+data ParseSt = ParseSt { pendingShort :: String
+ , remaining :: [String]
+ , sawStopper :: Bool
+ , counter :: Int
+ , errors :: [Message]
+ } deriving Show
+
+-- | Load up the ParseSt with an initial user state and a list of
+-- commmand line arguments.
+defaultState :: [String] -> ParseSt
+defaultState ts = ParseSt { pendingShort = ""
+ , remaining = ts
+ , sawStopper = False
+ , counter = 0
+ , errors = [] }
+
+-- | Carries the result of each parse.
+data Result a = Bad | Good a
+
+-- | Parsers. Internally the parser tracks what input remains to be
+-- parsed, whether there are any pending short options, and whether a
+-- stopper has been seen. A parser can return a value of any type.
+--
+-- The parser also includes the notion of failure. Any parser can
+-- fail; a failed parser affects the behavior of combinators such as
+-- combine.
+data Parser a =
+ Parser { runParser :: ParseSt -> (Result a, ParseSt) }
+
+instance Functor Parser where
+ fmap = parserMap
+
+instance Applicative Parser where
+ pure = good
+ (<*>) = apply
+
+instance Monoid (Parser a) where
+ mempty = genericThrow
+ mappend = choice
+
+instance Alternative Parser where
+ empty = genericThrow
+ (<|>) = choice
+ many = several
+
+instance Monad Parser where
+ (>>=) = combine
+ return = good
+ fail = throwString
+
+instance MonadPlus Parser where
+ mzero = genericThrow
+ mplus = choice
+
+
+-- | Runs a parser. This is the only way to change a value of type
+-- @Parser a@ into a value of type @a@ (that is, it is the only way to
+-- \"get out of the Parser monad\" or to \"escape the Parser monad\".)
+parse ::
+ [String]
+ -- ^ Command line arguments to parse. Presumably you got these from
+ -- 'getArgs'. If there is any chance that you will be parsing
+ -- Unicode strings, see the documentation in
+ -- "System.Console.MultiArg.GetArgs" before you use
+ -- 'System.Environment.getArgs'.
+
+ -> Parser a
+ -- ^ Parser to run
+
+ -> Exceptional Error a
+ -- ^ Success or failure. Any parser might fail; for example, the
+ -- command line might not have any values left to parse. Use of the
+ -- 'choice' combinator can lead to a list of failures. If multiple
+ -- parsers are tried one after another using the 'choice' combinator,
+ -- and each fails without consuming any input, then multiple Error
+ -- will result, one for each failure.
+
+parse ts p =
+ let (result, st') = runParser p (defaultState ts)
+ in case result of
+ Good g -> Success g
+ Bad ->
+ let e = Error (errors st') (location st')
+ in Exception e
+
+
+-- | 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 :: Parser a -> (a -> Parser b) -> Parser b
+combine a k = Parser $ \s ->
+ let (r, s') = runParser a s
+ in case r of
+ Bad -> (Bad, s')
+ Good g -> runParser (k g) s'
+
+
+-- | @lookAhead p@ runs parser p. If p succeeds, lookAhead p succeeds
+-- without consuming any input. If p fails without consuming any
+-- input, so does lookAhead. If p fails and consumes input, lookAhead
+-- also fails and consumes input. If this is undesirable, combine with
+-- "try".
+lookAhead :: Parser a -> Parser a
+lookAhead a = Parser $ \s ->
+ let (r, s') = runParser a s
+ in case r of
+ Good g -> (Good g, s)
+ Bad -> (Bad, s')
+
+
+-- | @good a@ always succeeds without consuming any input and has
+-- result a. This provides the implementation for
+-- 'Control.Monad.Monad.return' and
+-- 'Control.Applicative.Applicative.pure'.
+good :: a -> Parser a
+good a = Parser $ \s -> (Good a, s)
+
+
+-- | @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 :: String -> Parser a
+throwString e = Parser $ \s ->
+ let err = StrMsg e
+ s' = s { errors = err : errors s }
+ in (Bad, s')
+
+
+-- | @parserMap f p@ applies function f to the result of parser
+-- p. First parser p is run. If it succeeds, function f is applied to
+-- the result and another parser is returned with the result. If it
+-- fails, f is not applied and a failed parser is returned. This
+-- provides the implementation for 'Prelude.Functor.fmap'.
+parserMap :: (a -> b) -> Parser a -> Parser b
+parserMap f l = Parser $ \s ->
+ let (r, s') = runParser l s
+ in case r of
+ Good g -> (Good (f g), s')
+ Bad -> (Bad, s')
+
+
+-- | apply l r applies the function found in parser l to the result of
+-- parser r. First the l parser is run. If it succeeds, it has a
+-- resulting function. Then the r parser is run. If it succeeds, the
+-- function from the l parser is applied to the result of the r
+-- parser, and a new parser is returned with the result. If either
+-- parser l or parser r fails, then a failed parser is returned. This
+-- provides the implementation for '<*>' in
+-- 'Control.Applicative.Applicative'.
+apply :: Parser (a -> b) -> Parser a -> Parser b
+apply fa a = Parser $ \s ->
+ let (r, s') = runParser fa s
+ in case r of
+ Good g ->
+ let (ra, sa) = runParser a s'
+ in case ra of
+ Good ga -> (Good (g ga), sa)
+ Bad -> (Bad, sa)
+ Bad -> (Bad, s')
+
+
+-- | Fail with an unhelpful error message. Usually throw is more
+-- useful, but this is handy to implement some typeclass instances.
+genericThrow :: Parser a
+genericThrow = throw UnknownError
+
+-- | throw e always fails without consuming any input and returns a
+-- failed parser with error state e.
+throw :: Message -> Parser a
+throw e = Parser $ \s ->
+ (Bad, s { errors = e : errors s })
+
+noConsumed :: ParseSt -> ParseSt -> Bool
+noConsumed old new = counter old >= counter new
+
+-- | 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 :: Parser a -> Parser a -> Parser a
+choice a b = Parser $ \sOld ->
+ let (ra, sa) = runParser a sOld
+ in case ra of
+ Good g ->
+ let sNew = sa { errors = [] }
+ in (Good g, sNew)
+ Bad ->
+ if noConsumed sOld sa
+ then let sNew = sOld { errors = errors sa }
+ (rb, sb) = runParser b sNew
+ in case rb of
+ Good g' -> let sb' = sb { errors = [] }
+ in (Good g', sb')
+ Bad -> (Bad, sb)
+ else (Bad, sa)
+
+
+-- | Runs the parser given. If it fails /without consuming any input/,
+-- then applies the given function to the list of messages and replaces
+-- the list of messages with the list returned by the
+-- function. Otherwise, returns the result of the parser.
+() :: Parser a -> ([Message] -> [Message]) -> Parser a
+() l f = Parser $ \s ->
+ let (r, s') = runParser l s
+ in case r of
+ Good g -> (Good g, s')
+ Bad ->
+ if noConsumed s s'
+ then let s'' = s' { errors = f $ errors s' }
+ in (Bad, s'')
+ else (Bad, s')
+
+infix 0
+
+increment :: ParseSt -> ParseSt
+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.
+
+pendingShortOpt :: ShortOpt -> Parser ()
+pendingShortOpt so = Parser $ \s ->
+ let err = Expected ("pending short option: " ++ [(unShortOpt so)])
+ es = (Bad, s { errors = err : errors s })
+ gd newSt = (Good (), newSt)
+ in maybe es gd $ do
+ when (sawStopper s) Nothing
+ (first, rest) <- case pendingShort s of
+ [] -> Nothing
+ x:xs -> return (x, xs)
+ when (unShortOpt so /= first) Nothing
+ return (increment s { pendingShort = 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.
+nonPendingShortOpt :: ShortOpt -> Parser ()
+nonPendingShortOpt so = Parser $ \s ->
+ let err = Expected (msg ++ [unShortOpt so])
+ msg = "non pending short option: "
+ errRet = (Bad, s { errors = err : errors s })
+ gd n = (Good (), n)
+ in maybe errRet gd $ do
+ guard (noPendingShorts s)
+ guard (noStopper s)
+ (a, s') <- nextWord s
+ (maybeDash, word) <- case a of
+ [] -> Nothing
+ x:xs -> return (x, xs)
+ guard (maybeDash == '-')
+ (letter, arg) <- case word of
+ [] -> Nothing
+ x:xs -> return (x, xs)
+ guard (letter == unShortOpt so)
+ let s'' = s' { pendingShort = arg }
+ return 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 :: LongOpt -> Parser (Maybe String)
+exactLongOpt lo = Parser $ \s ->
+ let ert = (Bad, err)
+ err = s { errors = Expected msg : errors s } where
+ msg = "long option: " ++ unLongOpt lo
+ gd (g, n) = (Good g, n)
+ in maybe ert gd $ do
+ guard (noPendingShorts s)
+ guard (noStopper s)
+ (x, s') <- nextWord s
+ (word, afterEq) <- getLongOption x
+ guard (word == unLongOpt lo)
+ return (afterEq, s')
+
+-- | Takes a single String and returns a tuple, where the first element
+-- is the first two letters, the second element is everything from the
+-- third letter to the equal sign, and the third element is Nothing if
+-- there is no equal sign, or Just String with everything after the
+-- equal sign if there is one.
+splitLongWord :: String -> (String, String, Maybe String)
+splitLongWord t = (f, s, r) where
+ (f, rest) = L.splitAt 2 t
+ (s, withEq) = L.break (== '=') rest
+ r = case withEq of
+ [] -> Nothing
+ _:xs -> Just xs
+
+
+noPendingShorts :: ParseSt -> Bool
+noPendingShorts st = case pendingShort st of
+ [] -> True
+ _ -> False
+
+noStopper :: ParseSt -> Bool
+noStopper = not . sawStopper
+
+getLongOption :: String -> Maybe (String, Maybe String)
+getLongOption str = do
+ guard (str /= "--")
+ let (pre, word, afterEq) = splitLongWord str
+ guard (pre == "--")
+ return (word, afterEq)
+
+
+nextWord :: ParseSt -> Maybe (String, ParseSt)
+nextWord st = case remaining st of
+ [] -> Nothing
+ x:xs ->
+ let s' = increment st { remaining = xs }
+ in return (x, s')
+
+approxLongOptError ::
+ Set LongOpt
+ -> ParseSt
+ -> ParseSt
+approxLongOptError set st = st { errors = newE : errors st } where
+ newE = Expected ex
+ ex = "a long option: " ++ longs
+ longs = concat . L.intersperse ", " $ opts
+ opts = fmap unLongOpt . Set.toList $ set
+
+-- | 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 and the accompanying text after the equal
+-- sign (if any). If the Set is empty, this parser will always fail.
+approxLongOpt ::
+ Set LongOpt
+ -> Parser (String, LongOpt, Maybe String)
+approxLongOpt ts = Parser $ \s ->
+ let err = (Bad, approxLongOptError ts s)
+ gd (g, newSt) = (Good g, newSt)
+ in maybe err gd $ do
+ guard (noPendingShorts s)
+ (x, s') <- nextWord s
+ (word, afterEq) <- getLongOption x
+ opt <- makeLongOpt word
+ if Set.member opt ts
+ then return ((word, opt, afterEq), s')
+ else do
+ let p t = word `isPrefixOf` (unLongOpt t)
+ matches = Set.filter p ts
+ case Set.toList matches of
+ [] -> Nothing
+ (m:[]) -> return ((word, m, afterEq), s')
+ _ -> Nothing
+
+-- | 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 String of the pending short option argument
+-- (this String will never be empty).
+pendingShortOptArg :: Parser String
+pendingShortOptArg = Parser $ \s ->
+ let ert = (Bad, err)
+ err = s { errors = Expected msg : errors s } where
+ msg = "pending short option argument"
+ gd (g, newSt) = (Good g, newSt)
+ in maybe ert gd $ do
+ guard (noStopper s)
+ case pendingShort s of
+ [] -> Nothing
+ xs ->
+ let newSt = increment s { pendingShort = "" }
+ in return (xs, 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 :: Parser ()
+stopper = Parser $ \s ->
+ let err = s { errors = Expected msg : errors s } where
+ msg = "stopper"
+ ert = (Bad, err)
+ gd (g, newSt) = (Good g, newSt)
+ in maybe ert gd $ do
+ guard (noPendingShorts s)
+ guard (noStopper s)
+ (x, s') <- nextWord s
+ guard (x == "--")
+ let s'' = s' { sawStopper = True }
+ return ((), s'')
+
+-- | If a stopper has already been seen, change the internal state
+-- back to indicating that no stopper has been seen.
+resetStopper :: Parser ()
+resetStopper = Parser $ \s ->
+ let s' = s { sawStopper = False }
+ in (Good (), s')
+
+-- | try p behaves just like p, but if p fails, try p will not consume
+-- any input.
+try :: Parser a -> Parser a
+try a = Parser $ \s ->
+ let (r, s') = runParser a s
+ in case r of
+ Good g -> (Good g, s')
+ Bad -> (Bad, s'') where
+ s'' = s { errors = errors s' }
+
+
+-- | Returns the next string on the command line as long as there are
+-- no pendings. Be careful - this will return the next string even if
+-- it looks like an option (that is, it starts with a dash.) Consider
+-- whether you should be using nonOptionPosArg instead. However this
+-- can be useful when parsing command line options after a stopper.
+nextArg :: Parser String
+nextArg = Parser $ \s ->
+ let ert = (Bad, err)
+ err = s { errors = Expected msg : errors s } where
+ msg = "next argument"
+ gd (g, newSt) = (Good g, newSt)
+ in maybe ert gd $ do
+ guard (noPendingShorts s)
+ nextWord s
+
+
+-- | If there are pending short options, fails without consuming any input.
+--
+-- Otherwise, if a stopper has NOT already been parsed, then returns
+-- the next word if it is either a single dash or any other word that
+-- does not begin with a dash. If the next word does not meet these
+-- criteria, fails without consuming any input.
+--
+-- Otherwise, if a stopper has already been parsed, then returns the
+-- next word, regardless of whether it begins with a dash or not.
+nonOptionPosArg :: Parser String
+nonOptionPosArg = Parser $ \s ->
+ let ert = (Bad, err)
+ err = s { errors = Expected msg : errors s } where
+ msg = "non option positional argument"
+ gd (g, newSt) = (Good g, newSt)
+ in maybe ert gd $ do
+ guard (noPendingShorts s)
+ (x, s') <- nextWord s
+ result <-
+ if sawStopper s
+ then return x
+ else case x of
+ [] -> return x
+ '-':[] -> return "-"
+ f:_ -> if f == '-'
+ then Nothing
+ else return x
+ return (result, s')
+
+
+-- | manyTill p e runs parser p repeatedly until parser e succeeds.
+--
+-- More precisely, first it runs parser e. If parser e succeeds, then
+-- manyTill returns the result of all the preceding successful parses
+-- of p. If parser e fails (it does not matter whether e consumed any
+-- input or not), manyTill runs parser p again. What happens next
+-- depends on whether p succeeded or failed. If p succeeded, then the
+-- loop starts over by running parser e again. If p failed (it does
+-- not matter whether it consumed any input or not), then manyTill
+-- fails. The state of the parser is updated to reflect its state
+-- after the failed run of p, and the parser is left in a failed
+-- state.
+--
+-- Should parser e succeed (as it will on a successful application of
+-- manyTill), then the parser state will reflect that parser e
+-- succeeded--that is, if parser e consumes input, that input will be
+-- consumed in the parser that is returned. Wrap e inside of
+-- @lookAhead@ if that is undesirable.
+--
+-- Be particularly careful to get the order of the arguments
+-- correct. Applying this function to reversed arguments will yield
+-- bugs that are very difficult to diagnose.
+manyTill :: Parser a -> Parser end -> Parser [a]
+manyTill (Parser r) (Parser f) = Parser $ \s ->
+ let Till g lS lF = parseTill s r f
+ in if lF then (Bad, lS) else (Good g, lS)
+
+
+data Till a =
+ Till { _goods :: [a]
+ , _lastSt :: ParseSt
+ , _lastRunFailed :: Bool }
+
+parseTill ::
+ ParseSt
+ -> (ParseSt -> (Result a, ParseSt))
+ -> (ParseSt -> (Result b, ParseSt))
+ -> Till a
+parseTill s fr ff =
+ case ff s of
+ (Good _, s') -> Till [] s' False
+ (Bad, _) ->
+ case fr s of
+ (Bad, s'') -> Till [] s'' True
+ (Good g, s'') ->
+ let Till gs lS lF = parseTill s'' fr ff
+ in if counter s'' == counter s
+ then parseTillErr
+ else Till (g:gs) lS lF
+
+parseTillErr :: a
+parseTillErr =
+ error "parseTill applied to parser that takes empty list"
+
+
+-- | several p runs parser p zero or more times and returns all the
+-- results. This proceeds like this: parser p is run and, if it
+-- succeeds, the result is saved and parser p is run
+-- again. Repeat. Eventually this will have to fail. If the last run
+-- of parser p fails without consuming any input, then several p runs
+-- successfully. The state of the parser is updated to reflect the
+-- successful runs of p. If the last run of parser p fails but it
+-- consumed input, then several p fails. The state of the parser is
+-- updated to reflect the state up to and including the run that
+-- partially consumed input. The parser is left in a failed state.
+--
+-- This semantic can come in handy. For example you might run a parser
+-- multiple times that parses an option and arguments to the
+-- option. If the arguments fail to parse, then several will fail.
+--
+-- This function provides the implementation for
+-- 'Control.Applicative.Alternative.many'.
+several :: Parser a -> Parser [a]
+several (Parser l) = Parser $ \s ->
+ let (result, finalGoodSt, finalBadSt) = parseRepeat s l
+ in if noConsumed finalGoodSt finalBadSt
+ then (Good result, finalGoodSt)
+ else (Bad, finalBadSt)
+
+
+parseRepeat ::
+ ParseSt
+ -> (ParseSt -> (Result a, ParseSt))
+ -> ([a], ParseSt, ParseSt)
+parseRepeat st1 f =
+ case f st1 of
+ (Good a, st') ->
+ if noConsumed st1 st'
+ then error $ "several applied to parser that succeeds without"
+ ++ " consuming any input"
+ else
+ let (ls, finalGoodSt, finalBadSt) = parseRepeat st' f
+ in (a : ls, finalGoodSt, finalBadSt)
+ (Bad, st') -> ([], st1, st')
+
+
+-- | Succeeds if there is no more input left.
+end :: Parser ()
+end = Parser $ \s ->
+ let ert = (Bad, err)
+ err = s { errors = Expected msg : errors s } where
+ msg = "end of input"
+ gd (g, newSt) = (Good g, newSt)
+ in maybe ert gd $ do
+ guard (noPendingShorts s)
+ guard (null . remaining $ s)
+ return ((), s)
diff --git a/System/Console/MultiArg/SampleParser.hs b/System/Console/MultiArg/SampleParser.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/SampleParser.hs
@@ -0,0 +1,63 @@
+-- | 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, simply compile an executable that looks
+-- like this and then feed it different options:
+--
+-- > import System.Console.MultiArg.SampleParser
+-- > main = sampleMain Intersperse
+--
+-- or:
+--
+-- > import System.Console.MultiArg.SampleParser
+-- > main = sampleMain StopOptions
+--
+-- The code in the module is the sample code; the sample code is not
+-- in the Haddock documentation! If you're reading this in Haddock,
+-- you will want to also take a look at the actual source code.
+module System.Console.MultiArg.SampleParser (
+ Flag(..)
+ , specs
+ , P.Intersperse(..)
+ , sampleMain
+ ) where
+
+import System.Console.MultiArg.SimpleParser as P
+
+data Flag =
+ Bytes String
+ | Follow (Maybe String)
+ | Retry
+ | Lines String
+ | Stats String
+ | Pid String
+ | Quiet
+ | Sleep String
+ | Verbose
+ | Help
+ | Version
+ | Filename String
+ deriving Show
+
+specs :: [P.OptSpec Flag]
+
+specs =
+ [ P.OptSpec ["bytes"] ['c'] (P.OneArg Bytes)
+ , P.OptSpec ["follow"] ['f'] (P.OptionalArg Follow)
+ , P.OptSpec ["follow-retry"] ['F'] (P.NoArg Retry)
+ , P.OptSpec ["lines"] ['n'] (P.OneArg Lines)
+ , P.OptSpec ["max-unchanged-stats"] [] (P.OneArg Stats)
+ , P.OptSpec ["pid"] [] (P.OneArg Pid)
+ , P.OptSpec ["quiet"] ['q'] (P.NoArg Quiet)
+ , P.OptSpec ["sleep-interval"] ['s'] (P.OneArg Sleep)
+ , P.OptSpec ["verbose"] ['v'] (P.NoArg Verbose)
+ , P.OptSpec ["help"] [] (P.NoArg Help)
+ , P.OptSpec ["version"] [] (P.NoArg Version)
+ ]
+
+sampleMain :: P.Intersperse -> IO ()
+sampleMain i = do
+ as <- P.getArgs
+ let r = P.parse i specs Filename as
+ print r
diff --git a/System/Console/MultiArg/SimpleParser.hs b/System/Console/MultiArg/SimpleParser.hs
new file mode 100644
--- /dev/null
+++ b/System/Console/MultiArg/SimpleParser.hs
@@ -0,0 +1,105 @@
+-- | 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 (
+ -- * Interspersion control
+ Intersperse (Intersperse, StopOptions)
+
+ -- * Option specifications
+ , C.OptSpec (OptSpec, longOpts, shortOpts, argSpec)
+ , C.ArgSpec (NoArg, OptionalArg, OneArg, TwoArg, VariableArg)
+
+ -- * Exceptions
+ , Ex.Exceptional (Exception, Success)
+ , P.Error (Error)
+ , P.Message (Expected, StrMsg, Replaced, UnknownError)
+
+ -- * Get command line arguments
+ , G.getArgs
+
+ -- * The parser
+ , parse
+ ) where
+
+import qualified System.Console.MultiArg.Prim as P
+import qualified System.Console.MultiArg.GetArgs as G
+import qualified System.Console.MultiArg.Combinator as C
+import qualified Control.Monad.Exception.Synchronous as Ex
+import Control.Applicative ( many, (<|>), optional, (*>),
+ (<$))
+import Data.Maybe (catMaybes)
+
+-- | 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
+ -- ^ What to do after encountering the first positional argument
+
+ -> [C.OptSpec a]
+ -- ^ All possible options
+
+ -> (String -> a)
+ -- ^ How to handle positional arguments. This function is applied to
+ -- the appropriate string every time the parser encounters a
+ -- positional argument.
+
+ -> [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.
+
+ -> Ex.Exceptional P.Error [a]
+parse i os p as =
+ let optParser = C.parseOption os
+ parser = case i of
+ Intersperse -> parseIntersperse optParser p
+ StopOptions -> parseStopOpts optParser p
+ in P.parse as parser
+
+parseOptsNoIntersperse :: P.Parser a -> P.Parser [a]
+parseOptsNoIntersperse p = P.manyTill p e where
+ e = P.end <|> nonOpt
+ nonOpt = P.lookAhead next
+ next = ((() <$ P.nonOptionPosArg) <|> P.stopper)
+
+
+parseStopOpts :: P.Parser a -> (String -> a) -> P.Parser [a]
+parseStopOpts optParser p = do
+ opts <- parseOptsNoIntersperse optParser
+ _ <- optional P.stopper
+ args <- many P.nextArg
+ return $ opts ++ (map p args)
+
+
+-- | @parseIntersperse o p@ parses options and positional arguments,
+-- where o is a parser that parses options, and p is a function that,
+-- when applied to a string, returns the appropriate type.
+parseIntersperse :: P.Parser a -> (String -> a) -> P.Parser [a]
+parseIntersperse optParser p =
+ let pa = P.nonOptionPosArg >>= return . Just . p
+ po = optParser >>= return . Just
+ ps = P.stopper *> return Nothing
+ parser = po <|> ps <|> pa
+ in P.manyTill parser P.end >>= return . catMaybes
diff --git a/doc/sample.hs b/doc/sample.hs
deleted file mode 100644
--- a/doc/sample.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-import System.Console.MultiArg.SampleParser
-
-main :: IO ()
-main = sampleMain
diff --git a/lib/System/Console/MultiArg.hs b/lib/System/Console/MultiArg.hs
deleted file mode 100644
--- a/lib/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/lib/System/Console/MultiArg/Combinator.hs b/lib/System/Console/MultiArg/Combinator.hs
deleted file mode 100644
--- a/lib/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/lib/System/Console/MultiArg/Error.hs b/lib/System/Console/MultiArg/Error.hs
deleted file mode 100644
--- a/lib/System/Console/MultiArg/Error.hs
+++ /dev/null
@@ -1,215 +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
-
--- | 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
deleted file mode 100644
--- a/lib/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/lib/System/Console/MultiArg/Option.hs b/lib/System/Console/MultiArg/Option.hs
deleted file mode 100644
--- a/lib/System/Console/MultiArg/Option.hs
+++ /dev/null
@@ -1,61 +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 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
deleted file mode 100644
--- a/lib/System/Console/MultiArg/Prim.hs
+++ /dev/null
@@ -1,962 +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,
- 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
deleted file mode 100644
--- a/lib/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/lib/System/Console/MultiArg/SimpleParser.hs b/lib/System/Console/MultiArg/SimpleParser.hs
deleted file mode 100644
--- a/lib/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/lib/System/Console/MultiArg/TextNonEmpty.hs b/lib/System/Console/MultiArg/TextNonEmpty.hs
deleted file mode 100644
--- a/lib/System/Console/MultiArg/TextNonEmpty.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-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.2.0.0
+Version: 0.4.0.0
Cabal-version: >=1.8
Build-Type: Simple
License: MIT
@@ -12,8 +12,7 @@
Category: Console, Parsing
License-File: LICENSE
synopsis: Combinators to build command line parsers
-extra-source-files:
- doc/sample.hs, NEWS
+extra-source-files: NEWS
description: multiarg is a parser combinator library to build command
line parsers. With it you can easily create parsers with options
@@ -21,13 +20,11 @@
multiarg due to the apparent lack of such ability amongst other
parsers. Its basic design is loosely inspired by Parsec.
.
- Provides ParserT, a monad you use to build parsers. ParserT is a monad
- transformer, so you can layer it on top of other monads. For instance
- you could layer it on the IO monad so that your parser can perform IO.
- .
- It also has a simple, pre-built parser built with the underlying
- combinators, which works for many situtations and shields you from the
- underlying complexity if you don't need it.
+ Provides Parser, a monad you use to build parsers. This monad exposes
+ multiarg's full functionality. The library also has a simple,
+ pre-built parser built with the underlying combinators, which works
+ for many situtations and shields you from the underlying complexity
+ if you don't need it.
.
See the documentation in the System.Console.MultiArg module for
details.
@@ -40,14 +37,10 @@
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.*,
- transformers == 0.2.*
+ containers ==0.4.*
-- See documentation in System.Console.MultiArg.GetArgs for details
if flag(newbase)
@@ -61,12 +54,10 @@
Exposed-modules:
System.Console.MultiArg,
System.Console.MultiArg.Combinator,
- System.Console.MultiArg.Error,
System.Console.MultiArg.GetArgs,
System.Console.MultiArg.Option,
System.Console.MultiArg.Prim,
System.Console.MultiArg.SampleParser,
- System.Console.MultiArg.SimpleParser,
- System.Console.MultiArg.TextNonEmpty
+ System.Console.MultiArg.SimpleParser
ghc-options: -Wall