module System.Console.ParseArgs (
Arg(..),
Argtype(..),
ArgsComplete(..),
DataArg,
argDataRequired, argDataOptional, argDataDefaulted,
ArgRecord, Args(..),
parseArgs, parseArgsIO,
gotArg, ArgType(..),
getArgString, getArgFile, getArgStdio,
getArgInteger, getArgInt,
getArgDouble, getArgFloat,
ArgFileOpener(..),
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
data (Ord a) => Arg a =
Arg { argIndex :: a
, argAbbr :: Maybe Char
, argName :: Maybe String
, argData :: Maybe DataArg
, argDesc :: String
}
data Argtype = ArgtypeString (Maybe String)
| ArgtypeInteger (Maybe Integer)
| ArgtypeInt (Maybe Int)
| ArgtypeDouble (Maybe Double)
| ArgtypeFloat (Maybe Float)
data DataArg = DataArg { dataArgName :: String
, dataArgArgtype :: Argtype
, dataArgOptional :: Bool
}
argDataRequired :: String
-> (Maybe a -> Argtype)
-> Maybe DataArg
argDataRequired s c = Just (DataArg { dataArgName = s,
dataArgArgtype = c Nothing,
dataArgOptional = False })
argDataOptional :: String
-> (Maybe a -> Argtype)
-> Maybe DataArg
argDataOptional s c = Just (DataArg { dataArgName = s,
dataArgArgtype = c Nothing,
dataArgOptional = True })
argDataDefaulted :: String
-> (Maybe a -> Argtype)
-> a
-> Maybe DataArg
argDataDefaulted s c d = Just (DataArg { dataArgName = s,
dataArgArgtype = c (Just d),
dataArgOptional = True })
data Argval = ArgvalFlag
| ArgvalString String
| ArgvalInteger Integer
| ArgvalInt Int
| ArgvalDouble Double
| ArgvalFloat Float
newtype ArgRecord a = ArgRecord (Map.Map a Argval)
data (Ord a) => Args a =
Args { args :: ArgRecord a
, argsProgName :: String
, argsUsage :: String
, argsRest :: [ String ]
}
data ParseArgsException = ParseArgsException String String
deriving Eq
instance Typeable ParseArgsException where
typeOf _ = mkTyConApp e [s, s] where
e = mkTyCon "ParseArgsException"
s = typeOf ""
instance Exception ParseArgsException
instance Show ParseArgsException where
show (ParseArgsException usage msg) = msg ++ "\n" ++ usage
arg_posn :: (Ord a) =>
Arg a
-> Bool
arg_posn (Arg { argAbbr = Nothing,
argName = Nothing }) = True
arg_posn _ = False
arg_flag :: (Ord a) =>
Arg a
-> Bool
arg_flag a = not (arg_posn a)
arg_optional :: (Ord a) =>
Arg a
-> Bool
arg_optional (Arg { argData = Just (DataArg { dataArgOptional = b }) }) = b
arg_optional _ = True
arg_default_value :: (Ord a)
=> Arg a
-> Maybe Argval
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
perhaps b s = if b then s else ""
arg_string :: (Ord a) =>
Arg a
-> String
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_keys :: [ (Maybe a, b) ]
-> [ (a, b) ]
filter_keys l =
foldr check_key [] l
where
check_key (Nothing, _) rest = rest
check_key (Just k, v) rest = (k, v) : rest
argdesc_error :: String
-> a
argdesc_error msg =
error ("internal error: argument description: " ++ msg)
keymap_from_list :: (Ord k, Show k) =>
[ (k, a) ]
-> Map.Map k a
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_keymap :: (Ord a, Ord k, Show k) =>
((Arg a) -> Maybe k)
-> [ Arg a ]
-> (Map.Map k (Arg a))
make_keymap f_field args =
(keymap_from_list .
filter_keys .
map (\arg -> (f_field arg, arg))) args
data ArgsComplete = ArgsComplete
| ArgsTrailing
| ArgsInterspersed
exhaust :: (s -> [e] -> ([e], s))
-> s
-> [e]
-> s
exhaust f s [] = s
exhaust f s l =
let (l', s') = f s l
in exhaust f s' l'
parseError :: String
-> String
-> a
parseError usage msg =
throw (ParseArgsException usage msg)
parseArgs :: (Show a, Ord a) =>
ArgsComplete
-> [ Arg a ]
-> String
-> [ String ]
-> Args a
parseArgs acomplete argd pathname argv =
runST (do
check_argd
let flag_args = takeWhile arg_flag argd
let posn_args = dropWhile 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, posn, 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_argd :: ST s ()
check_argd = do
let residue = dropWhile arg_flag argd
let residue' = dropWhile arg_fixed_posn residue
let residue'' = dropWhile arg_opt_posn residue'
unless (null residue'')
(argdesc_error "argument description in wrong order")
when (or (map arg_nullary argd))
(argdesc_error "bogus 'nothing' argument")
return ()
where
arg_fixed_posn a = (arg_posn a) && (not (arg_optional a))
arg_opt_posn a = (arg_posn a) && (arg_optional a)
arg_nullary (Arg { argName = Nothing,
argAbbr = Nothing,
argData = Nothing }) = True
arg_nullary _ = False
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)
summary_line =
"usage: " ++ prog_name ++
perhaps
(not (null flag_args))
" [options]" ++
perhaps
(not (null posn_args))
(" " ++ unwords (map arg_string posn_args)) ++
(case acomplete of
ArgsComplete -> ""
_ -> " [--] ...") ++
"\n"
arg_lines = concatMap (arg_line n) argd where
arg_line n a =
let s = arg_string a in
" " ++ s ++
replicate (n (length s)) ' ' ++
" " ++ argDesc a ++ "\n"
parse _ _ _ av@(_, _, []) [] = ([], av)
parse usage _ _ av [] =
case acomplete of
ArgsComplete -> parseError usage "unexpected extra arguments"
_ -> ([], av)
parse usage name_hash abbr_hash (am, posn, rest) av@(aa : aas) =
case aa of
"--" -> case acomplete of
ArgsComplete -> parseError usage
("unexpected -- " ++
"(extra arguments not allowed)")
_ -> ([], (am, posn, (rest ++ aas)))
s@('-' : '-' : name) ->
case Map.lookup name name_hash of
Just ad -> peel s ad aas
Nothing ->
case acomplete of
ArgsInterspersed ->
(aas, (am, posn, rest ++ ["--" ++ name]))
_ -> parseError usage
("unknown argument --" ++ name)
('-' : abbr : abbrs) ->
case Map.lookup abbr abbr_hash of
Just ad ->
let p@(args', state') = peel ['-', abbr] ad aas
in case abbrs of
[] -> p
('-' : _) -> parseError usage
("bad internal '-' in argument " ++ aa)
_ -> (['-' : abbrs] ++ args', state')
Nothing ->
case acomplete of
ArgsInterspersed ->
(['-' : abbrs] ++ aas,
(am, posn, rest ++ [['-', abbr]]))
_ -> parseError usage
("unknown argument -" ++ [abbr])
aa -> case posn of
(ad@(Arg { argData = Just adata }) : ps) ->
let (argl', (am', _, rest')) =
peel_process (dataArgName adata) ad av
in (argl', (am', ps, rest'))
[] -> case acomplete of
ArgsComplete -> parseError usage
("unexpected argument " ++ aa)
_ -> (aas, (am, [], rest ++ [aa]))
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 ad@(Arg { argData = Nothing, argIndex = index }) argl =
let am' = add_entry name am (index, ArgvalFlag)
in (argl, (am', posn, rest))
peel name (Arg { argData = Just (DataArg {}) }) [] =
parseError usage (name ++ " is missing its argument")
peel name ad argl = peel_process name ad argl
peel_process name
ad@(Arg { argData = Just (DataArg {
dataArgArgtype = atype }),
argIndex = index })
(a : argl) =
let read_arg constructor kind =
case reads a of
[(v, "")] -> constructor v
_ -> parseError usage ("argument " ++
a ++ " to " ++ name ++
" is not " ++ kind)
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"
am' = add_entry name am (index, v)
in (argl, (am', posn, rest))
parseArgsIO :: (Show a, Ord a) =>
ArgsComplete
-> [ Arg a ]
-> IO (Args a)
parseArgsIO acomplete argd = do
argv <- getArgs
pathname <- getProgName
return (parseArgs acomplete argd pathname argv)
gotArg :: (Ord a) =>
Args a
-> a
-> Bool
gotArg (Args { args = ArgRecord am }) k =
case Map.lookup k am of
Just _ -> True
Nothing -> False
class ArgType b where
getArg :: (Show a, Ord a)
=> Args a
-> a
-> Maybe b
getRequiredArg :: (Show a, Ord a)
=> Args a
-> a
-> b
getRequiredArg args index =
case getArg args index of
Just v -> v
Nothing -> error ("internal error: required argument "
++ show index ++ "not supplied")
getArgPrimitive decons (Args { args = ArgRecord am }) k =
case Map.lookup k am of
Just v -> Just (decons v)
Nothing -> Nothing
instance ArgType ([] Char) where
getArg = getArgPrimitive (\(ArgvalString s) -> s)
getArgString :: (Show a, Ord a) =>
Args a
-> a
-> Maybe String
getArgString = getArg
instance ArgType Integer where
getArg = getArgPrimitive (\(ArgvalInteger i) -> i)
getArgInteger :: (Show a, Ord a) =>
Args a
-> a
-> Maybe Integer
getArgInteger = getArg
instance ArgType Int where
getArg = getArgPrimitive (\(ArgvalInt i) -> i)
getArgInt :: (Show a, Ord a) =>
Args a
-> a
-> Maybe Int
getArgInt = getArg
instance ArgType Double where
getArg = getArgPrimitive (\(ArgvalDouble i) -> i)
getArgDouble :: (Show a, Ord a) =>
Args a
-> a
-> Maybe Double
getArgDouble = getArg
instance ArgType Float where
getArg = getArgPrimitive (\(ArgvalFloat i) -> i)
getArgFloat :: (Show a, Ord a) =>
Args a
-> a
-> Maybe Float
getArgFloat = getArg
newtype ArgFileOpener = ArgFileOpener {
argFileOpener :: IOMode -> IO Handle
}
instance ArgType ArgFileOpener where
getArg args index =
case getArg args index of
Nothing -> Nothing
Just s -> Just (ArgFileOpener { argFileOpener = openFile s })
getArgFile :: (Show a, Ord a) =>
Args a
-> a
-> IOMode
-> IO (Maybe Handle)
getArgFile args k m =
case getArg args k of
Just fo -> (do h <- argFileOpener fo m; return (Just h))
Nothing -> return Nothing
getArgStdio :: (Show a, Ord a) =>
Args a
-> a
-> IOMode
-> IO Handle
getArgStdio args k m =
case getArg args 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")
baseName :: String
-> String
baseName s =
let s' = dropWhile (/= '/') s in
if null s' then s else baseName (tail s')
usageError :: (Ord a) => Args a -> String -> b
usageError args msg = error (argsUsage args ++ "\n" ++ msg)