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-- 23{-# LANGUAGE TupleSections #-} 24{-# LANGUAGE NamedFieldPuns #-} 25module Distribution.GetOpt ( 26 -- * GetOpt 27 getOpt, getOpt', 28 usageInfo, 29 ArgOrder(..), 30 OptDescr(..), 31 ArgDescr(..), 32 33 -- * Example 34 -- | See "System.Console.GetOpt" for examples 35) where 36 37import Prelude () 38import Distribution.Compat.Prelude 39import System.Console.GetOpt 40 ( ArgOrder(..), OptDescr(..), ArgDescr(..) ) 41 42data OptKind a -- kind of cmd line arg (internal use only): 43 = Opt a -- an option 44 | UnreqOpt String -- an un-recognized option 45 | NonOpt String -- a non-option 46 | EndOfOpts -- end-of-options marker (i.e. "--") 47 | OptErr String -- something went wrong... 48 49data OptHelp a = OptHelp { 50 optNames :: a, 51 optHelp :: String 52 } 53 54-- | Return a string describing the usage of a command, derived from 55-- the header (first argument) and the options described by the 56-- second argument. 57usageInfo :: String -- header 58 -> [OptDescr a] -- option descriptors 59 -> String -- nicely formatted decription of options 60usageInfo header optDescr = unlines (header : table) 61 where 62 options = flip map optDescr $ \(Option sos los ad d) -> 63 OptHelp 64 { optNames = 65 intercalate ", " $ 66 map (fmtShort ad) sos ++ 67 map (fmtLong ad) (take 1 los) 68 , optHelp = d 69 } 70 71 maxOptNameWidth = 30 72 descolWidth = 80 - (maxOptNameWidth + 3) 73 74 table :: [String] 75 table = do 76 OptHelp{optNames, optHelp} <- options 77 let wrappedHelp = wrapText descolWidth optHelp 78 if length optNames >= maxOptNameWidth 79 then [" " ++ optNames] ++ 80 renderColumns [] wrappedHelp 81 else renderColumns [optNames] wrappedHelp 82 83 renderColumns :: [String] -> [String] -> [String] 84 renderColumns xs ys = do 85 (x, y) <- zipDefault "" "" xs ys 86 return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y 87 88 padTo n x = take n (x ++ repeat ' ') 89 90zipDefault :: a -> b -> [a] -> [b] -> [(a,b)] 91zipDefault _ _ [] [] = [] 92zipDefault _ bd (a:as) [] = (a,bd) : map (,bd) as 93zipDefault ad _ [] (b:bs) = (ad,b) : map (ad,) bs 94zipDefault ad bd (a:as) (b:bs) = (a,b) : zipDefault ad bd as bs 95 96fmtShort :: ArgDescr a -> Char -> String 97fmtShort (NoArg _ ) so = "-" ++ [so] 98fmtShort (ReqArg _ _) so = "-" ++ [so] 99fmtShort (OptArg _ _) so = "-" ++ [so] 100 -- unlike upstream GetOpt we omit the arg name for short options 101 102fmtLong :: ArgDescr a -> String -> String 103fmtLong (NoArg _ ) lo = "--" ++ lo 104fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad 105fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" 106 107wrapText :: Int -> String -> [String] 108wrapText width = map unwords . wrap 0 [] . words 109 where wrap :: Int -> [String] -> [String] -> [[String]] 110 wrap 0 [] (w:ws) 111 | length w + 1 > width 112 = wrap (length w) [w] ws 113 wrap col line (w:ws) 114 | col + length w + 1 > width 115 = reverse line : wrap 0 [] (w:ws) 116 wrap col line (w:ws) 117 = let col' = col + length w + 1 118 in wrap col' (w:line) ws 119 wrap _ [] [] = [] 120 wrap _ line [] = [reverse line] 121 122{-| 123Process the command-line, and return the list of values that matched 124(and those that didn\'t). The arguments are: 125 126* The order requirements (see 'ArgOrder') 127 128* The option descriptions (see 'OptDescr') 129 130* The actual command line arguments (presumably got from 131 'System.Environment.getArgs'). 132 133'getOpt' returns a triple consisting of the option arguments, a list 134of non-options, and a list of error messages. 135-} 136getOpt :: ArgOrder a -- non-option handling 137 -> [OptDescr a] -- option descriptors 138 -> [String] -- the command-line arguments 139 -> ([a],[String],[String]) -- (options,non-options,error messages) 140getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) 141 where (os,xs,us,es) = getOpt' ordering optDescr args 142 143{-| 144This is almost the same as 'getOpt', but returns a quadruple 145consisting of the option arguments, a list of non-options, a list of 146unrecognized options, and a list of error messages. 147-} 148getOpt' :: ArgOrder a -- non-option handling 149 -> [OptDescr a] -- option descriptors 150 -> [String] -- the command-line arguments 151 -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) 152getOpt' _ _ [] = ([],[],[],[]) 153getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering 154 where procNextOpt (Opt o) _ = (o:os,xs,us,es) 155 procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) 156 procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) 157 procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) 158 procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) 159 procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) 160 procNextOpt EndOfOpts Permute = ([],rest,[],[]) 161 procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) 162 procNextOpt (OptErr e) _ = (os,xs,us,e:es) 163 164 (opt,rest) = getNext arg args optDescr 165 (os,xs,us,es) = getOpt' ordering optDescr rest 166 167-- take a look at the next cmd line arg and decide what to do with it 168getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) 169getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) 170getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr 171getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr 172getNext a rest _ = (NonOpt a,rest) 173 174-- handle long option 175longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) 176longOpt ls rs optDescr = long ads arg rs 177 where (opt,arg) = break (=='=') ls 178 getWith p = [ o | o@(Option _ xs _ _) <- optDescr 179 , isJust (find (p opt) xs)] 180 exact = getWith (==) 181 options = if null exact then getWith isPrefixOf else exact 182 ads = [ ad | Option _ _ ad _ <- options ] 183 optStr = "--" ++ opt 184 185 long (_:_:_) _ rest = (errAmbig options optStr,rest) 186 long [NoArg a ] [] rest = (Opt a,rest) 187 long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) 188 long [ReqArg _ d] [] [] = (errReq d optStr,[]) 189 long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) 190 long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) 191 long [OptArg f _] [] rest = (Opt (f Nothing),rest) 192 long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) 193 long _ _ rest = (UnreqOpt ("--"++ls),rest) 194 195-- handle short option 196shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) 197shortOpt y ys rs optDescr = short ads ys rs 198 where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] 199 ads = [ ad | Option _ _ ad _ <- options ] 200 optStr = '-':[y] 201 202 short (_:_:_) _ rest = (errAmbig options optStr,rest) 203 short (NoArg a :_) [] rest = (Opt a,rest) 204 short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) 205 short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) 206 short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) 207 short (ReqArg f _:_) xs rest = (Opt (f xs),rest) 208 short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) 209 short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) 210 short [] [] rest = (UnreqOpt optStr,rest) 211 short [] xs rest = (UnreqOpt (optStr++xs),rest) 212 -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) 213 -- Apparently this was part of the change so that flags that are 214 -- not recognised as global flags are passed on to the sub-command. 215 -- But why was no equivalent change required for longOpt? So could 216 -- this change go upstream? 217 218-- miscellaneous error formatting 219 220errAmbig :: [OptDescr a] -> String -> OptKind a 221errAmbig ods optStr = OptErr (usageInfo header ods) 222 where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" 223 224errReq :: String -> String -> OptKind a 225errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") 226 227errUnrec :: String -> String 228errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" 229 230errNoArg :: String -> OptKind a 231errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") 232