-----------------------------------------------------------------------------
-- |
-- Module : System.Console.GetOpt
--- Copyright : (c) Sven Panne Oct. 1996 (small changes Feb. 2003)
+-- Copyright : (c) Sven Panne 2002-2005
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-}
module System.Console.GetOpt (
- -- * GetOpt
- getOpt,
- usageInfo,
- ArgOrder(..),
- OptDescr(..),
- ArgDescr(..),
+ -- * GetOpt
+ getOpt, getOpt',
+ usageInfo,
+ ArgOrder(..),
+ OptDescr(..),
+ ArgDescr(..),
- -- * Example
-
- -- $example
- ) where
+ -- * Example
-import Prelude
-import Data.List ( isPrefixOf )
+ -- $example
+) where
+
+import Prelude -- necessary to get dependencies right
+
+import Data.List ( isPrefixOf )
-- |What to do with options following non-options
data ArgOrder a
data OptKind a -- kind of cmd line arg (internal use only):
= Opt a -- an option
+ | UnreqOpt String -- an un-recognized option
| NonOpt String -- a non-option
| EndOfOpts -- end-of-options marker (i.e. "--")
| OptErr String -- something went wrong...
-> [OptDescr a] -- option descriptors
-> String -- nicely formatted decription of options
usageInfo header optDescr = unlines (header:table)
- where (ss,ls,ds) = (unzip3 . map fmtOpt) optDescr
+ where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr
table = zipWith3 paste (sameLen ss) (sameLen ls) ds
paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z
sameLen xs = flushLeft ((maximum . map length) xs) xs
flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
-fmtOpt :: OptDescr a -> (String,String,String)
-fmtOpt (Option sos los ad descr) = (sepBy ',' (map (fmtShort ad) sos),
- sepBy ',' (map (fmtLong ad) los),
- descr)
+fmtOpt :: OptDescr a -> [(String,String,String)]
+fmtOpt (Option sos los ad descr) =
+ case lines descr of
+ [] -> [(sosFmt,losFmt,"")]
+ (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]
where sepBy _ [] = ""
sepBy _ [x] = x
sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
+ sosFmt = sepBy ',' (map (fmtShort ad) sos)
+ losFmt = sepBy ',' (map (fmtLong ad) los)
fmtShort :: ArgDescr a -> Char -> String
fmtShort (NoArg _ ) so = "-" ++ [so]
* The option descriptions (see 'OptDescr')
* The actual command line arguments (presumably got from
- 'System.Console.Environment.getArgs').
+ 'System.Environment.getArgs').
-'getOpt' returns a triple, consisting of the argument values, a list
-of options that didn\'t match, and a list of error messages.
+'getOpt' returns a triple consisting of the option arguments, a list
+of non-options, and a list of error messages.
-}
getOpt :: ArgOrder a -- non-option handling
-> [OptDescr a] -- option descriptors
- -> [String] -- the commandline arguments
+ -> [String] -- the command-line arguments
-> ([a],[String],[String]) -- (options,non-options,error messages)
-getOpt _ _ [] = ([],[],[])
-getOpt ordering optDescr (arg:args) = procNextOpt opt ordering
- where procNextOpt (Opt o) _ = (o:os,xs,es)
- procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[])
- procNextOpt (NonOpt x) Permute = (os,x:xs,es)
- procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)
- procNextOpt EndOfOpts RequireOrder = ([],rest,[])
- procNextOpt EndOfOpts Permute = ([],rest,[])
- procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[])
- procNextOpt (OptErr e) _ = (os,xs,e:es)
+getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
+ where (os,xs,us,es) = getOpt' ordering optDescr args
+
+{-|
+This is almost the same as 'getOpt', but returns a quadruple
+consisting of the option arguments, a list of non-options, a list of
+unrecognized options, and a list of error messages.
+-}
+getOpt' :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
+getOpt' _ _ [] = ([],[],[],[])
+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
+ where procNextOpt (Opt o) _ = (o:os,xs,us,es)
+ procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
+ procNextOpt (NonOpt x) RequireOrder = ([],x:rest,us,[])
+ procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
+ procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)
+ procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
+ procNextOpt EndOfOpts Permute = ([],rest,[],[])
+ procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])
+ procNextOpt (OptErr e) _ = (os,xs,us,e:es)
(opt,rest) = getNext arg args optDescr
- (os,xs,es) = getOpt ordering optDescr rest
+ (os,xs,us,es) = getOpt' ordering optDescr rest
-- take a look at the next cmd line arg and decide what to do with it
getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
longOpt ls rs optDescr = long ads arg rs
where (opt,arg) = break (=='=') ls
- getWith p = [ o | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `p` l ]
+ getWith p = [ o | o@(Option _ xs _ _) <- optDescr, x <- xs, opt `p` x ]
exact = getWith (==)
options = if null exact then getWith isPrefixOf else exact
ads = [ ad | Option _ _ ad _ <- options ]
long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
long [OptArg f _] [] rest = (Opt (f Nothing),rest)
long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
- long _ _ rest = (errUnrec optStr,rest)
+ long _ _ rest = (UnreqOpt ("--"++ls),rest)
-- handle short option
shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-shortOpt x xs rest optDescr = short ads xs rest
- where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]
+shortOpt y ys rs optDescr = short ads ys rs
+ where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]
ads = [ ad | Option _ _ ad _ <- options ]
- optStr = '-':[x]
+ optStr = '-':[y]
short (_:_:_) _ rest = (errAmbig options optStr,rest)
short (NoArg a :_) [] rest = (Opt a,rest)
short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)
- short [] [] rest = (errUnrec optStr,rest)
- short [] xs rest = (errUnrec optStr,('-':xs):rest)
+ short [] [] rest = (UnreqOpt optStr,rest)
+ short [] xs rest = (UnreqOpt optStr,('-':xs):rest)
-- miscellaneous error formatting
errReq :: String -> String -> OptKind a
errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
-errUnrec :: String -> OptKind a
-errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")
+errUnrec :: String -> String
+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
errNoArg :: String -> OptKind a
errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
> data Flag
> = Verbose | Version
> | Input String | Output String | LibDir String
-> deriving Show
+> deriving Show
>
> options :: [OptDescr Flag]
> options =
>
> inp,outp :: Maybe String -> Flag
> outp = Output . fromMaybe "stdout"
-> inp = Input . fromMaybe "stdout"
+> inp = Input . fromMaybe "stdin"
>
> compilerOpts :: [String] -> IO ([Flag], [String])
> compilerOpts argv =
-> case (getOpt Permute options argv) of
-> (o,n,[] ) -> return (o,n)
-> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+> case getOpt Permute options argv of
+> (o,n,[] ) -> return (o,n)
+> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
> where header = "Usage: ic [OPTION...] files..."
-}
projects / ghc-base.git / blobdiff