X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FConsole%2FGetOpt.hs;h=92ebd5205585cfbeaa899c81c8ea82880a9db967;hb=7dbb606d7b57cdad87a0ffbdb6ea4a274ebca7c0;hp=cc55a70f6fd203e04fbaef61ea8c59cc9182b77a;hpb=7fed02d08be1f19b470e2a79e587064789f0b564;p=ghc-base.git diff --git a/System/Console/GetOpt.hs b/System/Console/GetOpt.hs index cc55a70..92ebd52 100644 --- a/System/Console/GetOpt.hs +++ b/System/Console/GetOpt.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- 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 @@ -38,20 +38,31 @@ over 1100 lines, we need only 195 here, including a 46 line example! -} module System.Console.GetOpt ( - -- * GetOpt - getOpt, - usageInfo, - ArgOrder(..), - OptDescr(..), - ArgDescr(..), + -- * GetOpt + getOpt, getOpt', + usageInfo, + ArgOrder(..), + OptDescr(..), + ArgDescr(..), - -- * Example - - -- $example - ) where + -- * Examples -import Prelude -import Data.List ( isPrefixOf ) + -- |To hopefully illuminate the role of the different data structures, + -- here are the command-line options for a (very simple) compiler, + -- done in two different ways. + -- The difference arises because the type of 'getOpt' is + -- parameterized by the type of values derived from flags. + + -- ** Interpreting flags as concrete values + -- $example1 + + -- ** Interpreting flags as transformations of an options record + -- $example2 +) where + +import Prelude -- necessary to get dependencies right + +import Data.List ( isPrefixOf, find ) -- |What to do with options following non-options data ArgOrder a @@ -66,7 +77,7 @@ The arguments to 'Option' are: * list of short option characters -* list of long option strings (without "--") +* list of long option strings (without \"--\") * argument descriptor @@ -87,6 +98,7 @@ data ArgDescr 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... @@ -98,19 +110,22 @@ usageInfo :: String -- header -> [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] @@ -131,28 +146,41 @@ Process the command-line, and return the list of values that matched * 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,[],[]) + 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]) @@ -165,7 +193,8 @@ getNext a rest _ = (NonOpt a,rest) 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 + , find (p opt) xs /= Nothing ] exact = getWith (==) options = if null exact then getWith isPrefixOf else exact ads = [ ad | Option _ _ ad _ <- options ] @@ -179,14 +208,14 @@ longOpt ls rs optDescr = long ads arg rs 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) @@ -196,8 +225,8 @@ shortOpt x xs rest optDescr = short ads xs 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 @@ -208,8 +237,8 @@ errAmbig ods optStr = OptErr (usageInfo header ods) 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") @@ -260,13 +289,13 @@ test order cmdline = case getOpt order options cmdline of ----------------------------------------------------------------------------------------- -} -{- $example +{- $example1 -To hopefully illuminate the role of the different "GetOpt" data -structures, here\'s the command-line options for a (very simple) -compiler: +A simple choice for the type associated with flags is to define a type +@Flag@ as an algebraic type representing the possible flags and their +arguments: -> module Opts where +> module Opts1 where > > import System.Console.GetOpt > import Data.Maybe ( fromMaybe ) @@ -274,7 +303,7 @@ compiler: > data Flag > = Verbose | Version > | Input String | Output String | LibDir String -> deriving Show +> deriving Show > > options :: [OptDescr Flag] > options = @@ -287,13 +316,78 @@ compiler: > > 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..." +Then the rest of the program will use the constructed list of flags +to determine it\'s behaviour. + +-} + +{- $example2 + +A different approach is to group the option values in a record of type +@Options@, and have each flag yield a function of type +@Options -> Options@ transforming this record. + +> module Opts2 where +> +> import System.Console.GetOpt +> import Data.Maybe ( fromMaybe ) +> +> data Options = Options +> { optVerbose :: Bool +> , optShowVersion :: Bool +> , optOutput :: Maybe FilePath +> , optInput :: Maybe FilePath +> , optLibDirs :: [FilePath] +> } deriving Show +> +> defaultOptions = Options +> { optVerbose = False +> , optShowVersion = False +> , optOutput = Nothing +> , optInput = Nothing +> , optLibDirs = [] +> } +> +> options :: [OptDescr (Options -> Options)] +> options = +> [ Option ['v'] ["verbose"] +> (NoArg (\ opts -> opts { optVerbose = True })) +> "chatty output on stderr" +> , Option ['V','?'] ["version"] +> (NoArg (\ opts -> opts { optShowVersion = True })) +> "show version number" +> , Option ['o'] ["output"] +> (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output") +> "FILE") +> "output FILE" +> , Option ['c'] [] +> (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input") +> "FILE") +> "input FILE" +> , Option ['L'] ["libdir"] +> (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR") +> "library directory" +> ] +> +> compilerOpts :: [String] -> IO (Options, [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +Similarly, each flag could yield a monadic function transforming a record, +of type @Options -> IO Options@ (or any other monad), allowing option +processing to perform actions of the chosen monad, e.g. printing help or +version messages, checking that file arguments exist, etc. + -}