hsshellscript-3.1.0: src/HsShellScript/Args.hs
-- |
-- This module provides a more convient way of parsing command line
-- arguments than the GHC GetOpt package. It makes use of GetOpt, but hides
-- it from the user. It is reexported from module HsShellScript.
--
-- For each command line argument, a description is to be created with
-- @argdesc@. Then the command line arguments are evaluated with
-- one of the @getargs@... functions. In case of an error, this will cause a
-- exception, which provides an expressive error message to be
-- printed. Then the @arg@... functions are used to extract the
-- values contained in the arguments, with the right type. The typical use
-- of HsShellScript.Args looks something like this:
--
-- >import HsShellScript
-- >
-- >main =
-- > do let a_onevalue = argdesc [ desc_at_most_once, ... ]
-- > a_values = argdesc [ desc_direct, ... ]
-- > a_switch = argdesc [ ... ]
-- > ...
-- > header = "mclapep - My Command Line Argument Parser Example Program, version 1.0.0"
-- >
-- > args <- getargs header [a_onevalue, a_values, a_switch, ...]
-- >
-- > val <- optarg_req a_onevalue args -- val :: Maybe String
-- > vals <- args_req a_values args -- vals :: [String]
-- > doit <- arg_switch a_switch args -- doit :: Bool
-- > ...
-- > `catch`
-- > (\argerror -> do
-- > hPutStrLn stderr $ (argerror_message argerror) ++ "\n\n" ++ (argerror_usageinfo argerror)
-- > exitFailure
-- > )
--
-- Errors in the argument descriptions are regarded as bugs, and handled
-- by aborting the program with a message which is meaningful to the
-- programmer. It is assumed that the argument description is a constant for
-- a given program.
--
-- Errors in the arguments are reported using HsShellScript's error handling
-- scheme. An error description
-- value is generated, and either returned via an @Either@
-- value, or thrown as an exception.
module HsShellScript.Args ( -- ** Argument Properties
ArgumentProperty
, ArgumentDescription (..)
, ArgumentValueSpec (..)
, Argtester
, argdesc
, desc_short
, desc_long
, desc_direct
, desc_value_required
, desc_value_optional
, desc_times
, desc_once
, desc_at_least_once
, desc_at_most_once
, desc_any_times
, desc_at_least
, desc_at_most
, desc_argname
, desc_description
, desc_tester
, desc_integer
, desc_nonneg_integer
, readtester
-- ** Evaluating the Command Line
, Arguments
, getargs
, getargs_ordered
, getargs'
, getargs_ordered'
, unsafe_getargs
, unsafe_getargs_ordered
-- ** Extracting the Argument Values
, arg_switch
, arg_times
, args_opt
, args_req
, reqarg_opt
, reqarg_req
, optarg_opt
, optarg_req
, arg_occurs
-- ** Placing additional Constraints on the Arguments
, args_none
, args_all
, args_one
, args_at_most_one
, args_at_least_one
, arg_conflicts
-- ** Argument Error Reporting
, ArgError (..)
, usage_info
, argname
, argname_a
) where
-- We use a fixed copy of GHC's GetOpt implementation. This is to work around a bug.
-- import System.Console.GetOpt
import HsShellScript.GetOpt
import Control.Monad
import Control.Exception
import Prelude hiding (catch)
import Data.Maybe
import System.Environment
import Data.List
import GHC.IO
import System.IO
import HsShellScript.Shell
import Data.Char
import Debug.Trace
import Data.Typeable
-- | Does the command line argument take an value?
data ArgumentValueSpec = ArgumentValue_none -- ^ No value
| ArgumentValue_required -- ^ Value required
| ArgumentValue_optional -- ^ Value optional
deriving (Eq, Show, Ord)
-- | Argument value tester function. This tests the format of an argument's value for errors. The tester function is specified by
-- 'desc_tester' or such, as part of the argument description.
--
-- The tester is passed the argument value. If the format is correct, then it returns @Nothing@. If there is an error, then it returns @Just msgf@,
-- with @msgf@ being an error message generation function. This function gets passed the argument description, and produces the error
-- message. The argument description typically is used to extract a descriptive name of the argument (using 'argname' or 'argname_a') to be included
-- in the error message.
type Argtester = String -- Argument value to be tested
-> Maybe (ArgumentDescription -- Argument description for message generation
-> String -- Error message
)
-- | Description of one command line argument. These are generated by
-- @argdesc@ from a list of argument properties, and subsequently used by one of the
-- @getargs@... functions. This type is abstract.
data ArgumentDescription = ArgumentDescription {
argdesc_short_args :: [Char], -- ^ Short option names
argdesc_long_args :: [String], -- ^ Long option names
argdesc_argarg :: ArgumentValueSpec, -- ^ What about a possible value of the argument?
argdesc_times :: Maybe (Int,Int), -- ^ Minimum and maximum of number of occurences allowed
argdesc_argargname :: Maybe String, -- ^ Name for argument's value, for message generation
argdesc_argarg_description :: Maybe String, -- ^ Descrition of the argument, for message generation
argdesc_argarg_tester :: Maybe Argtester -- ^ Argument value tester
}
-- excluding tester
ad_tup ad =
(argdesc_short_args ad, argdesc_long_args ad, argdesc_argarg ad, argdesc_times ad, argdesc_argargname ad, argdesc_argarg_description ad)
instance Eq ArgumentDescription where
d == e = ad_tup d == ad_tup e
instance Ord ArgumentDescription where
compare d e = compare (ad_tup d) (ad_tup e)
-- value for maximum number of times
unlimited = -1
-- Whether two argument descriptions describe the same argument.
-- Every short or long argument name occurs in only one argument
-- descriptor (this is checked). Every argument has a short or a long
-- name (short = [], long = [""] for direct arguments).
same_arg :: ArgumentDescription -> ArgumentDescription -> Bool
same_arg arg1 arg2 =
case (argdesc_short_args arg1, argdesc_short_args arg2) of
(a:_, b:_) -> a == b
([], []) -> case (argdesc_long_args arg1, argdesc_long_args arg2) of
([],_) -> unnamed
(_,[]) -> unnamed
(l1,l2) -> head l1 == head l2
_ -> False
where unnamed = error "Bug in argument description: nameless, non-direct argument. desc_short or desc_long must be specified."
-- | A property of a command line argument. These are generated by the
-- @desc_@... functions, and condensed to argument
-- descriptions of type @ArgumentDescription@ by @argdesc@. This type is abstract.
newtype ArgumentProperty =
ArgumentProperty { argumentproperty :: ArgumentDescription -> ArgumentDescription }
-- An argument property is a function which fills in part of an argument descriptor.
-- starting value for argument descriptor
nulldesc :: ArgumentDescription
nulldesc =
ArgumentDescription {
argdesc_short_args = [],
argdesc_long_args = [],
argdesc_argarg = ArgumentValue_none,
argdesc_times = Nothing, -- default = (0,1)
argdesc_argargname = Nothing,
argdesc_argarg_description = Nothing,
argdesc_argarg_tester = Nothing
}
-- default number of times an argument may occur
times_default = (0,1)
-- | This represents the parsed contents of the command line. It is returned
-- by the @getargs@... functions, and passed on to the
-- value extraction functions by the user.
--
-- See 'getargs', 'getargs_ordered', 'getargs\'', 'getargs_ordered\''.
newtype Arguments =
Arguments ( [ ( ArgumentDescription -- argument descriptor
, [Maybe String] -- arguments matching this descriptor
)
]
, String -- usage information
)
argvalues :: Arguments -> ArgumentDescription -> [Maybe String]
argvalues (Arguments (l,_)) desc =
argvalues' l
where
argvalues' ((d,v):r) = if same_arg desc d then v else argvalues' r
argvalues' [] = abort "Bug using HsShellScript: Value of unknown argument queried (add it to getarg's list)" desc
-- used internally to represent one occurence of a specific argument
type ArgOcc = (ArgumentDescription, Maybe String)
-- | Error thrown when there is an error in the
-- command line arguments.
data ArgError = ArgError {
-- | Error message generated by HsShellScript.Args.
argerror_message :: String,
-- | Usage information derived from the argument descriptions.
argerror_usageinfo :: String
}
deriving (Typeable)
-- |
-- Make @ArgError@ an instance of @Exception@, so we can throw and catch it, using GHC-6.10\'s new exception library.
instance Exception ArgError
---
-- Printing an @ArgError@ will produce the error message. The usage
-- information must be printed separately, using @usage_info@.
instance Show ArgError where
show argerror = argerror_message argerror
-- Whether it is the description for direct arguments. Direct arguments are
-- the ones without introducing "-" or "--".
is_direct :: ArgumentDescription -> Bool
is_direct desc =
argdesc_short_args desc == [] && argdesc_long_args desc == [""]
-- |
-- Short name of the argument. This specifies a character for a
-- one letter style argument, like @-x@. There can be specified
-- several for the same argument. Each argument needs at least
-- either a short or a long name.
desc_short :: Char -- ^ The character to name the argument.
-> ArgumentProperty -- ^ The corresponding argument property.
desc_short c = ArgumentProperty
(\desc ->
if (c `elem` (argdesc_short_args desc))
then abort ("Bug in HsShellScript argument description: Duplicate short argument " ++ show c ++ " specified") desc
else if ("" `elem` argdesc_long_args desc)
then abort_conflict "" desc
else desc { argdesc_short_args = c : argdesc_short_args desc }
)
-- |
-- Long name of the argument. This specifies a GNU style long
-- name for the argument, like @--arg@ or @--arg=...@. There can be specified
-- several names for the same argument. Each argument needs at least
-- either a short or a long name.
desc_long :: String -- ^ The long name of the argument.
-> ArgumentProperty -- ^ The corresponding argument property.
desc_long str = ArgumentProperty
(\desc ->
if (str `elem` (argdesc_long_args desc))
then abort ("Bug in HsShellScript argument description: Duplicate long argument " ++ show str ++ " specified") desc
else if ("" `elem` argdesc_long_args desc)
then abort_conflict "" desc
else desc { argdesc_long_args = str : argdesc_long_args desc }
)
-- |
-- Signal that this is the description of direct arguments. Direct arguments
-- are the ones not introduced by any short or long argument names (like
-- @-x@ or @--arg@), or which occur after the special
-- argument @--@. The presence of @desc_direct@ in the argument properties list
-- signals @argdesc@ that this is the description of the direct
-- arguments. There may be at most one such description.
desc_direct :: ArgumentProperty
desc_direct = ArgumentProperty
(\desc ->
if argdesc_long_args desc == [] && argdesc_short_args desc == [] && argdesc_argarg desc == ArgumentValue_none
then desc { argdesc_long_args = [""], argdesc_argarg = ArgumentValue_required, argdesc_argargname = Just "" }
else abort_conflict "desc_direct conflicts desc_long, desc_short, desc_value_required and desc_value_optional." desc
)
-- |
-- Signal that the argument requires a value.
desc_value_required :: ArgumentProperty
desc_value_required = ArgumentProperty
(\desc ->
if argdesc_argarg desc == ArgumentValue_none
then desc { argdesc_argarg = ArgumentValue_required }
else abort_conflict "desc_value_required repeated or conflicting desc_value_optional" desc
)
-- |
-- Signal that the argument optionally has a value. The user may or may
-- not specify a value to this argument.
desc_value_optional :: ArgumentProperty
desc_value_optional = ArgumentProperty
(\desc ->
if argdesc_argarg desc == ArgumentValue_none
then desc { argdesc_argarg = ArgumentValue_optional }
else abort_conflict "desc_value_optional repeated or conflicting desc_value_required" desc
)
-- |
-- Specify lower and upper bound on the number of times an argument may
-- occur.
desc_times :: Int -- ^ Lower bound of the allowed number of argdesc_times.
-> Int -- ^ Upper bound of the allowed number of argdesc_times.
-> ArgumentProperty -- ^ The corresponding argument property.
desc_times n m = ArgumentProperty
(\desc ->
if argdesc_times desc == Nothing
then desc { argdesc_times = Just (n,m) }
else abort_conflict "desc_times conflicting previous number of occurences specification" desc
)
-- |
-- Signal that the argument must be present exactly once. This is
-- meaningful only for arguments which can take a value.
desc_once :: ArgumentProperty -- ^ The corresponding argument property.
desc_once = desc_times 1 1
-- |
-- Signal that the argument must occur at least one time.
desc_at_least_once :: ArgumentProperty -- ^ The corresponding argument property.
desc_at_least_once = desc_times 1 unlimited
-- |
-- Signal that the argument must occur at most one time.
desc_at_most_once :: ArgumentProperty -- ^ The corresponding argument property.
desc_at_most_once = desc_times 0 1
-- |
-- Signal that the argument must have at least the specified number of
-- occurences, and has no upper limit of occurences.
desc_at_least :: Int -- ^ Number of times.
-> ArgumentProperty -- ^ The corresponding argument property.
desc_at_least n = desc_times n unlimited
-- |
-- Signal that the argument may occur any number of times.
desc_any_times :: ArgumentProperty -- ^ The corresponding argument property.
desc_any_times = desc_times 0 unlimited
-- |
-- Signal that the argument does not need to be present, and may occur at most
-- the specified number of times.
desc_at_most :: Int -- ^ Number of times.
-> ArgumentProperty -- ^ The corresponding argument property.
desc_at_most n = desc_times 0 n
-- |
-- Specify the descriptive name for command line argument's value. Used for the
-- generation of the usage message. The name should be very short.
desc_argname :: String -- ^ Name of the argument's value.
-> ArgumentProperty -- ^ The corresponding argument property.
desc_argname name = ArgumentProperty
(\desc ->
if argdesc_argargname desc == Nothing
then desc { argdesc_argargname = Just name }
else abort "Bug in HsShellScript argument description: Multiple names specified" desc
)
-- |
-- Specify a short description of what the argument does. Used for the
-- generation of the usage message. This is to fit on one line, after the
-- short and long argument names. It should be 40 characters long or so.
desc_description :: String -- ^ Short description of the argument.
-> ArgumentProperty -- ^ The corresponding argument property.
desc_description expl = ArgumentProperty
(\desc ->
if argdesc_argarg_description desc == Nothing
then desc { argdesc_argarg_description = Just expl }
else abort "Bug in HsShellScript argument description: Multiple explanations specified" desc
)
-- | Specify a tester for this argument. The tester is a function which tests the argument value for format errors. Typically, it tests whether the
-- value can be parsed to some target type. If the test fails, the tester produces an error message. When parsing the command line arguments (which
-- @getargs@ or related), all the testers are applied to the respective argument values, and an 'ArgError' is thrown in case of failure. By using a
-- tester, it can be ensured that the argument values abide a specific format when extracting them, such that they can be parsed without errors, e.g.
-- @myarg = read (reqarg_req args d_myarg)@.
--
-- An argument tester is a function of type 'Argtester'.
--
-- See 'readtester', 'desc_integer', 'desc_nonneg_integer', 'Argtester'.
desc_tester :: Argtester -- ^ Argument tester to apply to this argument
-> ArgumentProperty -- ^ The corresponding argument property.
desc_tester t = ArgumentProperty
(\desc ->
case argdesc_argarg_tester desc of
Nothing -> desc { argdesc_argarg_tester = Just t }
Just _ -> abort "Bug in HsShellScript argument description: Multiple argument value testers specified" desc
)
-- |
-- Build an argument tester from a @reads@ like function. Typically, a specialisation of the standard prelude function @read@ is used.
-- Example: @readtester \"Integer expected.\" (reads :: ReadS Int)@
readtester :: ReadS a -- Reader function, like the standard prelude function @reads@
-> String -- Additional message
-> Argtester -- Argument tester to be passed to 'desc_tester'
readtester reader msg val =
case filter ((== "") . snd) $ reader val of
[(_,"")] -> Nothing
[] -> Just (\arg -> "Format error in the value of the " ++ argname_a arg ++ ". " ++ msg ++ "\nValue: " ++ quote val)
_ -> Just (\arg -> "Ambigious value of the " ++ argname_a arg ++ ". " ++ msg ++ "\nValue: " ++ quote val)
{- | Specify that the value of this argument, if present, is a positive integer. This will cause an error when the command line is parsed, and the
argument's value doesn't specify an integer.
>desc_integer = desc_tester (readtester (reads :: ReadS Int) "Integer expected.")
See 'desc_tester'.
-}
desc_integer :: ArgumentProperty
desc_integer = desc_tester (readtester (reads :: ReadS Int) "Integer expected.")
{- | Specify that the value of this argument, if present, is a non-negative integer. This will cause an error when the command line is parsed, and the
value doesn't specify a non-negative integer.
>desc_nonneg_integer = desc_tester (readtester ((filter (\(a,_) -> a >= 0) . reads) :: ReadS Int) "Non-negative integer expected." )
See 'desc_tester'.
-}
desc_nonneg_integer :: ArgumentProperty
desc_nonneg_integer = desc_tester (readtester ((filter (\(a,_) -> a >= 0) . reads) :: ReadS Int) "Non-negative integer expected." )
abort_conflict msg = abort ("Conflicting properties in argument description. " ++ msg)
abort msg desc = error (msg ++ "\nargument (so far): " ++ argname desc)
-- | Generate a descriptive argument name from an argument description, suitable for use in error messages. This uses the long and short argument names
-- (as specified by 'desc_short' and 'desc_long') and generates descriptive names of the argument like \"-f\", \"-myflag\", \"-f\/--myflag\", etc. All the
-- argument names are included. In case of direct arguments (see 'desc_direct'), the descriptive name is \"@(direct argument)@\".
argname :: ArgumentDescription -> String
argname desc =
if (argdesc_short_args desc, argdesc_long_args desc) == ([],[""]) then "(direct argument)"
else if (argdesc_short_args desc, argdesc_long_args desc) == ([],[]) then "yet unnamed argument"
else concat (intersperse "/" ( map (\s -> "-"++[s]) (argdesc_short_args desc) ++ map ("--" ++) (argdesc_long_args desc) ))
-- | Generate a descriptive argument name from an argument description, beginning with \"argument\". This uses the long and short argument names (as
-- specified by 'desc_short' and 'desc_long') and generates descriptive names of the argument like \"argument -f\", \"argument -myflag\", \"argument
-- -f\/--myflag\", etc. All the argument names are included. In case of direct arguments (see 'desc_direct'), the descriptive name is \"direct argument\".
argname_a :: ArgumentDescription -> String
argname_a desc =
if (argdesc_short_args desc, argdesc_long_args desc) == ([],[""]) then "direct argument"
else if (argdesc_short_args desc, argdesc_long_args desc) == ([],[]) then "yet unnamed argument"
else "argument " ++ concat (intersperse "/" ( map (\s -> "-"++[s]) (argdesc_short_args desc) ++ map ("--" ++) (argdesc_long_args desc) ))
up1 "" = ""
up1 (x:xs) = toUpper x : xs
-- complete generation of argument description
prop_final :: ArgumentProperty
prop_final = ArgumentProperty
(\desc ->
seq (if argdesc_argarg desc /= ArgumentValue_none && argdesc_argargname desc == Nothing
then error $ "Bug in description of " ++ argname_a desc ++ ": Argument's value must be given a name using desc_argname."
else if argdesc_argarg desc == ArgumentValue_none && argdesc_argargname desc /= Nothing
then error $ "Bug in description of " ++ argname_a desc
++ ": Argument doesn't take a sub argument, but a name for it is specified."
else ()
) $
desc { argdesc_times = Just (fromMaybe times_default (argdesc_times desc))
, argdesc_argarg_description = Just (fromMaybe "" (argdesc_argarg_description desc))
}
)
-- |
-- Make an argument description from a list of argument properties. This
-- condenses the list to an argument description,
-- which can be uses by the @getargs@... functions and the
-- argument value extraction functions.
argdesc :: [ArgumentProperty] -- ^ List of properties, which describe the command line argument.
-> ArgumentDescription -- ^ The corresponding argument description.
argdesc propl =
foldr (.) id (map argumentproperty (prop_final:propl)) nulldesc
-- Parse command line arguments.
getargs0 :: String -> ArgOrder ArgOcc -> [String] -> [ArgumentDescription] -> Either ArgError Arguments
getargs0 header ordering cmdlargs descs =
let ( descs_direct -- direct arguments (without argument name)
, descs_regular -- regular arguments (with long or short argument name)
) = partition is_direct descs
nonunique :: Eq a => [a] -> Maybe a
nonunique (a:b:r) = if (a == b) then (Just a) else nonunique (b:r)
nonunique _ = Nothing
test_unique :: (Show a, Ord a) => (ArgumentDescription -> [a]) -> String -> b -> b
test_unique extr what x =
case nonunique (sort (concat (map extr descs))) of
Just y -> error ("Bug: Several occurences of " ++ what ++ " " ++ show y ++ " in command line argument specifications")
Nothing -> x
optdescr = map make_optdescr descs_regular
make_optdescr :: ArgumentDescription -> OptDescr ArgOcc
make_optdescr desc =
Option (argdesc_short_args desc)
(argdesc_long_args desc)
(case argdesc_argarg desc of
ArgumentValue_none -> NoArg (desc, Nothing)
ArgumentValue_required -> ReqArg (\arg -> (desc, Just arg))
(fromJust (argdesc_argargname desc))
ArgumentValue_optional -> OptArg (\arg -> (desc, arg))
(fromJust (argdesc_argargname desc))
)
(fromJust (argdesc_argarg_description desc))
-- Postprocessing after successful call to getOpt
getopt_post :: [ArgOcc] -> [String] -> Either ArgError Arguments
getopt_post pars{-getOpt recognized arguments-} rest{-direct arguments-} =
case (rest, descs_direct) of
([],[]) ->
-- no direct arguments allowed and none provided
getopt_post' pars
(r, [d]) ->
-- direct arguments allowed and expected
getopt_post' (pars ++ zip (repeat d) (map Just r))
((x:xs), []) ->
-- direct arguments provided, but not allowed
Left (ArgError "Surplus arguments." usageinfo)
_ ->
-- several descriptions for direct arguments
error "Bug in argument descriptions: Several descriptions for direct arguments (desc_direct) specified."
add :: (ArgumentDescription, Maybe String) -> [(ArgumentDescription, [Maybe String])] -> [(ArgumentDescription, [Maybe String])]
add (a,str) [] = [(a,[str])]
add (b,str) ((a,l):r) =
if same_arg a b then (a,str:l) : r
else (a,l) : add (b,str) r
getopt_post' :: [ArgOcc] -> Either ArgError Arguments
getopt_post' pars{-all arguments-} =
let pars' = foldr add (map (\d -> (d,[])) descs) pars
-- Check the number of argument occurences
check_num :: [(ArgumentDescription, [Maybe String])] -> Maybe ArgError
check_num [] = Nothing
check_num ((desc,args):rest) =
let (min,max) = fromJust (argdesc_times desc)
number = length args
wrong_number_msg =
(if is_direct desc then fst else snd) $
if number == 0 && min == 1 then
( "Missing argument."
, "Missing " ++ argname_a desc ++ "."
)
else if number < min then
( "Too few arguments. " ++ show min ++ " required."
, "Too few instances of " ++ argname_a desc ++ ". "++ show min ++ " required."
)
else if number > max && max == 1 then
( "Only one argument may be specified."
, "Repeated " ++ argname_a desc ++ "."
)
else if number > max && max /= unlimited then
( "Too many arguments."
, "Too many instances of " ++ argname_a desc ++ "."
)
else error "bug in HsShellScript.Args.hs"
in if number >= min && (number <= max || max == unlimited)
then check_num rest
else Just (ArgError wrong_number_msg usageinfo)
-- Apply any argument testers
check_testers :: [(ArgumentDescription, [Maybe String])] -> Maybe ArgError
check_testers [] = Nothing
check_testers ((desc,args):rest) =
case argdesc_argarg_tester desc of
Just argdesc_argarg_tester ->
if argdesc_argarg desc == ArgumentValue_none
then abort "Bug in HsShellScript argument descriptions: Argument value tester specified,\n\
\but no argument value has been allowed. Add desc_value_optional or\n\
\desc_value_required."
desc
else case filter isJust (map (argdesc_argarg_tester . fromJust) (filter isJust args)) of
[] -> check_testers rest
(Just msgf : _) -> Just (ArgError (msgf desc) usageinfo)
Nothing -> check_testers rest
in case check_testers pars' of
Nothing -> case check_num pars' of
Nothing -> Right (Arguments (pars',usageinfo))
Just err -> Left err
Just err -> Left err
-- usage information generated by GetOpt
usageinfo = usageInfo header optdescr
in test_unique argdesc_short_args "short argument" $
test_unique argdesc_long_args "long argument" $
case getOpt ordering optdescr cmdlargs of
(pars, rest, []) ->
getopt_post pars rest
(_,_,f) ->
throw (ArgError (unlines (map chomp f)) (usageInfo header optdescr))
where
-- duplicated here in order to break cyclic module dependency
chomp "" = ""
chomp "\n" = ""
chomp [x] = [x]
chomp (x:xs) = let xs' = chomp xs
in if xs' == "" && x == '\n' then "" else x:xs'
-- |
-- Parse command line arguments. The arguments are taken from a call to
-- @getArgs@ and parsed. Any error is thrown as a
-- @ArgError@ exception. The result is a value from which the
-- information in the command line can be extracted by the @arg@...,
-- @reqarg@... and @optarg@... functions.
--
-- Named arguments (like @-x@ or @--arg@) and direct
-- arguments may occur in any order.
getargs :: String -- ^ Header to be used in the usage info.
-> [ArgumentDescription] -- ^ The argument descriptions.
-> IO Arguments -- ^ The contents of the command line.
getargs header descs = do
args <- getArgs
let res = getargs0 header Permute args descs
either throw
return
res
-- |
-- Parse command line arguments. The arguments are taken from a call to
-- @getArgs@ and parsed. Any error is thrown as a
-- @ArgError@ exception. The result is a value from which the
-- information in the command line can be extracted by the @arg@...,
-- @reqarg@... and @optarg@... functions.
--
-- All arguments after the first direct argument are regarded as direct
-- arguments. This means that argument names introduced by @-@
-- or @--@ no longer take effect.
getargs_ordered :: String -- ^ Header to be used in the usage info.
-> [ArgumentDescription] -- ^ Descriptions of the arguments.
-> IO Arguments -- ^ The contents of the command line.
getargs_ordered header descs = do
args <- getArgs
either throw
return
(getargs0 header RequireOrder args descs)
-- |
-- Parse the specified command line. Any error is returned as @Left
-- argerror@. In case of success, the result is returned as
-- @Right res@. From the result, the information in the command
-- line can be extracted by the @arg@..., @reqarg@...
-- and @optarg@... functions.
--
-- Named arguments (like @-x@ or @--arg@) and direct
-- arguments may occur in any order.
getargs' :: String -- ^ Header to be used in the usage info.
-> [String] -- ^ Command line to be parsed.
-> [ArgumentDescription] -- ^ The argument descriptions.
-> Either ArgError Arguments -- ^ The contents of the command line.
getargs' header args descs = getargs0 header Permute args descs
-- |
-- Parse the specified command line. Any error is returned as @Left
-- argerror@. In case of success, the result is returned as
-- @Right res@. From the result, the information in the command
-- line can be extracted by the @arg@..., @reqarg@...
-- and @optarg@... functions.
--
-- All arguments after the first direct argument are regarded as direct
-- arguments. This means that argument names introduced by @-@
-- or @--@ no longer take effect.
getargs_ordered' :: String -- ^ Header to be used in the usage info.
-> [String] -- ^ Command line to be parsed.
-> [ArgumentDescription] -- ^ The argument descriptions.
-> Either ArgError Arguments -- ^ The contents of the command line.
getargs_ordered' header args descs = getargs0 header RequireOrder args descs
test_desc :: ArgumentDescription -> Bool -> String -> b -> b
test_desc desc ok msg x =
if ok then x
else abort msg desc
maybe_head :: [a] -> Maybe a
maybe_head [] = Nothing
maybe_head [a] = Just a
-- |
-- Query whether a certain switch is specified on the command line. A switch is an
-- argument which is allowed zero or one time, and has no value.
arg_switch :: Arguments -- ^ Command line parse result.
-> ArgumentDescription -- ^ Argument description of the switch.
-> Bool -- ^ Whether the switch is present in the command line.
arg_switch args desc =
test_desc desc (argdesc_argarg desc == ArgumentValue_none && argdesc_times desc == Just (0,1))
"bug: querying argument with is not a switch with arg_switch" $
case argvalues args desc of
[] -> False
[Nothing] -> True
-- |
-- Query the number of occurences of an argument.
arg_times :: Arguments -- ^ Command line parse result.
-> ArgumentDescription -- ^ Description of the argument.
-> Int -- ^ Number of times the argument occurs.
arg_times args desc =
length (argvalues args desc)
-- |
-- Query the values of an argument with optional value. This is for
-- arguments which take an optional value, and may occur several times. The
-- occurences with value are represented as @Just value@, the occurences
-- without are represented as @Nothing@.
args_opt :: Arguments -- ^ Command line parse result.
-> ArgumentDescription -- ^ Description of the argument.
-> [Maybe String] -- ^ The occurences of the argument.
args_opt args desc =
test_desc desc (argdesc_argarg desc == ArgumentValue_optional && snd (fromJust (argdesc_times desc)) /= 1)
"Bug: Querying argument which doesn't take an optional value, or may not occur several times, with args_opt."
$ argvalues args desc
-- |
-- Query the values of an argument with required value. This is for
-- arguments which require a value, and may occur several times.
args_req :: Arguments -- ^ Command line parse result.
-> ArgumentDescription -- ^ Description of the argument.
-> [String] -- ^ The values of the argument.
args_req args desc =
test_desc desc (argdesc_argarg desc == ArgumentValue_required && snd (fromJust (argdesc_times desc)) /= 1)
"Bug: Querying argument which doesn't require a value, or may not occur several times, with args_req." $
map fromJust (argvalues args desc)
-- |
-- Query the optional value of a required argument. This is for arguments
-- which must occur once, and may have a value. If the argument is
-- specified, its value is returned as @Just value@. If it isn't, the result
-- is @Nothing@.
reqarg_opt :: Arguments -- ^ Command line parse result.
-> ArgumentDescription -- ^ Description of the argument.
-> Maybe String -- ^ The value of the argument, if it occurs.
reqarg_opt args desc =
test_desc desc (argdesc_argarg desc == ArgumentValue_optional && argdesc_times desc == Just (1,1))
"Bug: Querying argument which doesn't take an optional value, or which must not occur exactly once, with reqarg_opt." $
head (argvalues args desc)
-- |
-- Query the value of a required argument. This is for arguments which must
-- occur exactly once, and require a value.
reqarg_req :: Arguments -- ^ Command line parse result.
-> ArgumentDescription -- ^ Description of the argument.
-> String -- ^ The value of the argument.
reqarg_req args desc =
test_desc desc (argdesc_argarg desc == ArgumentValue_required && argdesc_times desc == Just (1,1))
"Bug: Querying argument with non-required value, or which doesn't occur exactly once, with reqarg_req." $
fromJust (head (argvalues args desc))
-- |
-- Query the optional value of an optional argument. This is for arguments
-- which may occur zero or one time, and which may or may not have a value.
-- If the argument doesn't occur, the result is @Nothing@. If it does occur,
-- but has no value, then the result is @Just Nothing@. If it does occur with
-- value, the result is @Just (Just value)@.
optarg_opt :: Arguments -- ^ Command line parse result.
-> ArgumentDescription -- ^ Description of the argument.
-> Maybe (Maybe String) -- ^ The occurence of the argument and its value (see above).
optarg_opt args desc =
test_desc desc (argdesc_argarg desc == ArgumentValue_optional) "Bug: Querying argument with non-optional value with optarg_opt." $
test_desc desc (fst (fromJust (argdesc_times desc)) == 0) "Bug: Querying argument which isn't optional with optarg_opt." $
test_desc desc (snd (fromJust (argdesc_times desc)) == 1) "Bug: Querying argument which may occur several times optarg_opt." $
maybe_head (argvalues args desc)
-- |
-- Query the value of an optional argument. This is for optional arguments
-- which require a value, and may occur at most once. The result is
-- @Just value@ if the argument occurs, and @Nothing@
-- if it doesn't occur.
optarg_req :: Arguments -- ^ Command line parse result.
-> ArgumentDescription -- ^ Description of the argument.
-> Maybe String -- ^ The value of the argument, if it occurs.
optarg_req args desc =
test_desc desc (argdesc_argarg desc == ArgumentValue_required) "Bug: Querying argument with non-required value with optarg_req."
$ test_desc desc (fst (fromJust (argdesc_times desc)) == 0) "Bug: Querying argument which isn't optional with optarg_req."
$ test_desc desc (snd (fromJust (argdesc_times desc)) == 1) "Bug: Querying argument which may occur several times optarg_req."
$ fmap fromJust (maybe_head (argvalues args desc))
-- |
-- None of the specifed arguments may be present.
--
-- Throws an ArgError if any of the arguments are present.
args_none :: [ArgumentDescription] -- ^ List of the arguments which must not be present.
-> Arguments -- ^ Command line parse result.
-> IO ()
args_none descs args@(Arguments (argl,usageinfo)) =
mapM_ (\desc ->
when (arg_times args desc /= 0) $
throw (ArgError (up1 (argname_a desc) ++ " is not allowed.\n") usageinfo)
)
descs
-- |
-- All of the specified arguments must be present.
--
-- Throws an ArgError if any is missing.
args_all :: [ArgumentDescription] -- ^ List of the arguments which must be present.
-> Arguments -- ^ Command line parse result.
-> IO ()
args_all descs args@(Arguments (argl,usageinfo)) =
mapM_ (\desc ->
when (arg_times args desc == 0) $
throw (ArgError ("Missing " ++ argname_a desc ++ "\n") usageinfo)
)
descs
-- |
-- Exactly one of the specified arguments must be present.
--
-- Otherwise throw an ArgError.
args_one :: [ArgumentDescription] -- ^ List of the arguments, of which exactly one must be present.
-> Arguments -- ^ Command line parse result.
-> IO ()
args_one descs args@(Arguments (argl,usageinfo)) =
when (occuring descs args /= 1) $
throw (ArgError ("Exactly one of the following arguments must be present.\n"
++ concat (intersperse ", " (map argname descs)) ++ "\n")
usageinfo)
-- |
-- At most one of the specified arguments may be present.
--
-- Otherwise throw an ArgError.
args_at_most_one :: [ArgumentDescription] -- ^ List of the arguments, of which at most one may be present.
-> Arguments -- ^ Command line parse result.
-> IO ()
args_at_most_one descs args@(Arguments (argl,usageinfo)) =
when (occuring descs args > 1) $
throw (ArgError ("Only one of the following arguments may be present.\n"
++ concat (intersperse ", " (map argname descs)) ++ "\n")
usageinfo)
-- |
-- At least one of the specified arguments must be present.
--
-- Otherwise throw an ArgError.
args_at_least_one :: [ArgumentDescription] -- ^ List of the arguments, of which at least one must be present.
-> Arguments -- ^ Command line parse result.
-> IO ()
args_at_least_one descs args@(Arguments (argl,usageinfo)) =
when (occuring descs args == 0) $
throw (ArgError ("One of the following arguments must be present.\n"
++ concat (intersperse ", " (map argname descs)) ++ "\n")
usageinfo)
-- |
-- When the specified argument is present, then none of the other arguments may be present.
--
-- Otherwise throw an ArgError.
arg_conflicts :: ArgumentDescription -- ^ Argument which doesn't tolerate the other arguments
-> [ArgumentDescription] -- ^ Arguments which aren't tolerated by the specified argument
-> Arguments -- ^ Command line parse result.
-> IO ()
arg_conflicts desc descs args@(Arguments (argl,usageinfo)) =
when (arg_occurs args desc && occuring descs args > 1) $
throw (ArgError ("When " ++ argname desc ++ " is present, none of the following arguments may be present.\n"
++ concat (intersperse ", " (map argname descs)) ++ "\n")
usageinfo)
-- How many of the specified arguments do occur? Multiple occurences of the same argument count as one.
occuring :: [ArgumentDescription] -> Arguments -> Int
occuring descs args =
sum (map (\desc -> if arg_times args desc == 0 then 0 else 1) descs)
{- | Whether the specified argument occurs in the command line.
-}
arg_occurs :: Arguments -- ^ Command line parse result.
-> ArgumentDescription -- ^ Description of the respective argument.
-> Bool -- ^ Whether the specified argument occurs in the command line.
arg_occurs args desc =
occuring [desc] args == 1
-- |
-- Get the usage information from the parsed arguments. The usage info
-- contains the header specified to the corresponding @getargs...@
-- function, and descriptions of the command line arguments.
usage_info :: Arguments -> String
usage_info (Arguments (_,ui)) = ui
{-
instance Show (OptDescr a) where
show (Option short long argdescr expl) =
"Option short:" ++ showList short " long:" ++ show long ++ " argdescr:" ++ show argdescr ++ " expl:" ++ showList expl ""
instance Show (ArgDescr a) where
show (NoArg _) = "NoArg"
show (ReqArg _ _) = "ReqArg ..."
show (OptArg _ _) = "OptArg ..."
-}
{- | @getargs@ as a pure function, instead of an IO action. This allows to make evaluated command line arguments global values. This calls @getargs@
to parse the command line arguments. @GHC.IO.unsafePerformIO@ is used to take the result out of the IO monad.
>unsafe_getargs header descs = GHC.IO.unsafePerformIO $ getargs header descs
The @getargs@ action is performed on demand, when the parse result is evaluated. It may result in an 'ArgError' being thrown. In order to avoid
this happening at unexpected times, the @main@ function should, start with the line @seq args (return ())@, where @args@ is the result of
@unsafe_getargs@,. This will trigger any command line argument errors at the beginning of the program. (See section 6.2 of the Hakell Report for the
definition of @seq@).
A typical use of @unsafe_getargs@ looks like this:
>header = "..."
>descs = [ d_myflag, ... ]
>
>d_myflag = argdesc [ ... ]
>
>args = unsafe_getargs header descs
>myflag = arg_switch args d_myflag
>
>main = mainwrapper $ do
> seq args (return ())
> ...
See 'getargs', 'unsafe_getargs_ordered'.
-}
unsafe_getargs :: String -- ^ The header used in the usage information
-> [ArgumentDescription] -- ^ The argument descriptions
-> Arguments -- ^ The parsed command line arguments
unsafe_getargs header descs =
GHC.IO.unsafePerformIO $ getargs header descs
{- | @getargs_ordered@ as a pure function, instead of an IO action. This is exactly like @unsafe_getargs@, but using @getargs_ordered@ instead of
@getargs@.
>unsafe_getargs_ordered = GHC.IO.unsafePerformIO $ getargs_ordered header descs
See 'unsafe_getargs'.
-}
unsafe_getargs_ordered :: String -- ^ The header used in the usage information
-> [ArgumentDescription] -- ^ The argument descriptions
-> Arguments -- ^ The parsed command line arguments
unsafe_getargs_ordered header descs =
GHC.IO.unsafePerformIO $ getargs_ordered header descs