1----------------------------------------------------------------------------- 2-- | 3-- Module : Distribution.GetOpt 4-- Copyright : (c) Sven Panne 2002-2005 5-- License : BSD-style (see the file libraries/base/LICENSE) 6-- 7-- Maintainer : libraries@haskell.org 8-- Portability : portable 9-- 10-- This is a fork of "System.Console.GetOpt" with the following changes: 11-- 12-- * Treat "cabal --flag command" as "cabal command --flag" e.g. 13-- "cabal -v configure" to mean "cabal configure -v" For flags that are 14-- not recognised as global flags, pass them on to the sub-command. See 15-- the difference in 'shortOpt'. 16-- 17-- * Line wrapping in the 'usageInfo' output, plus a more compact 18-- rendering of short options, and slightly less padding. 19-- 20-- If you want to take on the challenge of merging this with the GetOpt 21-- from the base package then go for it! 22-- 23module Distribution.GetOpt ( 24 -- * GetOpt 25 getOpt, getOpt', 26 usageInfo, 27 ArgOrder(..), 28 OptDescr(..), 29 ArgDescr(..), 30 31 -- * Example 32 -- | See "System.Console.GetOpt" for examples 33) where 34 35import Prelude () 36import Distribution.Compat.Prelude 37import System.Console.GetOpt 38 ( ArgOrder(..), OptDescr(..), ArgDescr(..) ) 39 40data OptKind a -- kind of cmd line arg (internal use only): 41 = Opt a -- an option 42 | UnreqOpt String -- an un-recognized option 43 | NonOpt String -- a non-option 44 | EndOfOpts -- end-of-options marker (i.e. "--") 45 | OptErr String -- something went wrong... 46 47-- | Return a string describing the usage of a command, derived from 48-- the header (first argument) and the options described by the 49-- second argument. 50usageInfo :: String -- header 51 -> [OptDescr a] -- option descriptors 52 -> String -- nicely formatted decription of options 53usageInfo header optDescr = unlines (header:table) 54 where (ss,ls,ds) = unzip3 [ (intercalate ", " (map (fmtShort ad) sos) 55 ,concatMap (fmtLong ad) (take 1 los) 56 ,d) 57 | Option sos los ad d <- optDescr ] 58 ssWidth = (maximum . map length) ss 59 lsWidth = (maximum . map length) ls 60 dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) 61 table = [ " " ++ padTo ssWidth so' ++ 62 " " ++ padTo lsWidth lo' ++ 63 " " ++ d' 64 | (so,lo,d) <- zip3 ss ls ds 65 , (so',lo',d') <- fmtOpt dsWidth so lo d ] 66 padTo n x = take n (x ++ repeat ' ') 67 68fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] 69fmtOpt descrWidth so lo descr = 70 case wrapText descrWidth descr of 71 [] -> [(so,lo,"")] 72 (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] 73 74fmtShort :: ArgDescr a -> Char -> String 75fmtShort (NoArg _ ) so = "-" ++ [so] 76fmtShort (ReqArg _ _) so = "-" ++ [so] 77fmtShort (OptArg _ _) so = "-" ++ [so] 78 -- unlike upstream GetOpt we omit the arg name for short options 79 80fmtLong :: ArgDescr a -> String -> String 81fmtLong (NoArg _ ) lo = "--" ++ lo 82fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad 83fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" 84 85wrapText :: Int -> String -> [String] 86wrapText width = map unwords . wrap 0 [] . words 87 where wrap :: Int -> [String] -> [String] -> [[String]] 88 wrap 0 [] (w:ws) 89 | length w + 1 > width 90 = wrap (length w) [w] ws 91 wrap col line (w:ws) 92 | col + length w + 1 > width 93 = reverse line : wrap 0 [] (w:ws) 94 wrap col line (w:ws) 95 = let col' = col + length w + 1 96 in wrap col' (w:line) ws 97 wrap _ [] [] = [] 98 wrap _ line [] = [reverse line] 99 100{-| 101Process the command-line, and return the list of values that matched 102(and those that didn\'t). The arguments are: 103 104* The order requirements (see 'ArgOrder') 105 106* The option descriptions (see 'OptDescr') 107 108* The actual command line arguments (presumably got from 109 'System.Environment.getArgs'). 110 111'getOpt' returns a triple consisting of the option arguments, a list 112of non-options, and a list of error messages. 113-} 114getOpt :: ArgOrder a -- non-option handling 115 -> [OptDescr a] -- option descriptors 116 -> [String] -- the command-line arguments 117 -> ([a],[String],[String]) -- (options,non-options,error messages) 118getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) 119 where (os,xs,us,es) = getOpt' ordering optDescr args 120 121{-| 122This is almost the same as 'getOpt', but returns a quadruple 123consisting of the option arguments, a list of non-options, a list of 124unrecognized options, and a list of error messages. 125-} 126getOpt' :: ArgOrder a -- non-option handling 127 -> [OptDescr a] -- option descriptors 128 -> [String] -- the command-line arguments 129 -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) 130getOpt' _ _ [] = ([],[],[],[]) 131getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering 132 where procNextOpt (Opt o) _ = (o:os,xs,us,es) 133 procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) 134 procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) 135 procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) 136 procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) 137 procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) 138 procNextOpt EndOfOpts Permute = ([],rest,[],[]) 139 procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) 140 procNextOpt (OptErr e) _ = (os,xs,us,e:es) 141 142 (opt,rest) = getNext arg args optDescr 143 (os,xs,us,es) = getOpt' ordering optDescr rest 144 145-- take a look at the next cmd line arg and decide what to do with it 146getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) 147getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) 148getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr 149getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr 150getNext a rest _ = (NonOpt a,rest) 151 152-- handle long option 153longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) 154longOpt ls rs optDescr = long ads arg rs 155 where (opt,arg) = break (=='=') ls 156 getWith p = [ o | o@(Option _ xs _ _) <- optDescr 157 , isJust (find (p opt) xs)] 158 exact = getWith (==) 159 options = if null exact then getWith isPrefixOf else exact 160 ads = [ ad | Option _ _ ad _ <- options ] 161 optStr = "--" ++ opt 162 163 long (_:_:_) _ rest = (errAmbig options optStr,rest) 164 long [NoArg a ] [] rest = (Opt a,rest) 165 long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) 166 long [ReqArg _ d] [] [] = (errReq d optStr,[]) 167 long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) 168 long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) 169 long [OptArg f _] [] rest = (Opt (f Nothing),rest) 170 long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) 171 long _ _ rest = (UnreqOpt ("--"++ls),rest) 172 173-- handle short option 174shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) 175shortOpt y ys rs optDescr = short ads ys rs 176 where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] 177 ads = [ ad | Option _ _ ad _ <- options ] 178 optStr = '-':[y] 179 180 short (_:_:_) _ rest = (errAmbig options optStr,rest) 181 short (NoArg a :_) [] rest = (Opt a,rest) 182 short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) 183 short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) 184 short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) 185 short (ReqArg f _:_) xs rest = (Opt (f xs),rest) 186 short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) 187 short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) 188 short [] [] rest = (UnreqOpt optStr,rest) 189 short [] xs rest = (UnreqOpt (optStr++xs),rest) 190 -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) 191 -- Apparently this was part of the change so that flags that are 192 -- not recognised as global flags are passed on to the sub-command. 193 -- But why was no equivalent change required for longOpt? So could 194 -- this change go upstream? 195 196-- miscellaneous error formatting 197 198errAmbig :: [OptDescr a] -> String -> OptKind a 199errAmbig ods optStr = OptErr (usageInfo header ods) 200 where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" 201 202errReq :: String -> String -> OptKind a 203errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") 204 205errUnrec :: String -> String 206errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" 207 208errNoArg :: String -> OptKind a 209errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") 210