parseargs-0.2.0.7/0000755000000000000000000000000012726173661012046 5ustar0000000000000000parseargs-0.2.0.7/test-parseargs.sh0000755000000000000000000000067012726173661015354 0ustar0000000000000000#!/bin/sh # Copyright © 2016 Bart Massey # Run simple parseargs tests PA=dist/build/parseargs-example/parseargs-example TMP=/tmp/test-parseargs-$$ trap "rm -f $TMP" 0 1 2 3 15 for f in tests/*.in do T="`basename $f .in`" $PA `cat $f` >$TMP if ! cmp $TMP tests/$T.out then echo "test $T failed" echo "expected:" cat tests/$T.out echo "got:" cat $TMP exit 1 fi done exit 0 parseargs-0.2.0.7/parseargs-example.hs0000644000000000000000000000505712726173661016031 0ustar0000000000000000-- Copyright © 2010 Bart Massey -- This program is licensed under the "3-clause ('new') BSD License". -- Please see the file COPYING in this distribution for license terms. module Main where import Control.Monad import Data.Maybe import System.Console.ParseArgs data Options = OptionFlag | OptionFlagInt | OptionFlagString | OptionPreoptional | OptionFixed | OptionOptional deriving (Ord, Eq, Show) argd :: [ Arg Options ] argd = [ Arg { argIndex = OptionFlag, argName = Just "flag", argAbbr = Just 'f', argData = Nothing, argDesc = "Test flag" }, Arg { argIndex = OptionFlagString, argName = Just "string-flag", argAbbr = Just 's', argData = argDataOptional "test-value" ArgtypeString, argDesc = "Test string flag" }, Arg { argIndex = OptionFlagInt, argName = Just "int-flag", argAbbr = Nothing, argData = argDataDefaulted "test-value" ArgtypeInt 7, argDesc = "Test int flag" }, Arg { argIndex = OptionPreoptional, argName = Nothing, argAbbr = Nothing, argData = argDataOptional "pre-optional" ArgtypeString, argDesc = "Test optional string before fixed" }, Arg { argIndex = OptionFixed, argName = Nothing, argAbbr = Nothing, argData = argDataRequired "fixed" ArgtypeString, argDesc = "Test fixed string" }, Arg { argIndex = OptionOptional, argName = Nothing, argAbbr = Nothing, argData = argDataOptional "optional" ArgtypeString, argDesc = "Test optional string" }] main :: IO () main = do args <- parseArgsIO (ArgsParseControl (ArgsTrailing "junk") ArgsSoftDash) argd putStrLn "parse successful" when (gotArg args OptionFlag) (putStrLn "saw flag") case (getArg args OptionFlagString) of Just s -> putStrLn ("saw string " ++ s) Nothing -> return () case (getArg args OptionFlagInt) of Just d -> putStrLn ("saw int " ++ (show (d::Int))) Nothing -> return () case (getArg args OptionPreoptional) of Just s -> putStrLn ("saw pre-optional " ++ s) Nothing -> return () putStrLn ("saw fixed " ++ (fromJust (getArgString args OptionFixed))) case (getArg args OptionOptional) of Just s -> putStrLn ("saw optional " ++ s) Nothing -> return () putStrLn ("saw rest: " ++ show (argsRest args)) parseargs-0.2.0.7/README.md0000644000000000000000000000456112726173661013333 0ustar0000000000000000# parseargs: Command-line argument parsing for Haskell programs Copyright (c) 2007 Bart Massey This library provides System.Console.Parseargs, a module to assist in argument parsing for Haskell stand-alone command line programs. The package provides a Haskell command-line argument "parser". You supply a specification of the arguments to your command-line program; `parseargs` reads the arguments and checks that they meet your spec. It then fills in a data structure that captures the relevant data, from which parsed arguments can be extracted as needed. See the Haddock documentation for the gory details. I have used this code with `ghc` 6 and later on Linux. It is a fairly standard Hackage-ready package, to the extent I know how to construct such. This library is not what I set out to build. It definitely could also use some work. However, I use it all the time for writing little programs. I thought others might find it useful, and I also have released other code that depends on it, so I put it out there. Have fun with it, and let me know if there are problems. ## Release History * The 0.1.2 release includes a typeclass for argument types for easier use. * The 0.1.3 release includes more uniform and usable error handling. * The various 0.1.3.x point releases include bug fixes and various extra-minor enhancements. See the Git log. * The 0.1.4 release includes the ability to mix optional and required positional arguments. * The 0.1.5 release includes the "soft dash" option, giving the ability to allow positional arguments to begin with a dash if possible. * The 0.1.5.1 release fixes some warnings and stuff. * The 0.1.5.2 release fixes some missing documentation. * The 0.2 release cleans up some namespace pollution by removing `ArgRecord` and the `args` accessor from the public namespace. This allows the use of the name `args` by the user to describe program arguments. * The 0.2.0.1 release cleans up a bunch of documentation nits and cleans up copyright notices and license information. * The 0.2.0.2 release fixes the botched release of 0.2.0.1. Sigh. * The 0.2.0.3 release fixes the missing `Args` constructor documentation of 0.2.0.2. * The 0.2.0.4 release suppresses a GHC 7.10 warning for `Control.Monad.Safe`. ## License This program is licensed under the "3-clause ('new') BSD License". Please see the file COPYING in this distribution for license terms. parseargs-0.2.0.7/test-parseargs.hs0000644000000000000000000000035712726173661015353 0ustar0000000000000000-- Stupid glue for "cabal test" -- http://stackoverflow.com/a/31214045/364875 import System.Exit import System.Process main = do result <- system "./test-parseargs.sh" case result of ExitSuccess -> return () _ -> exitFailure parseargs-0.2.0.7/Setup.hs0000644000000000000000000000005612726173661013503 0ustar0000000000000000import Distribution.Simple main = defaultMain parseargs-0.2.0.7/COPYING0000644000000000000000000000304712726173661013105 0ustar0000000000000000Copyright © 2007 Bart Massey [This program is licensed under the "3-clause ('new') BSD License"] Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holders nor the names of contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. parseargs-0.2.0.7/parseargs.cabal0000644000000000000000000000256012726173661015024 0ustar0000000000000000-- Copyright © 2010 Bart Massey -- This work is licensed under the "3-clause ('new') BSD License". -- Please see the file COPYING in this distribution for license terms. Name: parseargs Build-Type: Simple Description: Parse command-line arguments -- Don't forget to bump the source-repository this below Version: 0.2.0.7 Cabal-Version: >= 1.8 License: BSD3 License-File: COPYING Author: Bart Massey Copyright: Copyright (c) 2007 Bart Massey Maintainer: Bart Massey Homepage: http://github.com/BartMassey/parseargs Category: Console Synopsis: Full-featured command-line argument parsing library. Extra-Source-Files: README.md test-parseargs.sh tests/*.in tests/*.out Tested-With: GHC >= 6 && < 8.1 Library Build-Depends: base < 5, containers < 1 Exposed-Modules: System.Console.ParseArgs GHC-Options: -Wall Executable parseargs-example Build-Depends: base < 5, containers < 1 Main-Is: parseargs-example.hs Other-Modules: System.Console.ParseArgs GHC-Options: -Wall Test-Suite test-parseargs Type: exitcode-stdio-1.0 Main-Is: test-parseargs.hs build-depends: base < 5, process < 2 Source-repository head Type: git Location: git://github.com/BartMassey/parseargs.git Source-repository this Type: git Location: git://github.com/BartMassey/parseargs.git Tag: v0.2.0.7 parseargs-0.2.0.7/tests/0000755000000000000000000000000012726173661013210 5ustar0000000000000000parseargs-0.2.0.7/tests/t3.out0000644000000000000000000000012612726173661014266 0ustar0000000000000000parse successful saw int 7 saw pre-optional x saw fixed y saw optional z saw rest: [] parseargs-0.2.0.7/tests/t1.in0000644000000000000000000000000212726173661014054 0ustar0000000000000000x parseargs-0.2.0.7/tests/t3.in0000644000000000000000000000000612726173661014062 0ustar0000000000000000x y z parseargs-0.2.0.7/tests/t1.out0000644000000000000000000000006412726173661014265 0ustar0000000000000000parse successful saw int 7 saw fixed x saw rest: [] parseargs-0.2.0.7/tests/t2.out0000644000000000000000000000010712726173661014264 0ustar0000000000000000parse successful saw int 7 saw pre-optional x saw fixed y saw rest: [] parseargs-0.2.0.7/tests/t2.in0000644000000000000000000000000412726173661014057 0ustar0000000000000000x y parseargs-0.2.0.7/System/0000755000000000000000000000000012726173661013332 5ustar0000000000000000parseargs-0.2.0.7/System/Console/0000755000000000000000000000000012726173661014734 5ustar0000000000000000parseargs-0.2.0.7/System/Console/ParseArgs.hs0000644000000000000000000007274012726173661017171 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, CPP #-} #if __GLASGOW_HASKELL__ > 720 {-# LANGUAGE Safe #-} #endif ------------------------------------------------------------ -- | -- Module : System.Console.ParseArgs -- Description : Full-featured command-line argument parsing library. -- Copyright : (c) 2007 Bart Massey -- License : BSD-style (see the file COPYING) -- Maintainer : Bart Massey -- Stability : stable -- Portability : portable -- -- `ParseArgs` is a full-featured command-line argument -- parsing library. -- -- This module supplies an argument parser. Given a -- description of type [`Arg`] of the legal arguments to the -- program, a list of argument strings, and a bit of extra -- information, the `parseArgs` function in this module -- returns an `Args` data structure suitable for querying -- using the provided functions `gotArg`, `getArg`, etc. ------------------------------------------------------------ module System.Console.ParseArgs ( -- * Describing allowed arguments -- |The argument parser requires a description of -- the arguments that will be parsed. This is -- supplied as a list of `Arg` records, built up -- using the functions described here. Arg(..), Argtype(..), ArgsComplete(..), ArgsDash(..), APCData(..), ArgsParseControl(..), -- ** DataArg and its pseudo-constructors DataArg, argDataRequired, argDataOptional, argDataDefaulted, -- * Argument processing -- |The argument descriptions are used to parse -- the command line arguments, and the results -- of the parse can later be (efficiently) queried -- to determine program behavior. -- ** Getting parse results -- |The argument parser returns an opaque map -- from argument index to parsed argument data -- (plus some convenience information). Args(..), parseArgs, parseArgsIO, -- ** Using parse results -- |Query functions permit checking for the existence -- and values of command-line arguments. gotArg, ArgType(..), getArgString, getArgFile, getArgStdio, getArgInteger, getArgInt, getArgDouble, getArgFloat, ArgFileOpener(..), -- * Misc ParseArgsException(..), baseName, parseError, usageError, System.IO.IOMode(ReadMode, WriteMode, AppendMode)) where import Control.Exception import Control.Monad import Control.Monad.ST import Data.List import qualified Data.Map as Map import Data.Maybe import Data.Typeable import System.Environment import System.IO -- The main job of this module is to provide parseArgs. -- See below for its contract. -- -- Provided datatypes. -- -- |The description of an argument, suitable for -- messages and for parsing. The `argData` field -- is used both for flags with a data argument, and -- for positional data arguments. -- -- There are two cases: -- -- (1) The argument is a flag, in which case at least -- one of `argAbbr` and `argName` is provided; -- -- (2) The argument is positional, in which case neither -- `argAbbr` nor `argName` are provided, but `argData` is. -- -- If none of `argAbbr`, `argName`, or `argData` are -- provided, this is an error. See also the -- `argDataRequired`, `argDataOptional`, and -- `argDataDefaulted` functions below, which are used to -- generate `argData`. data (Ord a) => Arg a = Arg { argIndex :: a -- ^Connects the input description -- to the output argument. , argAbbr :: Maybe Char -- ^One-character flag name. , argName :: Maybe String -- ^\"Long name\" of flag. , argData :: Maybe DataArg -- ^Datum description. , argDesc :: String -- ^Documentation for the argument. } -- |The types of an argument carrying data. The constructor -- argument is used to carry a default value. -- -- The constructor argument should really be hidden. -- Values of this type are normally constructed within -- the pseudo-constructors pseudo-constructors -- `argDataRequired`, `argDataOptional`, and -- `argDataDefaulted`, to which only the constructor -- function itself is passed. data Argtype = ArgtypeString (Maybe String) | ArgtypeInteger (Maybe Integer) | ArgtypeInt (Maybe Int) | ArgtypeDouble (Maybe Double) | ArgtypeFloat (Maybe Float) -- |Information specific to an argument carrying a datum. This -- is an opaque type, whose instances are constructed using the -- pseudo-constructors `argDataRequired`, `argDataOptional`, -- and `argDataDefaulted`. data DataArg = DataArg { dataArgName :: String -- ^Print name of datum. , dataArgArgtype :: Argtype -- ^Type of datum. , dataArgOptional :: Bool -- ^Datum is not required. } -- |Generate the `argData` for the given non-optional argument. argDataRequired :: String -- ^Datum print name. -> (Maybe a -> Argtype) -- ^Type constructor for datum. -> Maybe DataArg -- ^Result is `argData`-ready. argDataRequired s c = Just (DataArg { dataArgName = s, dataArgArgtype = c Nothing, dataArgOptional = False }) -- |Generate the `argData` for the given optional argument with no default. argDataOptional :: String -- ^Datum print name. -> (Maybe a -> Argtype) -- ^Type constructor for datum. -> Maybe DataArg -- ^Result is `argData`-ready. argDataOptional s c = Just (DataArg { dataArgName = s, dataArgArgtype = c Nothing, dataArgOptional = True }) -- |Generate the `argData` for the given optional argument with the -- given default. argDataDefaulted :: String -- ^Datum print name. -> (Maybe a -> Argtype) -- ^Type constructor for datum. -> a -- ^Datum default value. -> Maybe DataArg -- ^Result is `argData`-ready. argDataDefaulted s c d = Just (DataArg { dataArgName = s, dataArgArgtype = c (Just d), dataArgOptional = True }) -- -- Returned datatypes. -- -- |The \"kinds of values\" an argument can have. data Argval = ArgvalFlag -- ^For simple present vs not-present flags. | ArgvalString String | ArgvalInteger Integer | ArgvalInt Int | ArgvalDouble Double | ArgvalFloat Float -- |The type of the mapping from argument index to value. newtype ArgRecord a = ArgRecord (Map.Map a Argval) -- |The data structure `parseArgs` produces. There is a should-be-hidden -- field that describes the parse. data (Ord a) => Args a = Args { __args :: ArgRecord a -- ^The argument parse, only listed here -- to work around a Haddock bug. See -- . , argsProgName :: String -- ^Basename of 0th argument. , argsUsage :: String -- ^Full usage string. , argsRest :: [ String ] -- ^Remaining unprocessed arguments. } -- -- Exception type. -- -- |This exception is raised with an appropriate error message -- when argument parsing fails. The first argument is the usage -- message, the second the actual error message from the parser. data ParseArgsException = ParseArgsException String String deriving (Eq, Typeable) instance Exception ParseArgsException instance Show ParseArgsException where show (ParseArgsException usage msg) = msg ++ "\n" ++ usage -- -- Implementation. -- -- |True if the described argument is positional. arg_posn :: (Ord a) => Arg a -- ^Argument. -> Bool -- ^True if argument is positional. arg_posn (Arg { argAbbr = Nothing, argName = Nothing }) = True arg_posn _ = False -- |True if the described argument is a flag. arg_flag :: (Ord a) => Arg a -- ^Argument. -> Bool -- ^True if argument is a flag. arg_flag a = not (arg_posn a) -- |True if the described argument is optional. arg_optional :: (Ord a) => Arg a -- ^Argument. -> Bool -- ^False if argument is required to be present. arg_optional (Arg { argData = Just (DataArg { dataArgOptional = b }) }) = b arg_optional _ = True arg_required :: (Ord a) => Arg a -- ^Argument. -> Bool -- ^True if argument is required to be present. arg_required a = not (arg_optional a) -- |Return the value of a defaulted argument. arg_default_value :: (Ord a) => Arg a -- ^Argument. -> Maybe Argval -- ^Optional default value. arg_default_value arg@(Arg { argData = Just (DataArg { dataArgArgtype = da }) }) | arg_optional arg = defval da where defval (ArgtypeString (Just v)) = Just (ArgvalString v) defval (ArgtypeInteger (Just v)) = Just (ArgvalInteger v) defval (ArgtypeInt (Just v)) = Just (ArgvalInt v) defval (ArgtypeDouble (Just v)) = Just (ArgvalDouble v) defval (ArgtypeFloat (Just v)) = Just (ArgvalFloat v) defval _ = Nothing arg_default_value _ = Nothing -- |There's probably a better way to do this. perhaps :: Bool -> String -> String perhaps b s = if b then s else "" -- |Format the described argument as a string. arg_string :: (Ord a) => Arg a -- ^Argument to be described. -> String -- ^String describing argument. arg_string a@(Arg { argAbbr = abbr, argName = name, argData = arg }) = (optionally "[") ++ (sometimes flag_abbr abbr) ++ (perhaps ((isJust abbr) && (isJust name)) ",") ++ (sometimes flag_name name) ++ (perhaps ((arg_flag a) && (isJust arg)) " ") ++ (sometimes data_arg arg) ++ (optionally "]") where sometimes = maybe "" optionally s = perhaps (arg_optional a) s flag_name s = "--" ++ s flag_abbr c = [ '-', c ] data_arg (DataArg {dataArgName = s}) = "<" ++ s ++ ">" -- |Filter out the empty keys for a hash. filter_keys :: [ (Maybe a, b) ] -- ^List of (optional key, value) pairs. -> [ (a, b) ] -- ^Pairs with actual keys. filter_keys l = foldr check_key [] l where check_key (Nothing, _) rest = rest check_key (Just k, v) rest = (k, v) : rest -- |Fail with an error if the argument description is bad -- for some reason. argdesc_error :: String -- ^Error message. -> a -- ^Bogus polymorphic result. argdesc_error msg = error ("internal error: argument description: " ++ msg) -- |Make a keymap. keymap_from_list :: (Ord k, Show k) => [ (k, a) ] -- ^List of key-value pairs. -- Will be checked for duplicate keys. -> Map.Map k a -- ^Key-value map. keymap_from_list l = foldl add_entry Map.empty l where add_entry m (k, a) = case Map.member k m of False -> Map.insert k a m True -> argdesc_error ("duplicate argument description name " ++ (show k)) -- |Make a keymap for looking up a flag argument. make_keymap :: (Ord a, Ord k, Show k) => ((Arg a) -> Maybe k) -- ^Mapping from argdesc to flag key. -> [ Arg a ] -- ^List of argdesc. -> (Map.Map k (Arg a)) -- ^Map from key to argdesc. make_keymap f_field ads = (keymap_from_list . filter_keys . map (\arg -> (f_field arg, arg))) ads -- |How \"sloppy\" the parse is. data ArgsComplete = ArgsComplete -- ^Any extraneous arguments -- (unparseable from description) -- will cause the parser to fail. | ArgsTrailing String -- ^Trailing extraneous arguments are -- permitted, and will be skipped, -- saved, and returned. The -- constructor argument is the -- name of the args. | ArgsInterspersed -- ^All extraneous arguments are -- permitted, and will be skipped, -- saved, and returned. -- |Whether to always treat an unknown argument beginning -- with \"-\" as an error, or to allow it to be used as a -- positional argument when possible. data ArgsDash = ArgsHardDash -- ^If an argument begins with -- a \"-\", it will always be -- treated as an error unless -- it corresponds to a flag description. | ArgsSoftDash -- ^If an argument beginning with -- a \"-\" is unrecognized as a flag, -- treat it as a positional argument -- if possible. Otherwise it is an error. deriving Eq -- |Record containing the collective parse control information. data ArgsParseControl = ArgsParseControl { -- |Level of completeness of parse. apcComplete :: ArgsComplete, -- |Handling of dashes in parse. apcDash :: ArgsDash } -- |Class for building parse control information, -- for backward compatibility. class APCData a where getAPCData :: a -> ArgsParseControl -- ^Build an 'ArgsParseControl' -- structure from the given info. instance APCData ArgsParseControl where getAPCData a = a instance APCData ArgsComplete where getAPCData a = ArgsParseControl a ArgsHardDash -- |The iteration function is given a state and a list, and -- expected to produce a new state and list. The function -- is again invoked with the resulting state and list. When -- the supplied function returns the empty list, this -- function returns the final state produced. exhaust :: (s -> [e] -> ([e], s)) -- ^Function to iterate. -> s -- ^Initial state. -> [e] -- ^Initial list. -> s -- ^Final state. exhaust _ s [] = s exhaust f s l = let (l', s') = f s l in exhaust f s' l' -- |Generate a usage error with the given supplementary message string. parseError :: String -- ^Usage message. -> String -- ^Specific error message. -> a -- ^Bogus polymorphic result. parseError usage msg = throw (ParseArgsException usage msg) -- |Given a description of the arguments, `parseArgs` -- produces a map from the arguments to their \"values\" and -- some other useful byproducts. `parseArgs` requires that -- the argument descriptions occur in the order 1) flag -- arguments, then 2) positional arguments; otherwise a -- runtime error will be thrown. parseArgs :: (Show a, Ord a, APCData b) => b -- ^Configuration for parse. -> [ Arg a ] -- ^Argument descriptions. -> String -- ^Full program pathname. -> [ String ] -- ^Incoming program argument list. -> Args a -- ^Outgoing argument parse results. parseArgs apcData argd pathname argv = runST (do check_argd let (flag_args, posn_args) = span arg_flag argd let name_hash = make_keymap argName flag_args let abbr_hash = make_keymap argAbbr flag_args let prog_name = baseName pathname let usage = make_usage_string prog_name let (am, _, rest) = exhaust (parse usage name_hash abbr_hash) (Map.empty, posn_args, []) argv let required_args = filter (not . arg_optional) argd unless (and (map (check_present usage am) required_args)) (error "internal error") let am' = foldl supply_defaults am argd return (Args { __args = ArgRecord am', argsProgName = prog_name, argsUsage = usage, argsRest = rest })) where supply_defaults am ad@(Arg { argIndex = k }) = case Map.lookup k am of Just _ -> am Nothing -> case arg_default_value ad of Just v -> Map.insert k v am Nothing -> am check_present usage am ad@(Arg { argIndex = k }) = case Map.lookup k am of Just _ -> True Nothing -> parseError usage ("missing required argument " ++ (arg_string ad)) --- Check for various possible misuses. check_argd :: ST s () check_argd = do --- Order must be flags, then posn args let (_, posns) = span arg_flag argd unless (all arg_posn posns) (argdesc_error "argument description mixes flags and positionals") --- No argument may be "nullary". when (or (map arg_nullary argd)) (argdesc_error "bogus 'nothing' argument") return () where arg_nullary (Arg { argName = Nothing, argAbbr = Nothing, argData = Nothing }) = True arg_nullary _ = False --- Generate a usage message string make_usage_string prog_name = summary_line ++ arg_lines where flag_args = filter arg_flag argd posn_args = filter arg_posn argd n = maximum (map (length . arg_string) argd) --- top (summary) line summary_line = "usage: " ++ prog_name ++ perhaps (not (null flag_args)) " [options]" ++ perhaps (not (null posn_args)) (" " ++ unwords (map arg_string posn_args)) ++ (case apcComplete $ getAPCData apcData of ArgsComplete -> "" ArgsTrailing s -> " [--] [" ++ s ++ " ...]" ArgsInterspersed -> " ... [--] ...") ++ "\n" --- argument lines arg_lines = concatMap (arg_line n) argd where arg_line na a = let s = arg_string a in " " ++ s ++ replicate (na - (length s)) ' ' ++ " " ++ argDesc a ++ "\n" --- simple recursive-descent parser parse _ _ _ av@(_, _, []) [] = ([], av) parse usage _ _ av [] = case apcComplete $ getAPCData apcData of ArgsComplete -> parseError usage "unexpected extra arguments" _ -> ([], av) parse usage name_hash abbr_hash (am, posn, rest) av@(aa : aas) = case aa of "--" -> case getAPCData apcData of ArgsParseControl ArgsComplete ArgsHardDash -> parseError usage ("unexpected -- " ++ "(extra arguments not allowed)") _ -> ([], (am, posn, (rest ++ aas))) s@('-' : '-' : name) | isJust (Map.lookup name name_hash) || apcDash (getAPCData apcData) == ArgsHardDash -> case Map.lookup name name_hash of Just ad -> let (args', am') = peel s ad aas in (args', (am', posn, rest)) Nothing -> case getAPCData apcData of ArgsParseControl ArgsInterspersed _ -> (aas, (am, posn, rest ++ ["--" ++ name])) _ -> parseError usage ("unknown argument --" ++ name) ('-' : abbr : abbrs) | isJust (Map.lookup abbr abbr_hash) || apcDash (getAPCData apcData) == ArgsHardDash -> case Map.lookup abbr abbr_hash of Just ad -> let (args', am') = peel ['-', abbr] ad aas state' = (am', posn, rest) in case abbrs of [] -> (args', state') ('-' : _) -> parseError usage ("bad internal '-' in argument " ++ aa) _ -> (['-' : abbrs] ++ args', state') Nothing -> case apcComplete $ getAPCData apcData of ArgsInterspersed -> (aas, (am, posn, rest ++ ['-' : abbr : abbrs])) _ -> parseError usage ("unknown argument -" ++ [abbr]) _ -> case posn of (p : ps) -> let (_, req_posn) = partition arg_optional posn in case length av - length req_posn of n_extra | n_extra > 0 || (n_extra == 0 && arg_required p) -> let (args', am') = peel (dataArgName $ fromJust $ argData p) p av in (args', (am', ps, rest)) 0 -> (av, (am, ps, rest)) _ -> parseError usage "missing required positional argument(s)" [] -> ([], (am, [], rest ++ av)) where add_entry s m (k, a) = case Map.member k m of False -> Map.insert k a m True -> parseError usage ("duplicate argument " ++ s) peel name (Arg { argData = Nothing, argIndex = index }) argl = let am' = add_entry name am (index, ArgvalFlag) in (argl, am') peel name (Arg { argData = Just (DataArg {}) }) [] = parseError usage (name ++ " is missing its argument") peel name (Arg { argData = Just (DataArg { dataArgArgtype = atype }), argIndex = index }) (a : argl) = let v = case atype of ArgtypeString _ -> ArgvalString a ArgtypeInteger _ -> read_arg ArgvalInteger "an integer" ArgtypeInt _ -> read_arg ArgvalInt "an int" ArgtypeDouble _ -> read_arg ArgvalDouble "a double" ArgtypeFloat _ -> read_arg ArgvalFloat "a float" where read_arg constructor kind = case reads a of [(val, "")] -> constructor val _ -> parseError usage ("argument " ++ a ++ " to " ++ name ++ " is not " ++ kind) am' = add_entry name am (index, v) in (argl, am') -- |Most of the time, you just want the environment's -- arguments and are willing to live in the IO monad. -- This version of `parseArgs` digs the pathname and arguments -- out of the system directly. parseArgsIO :: (Show a, Ord a, APCData b) => b -- ^Degree of completeness of parse. -> [ Arg a ] -- ^Argument descriptions. -> IO (Args a) -- ^Argument parse results. parseArgsIO apcData argd = do argv <- getArgs pathname <- getProgName return (parseArgs apcData argd pathname argv) -- |Check whether a given optional argument was supplied. Works on all types. gotArg :: (Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be checked for. -> Bool -- ^True if the arg was present. gotArg (Args { __args = ArgRecord am }) k = case Map.lookup k am of Just _ -> True Nothing -> False -- |Type of values that can be parsed by the argument parser. class ArgType b where -- |Fetch an argument's value if it is present. getArg :: (Show a, Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be retrieved. -> Maybe b -- ^Argument value if present. -- |Fetch the value of a required argument. getRequiredArg :: (Show a, Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be retrieved. -> b -- ^Argument value. getRequiredArg ads index = case getArg ads index of Just v -> v Nothing -> error ("internal error: required argument " ++ show index ++ "not supplied") getArgPrimitive :: Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b getArgPrimitive decons (Args { __args = ArgRecord am }) k = Map.lookup k am >>= decons instance ArgType () where getArg = getArgPrimitive flagArg where flagArg ArgvalFlag = return () flagArg _ = error "internal error: flag arg at wrong type" instance ArgType ([] Char) where getArg = getArgPrimitive stringArg where stringArg (ArgvalString s) = return s stringArg _ = error "internal error: string arg at wrong type" -- |[Deprecated] Return the `String` value, if any, of the given argument. getArgString :: (Show a, Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be retrieved. -> Maybe String -- ^Argument value if present. getArgString = getArg instance ArgType Integer where getArg = getArgPrimitive integerArg where integerArg (ArgvalInteger i) = return i integerArg _ = error "internal error: integer arg at wrong type" -- |[Deprecated] Return the `Integer` value, if any, of the given argument. getArgInteger :: (Show a, Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be retrieved. -> Maybe Integer -- ^Argument value if present. getArgInteger = getArg instance ArgType Int where getArg = getArgPrimitive intArg where intArg (ArgvalInt i) = return i intArg _ = error "internal error: int arg at wrong type" -- |[Deprecated] Return the `Int` value, if any, of the given argument. getArgInt :: (Show a, Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be retrieved. -> Maybe Int -- ^Argument value if present. getArgInt = getArg instance ArgType Double where getArg = getArgPrimitive doubleArg where doubleArg (ArgvalDouble d) = return d doubleArg _ = error "internal error: double arg at wrong type" -- |[Deprecated] Return the `Double` value, if any, of the given argument. getArgDouble :: (Show a, Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be retrieved. -> Maybe Double -- ^Argument value if present. getArgDouble = getArg instance ArgType Float where getArg = getArgPrimitive floatArg where floatArg (ArgvalFloat f) = return f floatArg _ = error "internal error: float arg at wrong type" -- |[Deprecated] Return the `Float` value, if any, of the given argument. getArgFloat :: (Show a, Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be retrieved. -> Maybe Float -- ^Argument value if present. getArgFloat = getArg -- |`ArgType` instance for opening a file from its string name. newtype ArgFileOpener = ArgFileOpener { argFileOpener :: IOMode -> IO Handle -- ^Function to open the file } instance ArgType ArgFileOpener where getArg ads index = getArg ads index >>= (\s -> return $ ArgFileOpener { argFileOpener = openFile s }) -- |[Deprecated] Treat the `String` value, if any, of the given argument as -- a file handle and try to open it as requested. getArgFile :: (Show a, Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be retrieved. -> IOMode -- ^IO mode the file should be opened in. -> IO (Maybe Handle) -- ^Handle of opened file, if the argument -- was present. getArgFile ads k m = case getArg ads k of Just fo -> (do h <- argFileOpener fo m; return (Just h)) Nothing -> return Nothing -- |Treat the `String` value, if any, of the given argument as a -- file handle and try to open it as requested. If not -- present, substitute the appropriate one of stdin or -- stdout as indicated by `IOMode`. getArgStdio :: (Show a, Ord a) => Args a -- ^Parsed arguments. -> a -- ^Index of argument to be retrieved. -> IOMode -- ^IO mode the file should be opened in. -- Must not be `ReadWriteMode`. -> IO Handle -- ^Appropriate file handle. getArgStdio ads k m = case getArg ads k of Just s -> openFile s m Nothing -> case m of ReadMode -> return stdin WriteMode -> return stdout AppendMode -> return stdout ReadWriteMode -> error ("internal error: tried to open stdio " ++ "in ReadWriteMode") --- --- Misc --- -- |Return the filename part of a pathname. -- Unnecessarily efficient implementation does a single -- tail-call traversal with no construction. baseName :: String -- ^Pathname. -> String -- ^Rightmost component of pathname. baseName s = let s' = dropWhile (/= '/') s in if null s' then s else baseName (tail s') -- |Generate a usage error with the given supplementary message string. usageError :: (Ord a) => Args a -> String -> b usageError ads msg = error (argsUsage ads ++ "\n" ++ msg)