-- | -- 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