Cabal/src/Distribution/GetOpt.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE TupleSections #-}
   3
   4 -----------------------------------------------------------------------------
   5
   6 -- |
   7 -- Module      :  Distribution.GetOpt
   8 -- Copyright   :  (c) Sven Panne 2002-2005
   9 -- License     :  BSD-style (see the file libraries/base/LICENSE)
  10 --
  11 -- Maintainer  :  libraries@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- This is a fork of "System.Console.GetOpt" with the following changes:
  15 --
  16 -- * Treat "cabal --flag command" as "cabal command --flag" e.g.
  17 --   "cabal -v configure" to mean "cabal configure -v" For flags that are
  18 --   not recognised as global flags, pass them on to the sub-command. See
  19 --   the difference in 'shortOpt'.
  20 --
  21 -- * Line wrapping in the 'usageInfo' output, plus a more compact
  22 --   rendering of short options, and slightly less padding.
  23 --
  24 -- * Parsing of option arguments is allowed to fail.
  25 --
  26 -- * 'ReturnInOrder' argument order is removed.
  27 module Distribution.GetOpt
  28   ( -- * GetOpt
  29     getOpt
  30   , getOpt'
  31   , usageInfo
  32   , ArgOrder (..)
  33   , OptDescr (..)
  34   , ArgDescr (..)
  35
  36     -- * Example
  37
  38     -- | See "System.Console.GetOpt" for examples
  39   ) where
  40
  41 import Distribution.Compat.Prelude
  42 import Prelude ()
  43
  44 -- | What to do with options following non-options
  45 data ArgOrder a
  46   = -- | no option processing after first non-option
  47     RequireOrder
  48   | -- | freely intersperse options and non-options
  49     Permute
  50
  51 data OptDescr a -- description of a single options:
  52   = Option
  53       [Char] --    list of short option characters
  54       [String] --    list of long option strings (without "--")
  55       (ArgDescr a) --    argument descriptor
  56       String --    explanation of option for user
  57
  58 instance Functor OptDescr where
  59   fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c
  60
  61 -- | Describes whether an option takes an argument or not, and if so
  62 -- how the argument is parsed to a value of type @a@.
  63 --
  64 -- Compared to System.Console.GetOpt, we allow for parse errors.
  65 data ArgDescr a
  66   = -- |   no argument expected
  67     NoArg a
  68   | -- |   option requires argument
  69     ReqArg (String -> Either String a) String
  70   | -- |   optional argument
  71     OptArg String (Maybe String -> Either String a) String
  72
  73 instance Functor ArgDescr where
  74   fmap f (NoArg a) = NoArg (f a)
  75   fmap f (ReqArg g s) = ReqArg (fmap f . g) s
  76   fmap f (OptArg dv g s) = OptArg dv (fmap f . g) s
  77
  78 data OptKind a -- kind of cmd line arg (internal use only):
  79   = Opt a --    an option
  80   | UnreqOpt String --    an un-recognized option
  81   | NonOpt String --    a non-option
  82   | EndOfOpts --    end-of-options marker (i.e. "--")
  83   | OptErr String --    something went wrong...
  84
  85 data OptHelp = OptHelp
  86   { optNames :: String
  87   , optHelp :: String
  88   }
  89
  90 -- | Return a string describing the usage of a command, derived from
  91 -- the header (first argument) and the options described by the
  92 -- second argument.
  93 usageInfo
  94   :: String -- header
  95   -> [OptDescr a] -- option descriptors
  96   -> String -- nicely formatted description of options
  97 usageInfo header optDescr = unlines (header : table)
  98   where
  99     options = flip map optDescr $ \(Option sos los ad d) ->
 100       OptHelp
 101         { optNames =
 102             intercalate ", " $
 103               map (fmtShort ad) sos
 104                 ++ map (fmtLong ad) (take 1 los)
 105         , optHelp = d
 106         }
 107
 108     maxOptNameWidth = 30
 109     descolWidth = 80 - (maxOptNameWidth + 3)
 110
 111     table :: [String]
 112     table = do
 113       OptHelp{optNames, optHelp} <- options
 114       let wrappedHelp = wrapText descolWidth optHelp
 115       if length optNames >= maxOptNameWidth
 116         then
 117           [" " ++ optNames]
 118             ++ renderColumns [] wrappedHelp
 119         else renderColumns [optNames] wrappedHelp
 120
 121     renderColumns :: [String] -> [String] -> [String]
 122     renderColumns xs ys = do
 123       (x, y) <- zipDefault "" "" xs ys
 124       return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y
 125
 126     padTo n x = take n (x ++ repeat ' ')
 127
 128 zipDefault :: a -> b -> [a] -> [b] -> [(a, b)]
 129 zipDefault _ _ [] [] = []
 130 zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as
 131 zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs
 132 zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs
 133
 134 -- | Pretty printing of short options.
 135 -- * With required arguments can be given as:
 136 --    @-w PATH or -wPATH (but not -w=PATH)@
 137 --   This is dislayed as:
 138 --    @-w PATH or -wPATH@
 139 -- * With optional but default arguments can be given as:
 140 --    @-j or -jNUM (but not -j=NUM or -j NUM)@
 141 --   This is dislayed as:
 142 --    @-j[NUM]@
 143 fmtShort :: ArgDescr a -> Char -> String
 144 fmtShort (NoArg _) so = "-" ++ [so]
 145 fmtShort (ReqArg _ ad) so =
 146   let opt = "-" ++ [so]
 147    in opt ++ " " ++ ad ++ " or " ++ opt ++ ad
 148 fmtShort (OptArg _ _ ad) so =
 149   let opt = "-" ++ [so]
 150    in opt ++ "[" ++ ad ++ "]"
 151
 152 -- | Pretty printing of long options.
 153 -- * With required arguments can be given as:
 154 --    @--with-compiler=PATH (but not --with-compiler PATH)@
 155 --   This is dislayed as:
 156 --    @--with-compiler=PATH@
 157 -- * With optional but default arguments can be given as:
 158 --    @--jobs or --jobs=NUM (but not --jobs NUM)@
 159 --   This is dislayed as:
 160 --    @--jobs[=NUM]@
 161 fmtLong :: ArgDescr a -> String -> String
 162 fmtLong (NoArg _) lo = "--" ++ lo
 163 fmtLong (ReqArg _ ad) lo =
 164   let opt = "--" ++ lo
 165    in opt ++ "=" ++ ad
 166 fmtLong (OptArg _ _ ad) lo =
 167   let opt = "--" ++ lo
 168    in opt ++ "[=" ++ ad ++ "]"
 169
 170 wrapText :: Int -> String -> [String]
 171 wrapText width = map unwords . wrap 0 [] . words
 172   where
 173     wrap :: Int -> [String] -> [String] -> [[String]]
 174     wrap 0 [] (w : ws)
 175       | length w + 1 > width =
 176           wrap (length w) [w] ws
 177     wrap col line (w : ws)
 178       | col + length w + 1 > width =
 179           reverse line : wrap 0 [] (w : ws)
 180     wrap col line (w : ws) =
 181       let col' = col + length w + 1
 182        in wrap col' (w : line) ws
 183     wrap _ [] [] = []
 184     wrap _ line [] = [reverse line]
 185
 186 -- |
 187 -- Process the command-line, and return the list of values that matched
 188 -- (and those that didn\'t). The arguments are:
 189 --
 190 -- * The order requirements (see 'ArgOrder')
 191 --
 192 -- * The option descriptions (see 'OptDescr')
 193 --
 194 -- * The actual command line arguments (presumably got from
 195 --   'System.Environment.getArgs').
 196 --
 197 -- 'getOpt' returns a triple consisting of the option arguments, a list
 198 -- of non-options, and a list of error messages.
 199 getOpt
 200   :: ArgOrder a -- non-option handling
 201   -> [OptDescr a] -- option descriptors
 202   -> [String] -- the command-line arguments
 203   -> ([a], [String], [String]) -- (options,non-options,error messages)
 204 getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us)
 205   where
 206     (os, xs, us, es) = getOpt' ordering optDescr args
 207
 208 -- |
 209 -- This is almost the same as 'getOpt', but returns a quadruple
 210 -- consisting of the option arguments, a list of non-options, a list of
 211 -- unrecognized options, and a list of error messages.
 212 getOpt'
 213   :: ArgOrder a -- non-option handling
 214   -> [OptDescr a] -- option descriptors
 215   -> [String] -- the command-line arguments
 216   -> ([a], [String], [String], [String]) -- (options,non-options,unrecognized,error messages)
 217 getOpt' _ _ [] = ([], [], [], [])
 218 getOpt' ordering optDescr (arg : args) = procNextOpt opt ordering
 219   where
 220     procNextOpt (Opt o) _ = (o : os, xs, us, es)
 221     procNextOpt (UnreqOpt u) _ = (os, xs, u : us, es)
 222     procNextOpt (NonOpt x) RequireOrder = ([], x : rest, [], [])
 223     procNextOpt (NonOpt x) Permute = (os, x : xs, us, es)
 224     procNextOpt EndOfOpts RequireOrder = ([], rest, [], [])
 225     procNextOpt EndOfOpts Permute = ([], rest, [], [])
 226     procNextOpt (OptErr e) _ = (os, xs, us, e : es)
 227
 228     (opt, rest) = getNext arg args optDescr
 229     (os, xs, us, es) = getOpt' ordering optDescr rest
 230
 231 -- take a look at the next cmd line arg and decide what to do with it
 232 getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])
 233 getNext ('-' : '-' : []) rest _ = (EndOfOpts, rest)
 234 getNext ('-' : '-' : xs) rest optDescr = longOpt xs rest optDescr
 235 getNext ('-' : x : xs) rest optDescr = shortOpt x xs rest optDescr
 236 getNext a rest _ = (NonOpt a, rest)
 237
 238 -- handle long option
 239 longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])
 240 longOpt ls rs optDescr = long ads arg rs
 241   where
 242     (opt, arg) = break (== '=') ls
 243     getWith p =
 244       [ o | o@(Option _ xs _ _) <- optDescr, isJust (find (p opt) xs)
 245       ]
 246     exact = getWith (==)
 247     options = if null exact then getWith isPrefixOf else exact
 248     ads = [ad | Option _ _ ad _ <- options]
 249     optStr = "--" ++ opt
 250     fromRes = fromParseResult optStr
 251
 252     long (_ : _ : _) _ rest = (errAmbig options optStr, rest)
 253     long [NoArg a] [] rest = (Opt a, rest)
 254     long [NoArg _] ('=' : _) rest = (errNoArg optStr, rest)
 255     long [ReqArg _ d] [] [] = (errReq d optStr, [])
 256     long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest)
 257     long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest)
 258     long [OptArg _ f _] [] rest = (fromRes (f Nothing), rest)
 259     long [OptArg _ f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest)
 260     long _ _ rest = (UnreqOpt ("--" ++ ls), rest)
 261
 262 -- handle short option
 263 shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String])
 264 shortOpt y ys rs optDescr = short ads ys rs
 265   where
 266     options = [o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s]
 267     ads = [ad | Option _ _ ad _ <- options]
 268     optStr = '-' : [y]
 269     fromRes = fromParseResult optStr
 270
 271     short (_ : _ : _) _ rest = (errAmbig options optStr, rest)
 272     short (NoArg a : _) [] rest = (Opt a, rest)
 273     short (NoArg a : _) xs rest = (Opt a, ('-' : xs) : rest)
 274     short (ReqArg _ d : _) [] [] = (errReq d optStr, [])
 275     short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest)
 276     short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest)
 277     short (OptArg _ f _ : _) [] rest = (fromRes (f Nothing), rest)
 278     short (OptArg _ f _ : _) xs rest = (fromRes (f (Just xs)), rest)
 279     short [] [] rest = (UnreqOpt optStr, rest)
 280     short [] xs rest = (UnreqOpt (optStr ++ xs), rest)
 281
 282 -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)
 283 -- Apparently this was part of the change so that flags that are
 284 -- not recognised as global flags are passed on to the sub-command.
 285 -- But why was no equivalent change required for longOpt? So could
 286 -- this change go upstream?
 287
 288 fromParseResult :: String -> Either String a -> OptKind a
 289 fromParseResult optStr res = case res of
 290   Right x -> Opt x
 291   Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n")
 292
 293 -- miscellaneous error formatting
 294
 295 errAmbig :: [OptDescr a] -> String -> OptKind b
 296 errAmbig ods optStr = OptErr (usageInfo header ods)
 297   where
 298     header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
 299
 300 errReq :: String -> String -> OptKind a
 301 errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
 302
 303 errUnrec :: String -> String
 304 errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
 305
 306 errNoArg :: String -> OptKind a
 307 errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")