-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.GetOpt
-- Copyright   :  (c) Sven Panne 2002-2005
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Portability :  portable
--
-- This is a fork of "System.Console.GetOpt" with the following changes:
--
-- * Treat "cabal --flag command" as "cabal command --flag" e.g.
--   "cabal -v configure" to mean "cabal configure -v" For flags that are
--   not recognised as global flags, pass them on to the sub-command. See
--   the difference in 'shortOpt'.
--
-- * Line wrapping in the 'usageInfo' output, plus a more compact
--   rendering of short options, and slightly less padding.
--
-- If you want to take on the challenge of merging this with the GetOpt
-- from the base package then go for it!
--
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NamedFieldPuns #-}
module Distribution.GetOpt (
   -- * GetOpt
   getOpt, getOpt',
   usageInfo,
   ArgOrder(..),
   OptDescr(..),
   ArgDescr(..),

   -- * Example
   -- | See "System.Console.GetOpt" for examples
) where

import Prelude ()
import Distribution.Compat.Prelude
import System.Console.GetOpt
         ( ArgOrder(..), OptDescr(..), ArgDescr(..) )

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...

data OptHelp a = OptHelp {
      forall a. OptHelp a -> a
optNames :: a,
      forall a. OptHelp a -> String
optHelp :: String
    }

-- | Return a string describing the usage of a command, derived from
-- the header (first argument) and the options described by the
-- second argument.
usageInfo :: String                    -- header
          -> [OptDescr a]              -- option descriptors
          -> String                    -- nicely formatted decription of options
usageInfo :: forall a. String -> [OptDescr a] -> String
usageInfo String
header [OptDescr a]
optDescr = [String] -> String
unlines (String
header forall a. a -> [a] -> [a]
: [String]
table)
  where
    options :: [OptHelp String]
options = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [OptDescr a]
optDescr forall a b. (a -> b) -> a -> b
$ \(Option String
sos [String]
los ArgDescr a
ad String
d) ->
      OptHelp
        { optNames :: String
optNames =
          forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map (forall a. ArgDescr a -> Char -> String
fmtShort ArgDescr a
ad) String
sos forall a. [a] -> [a] -> [a]
++
            forall a b. (a -> b) -> [a] -> [b]
map (forall a. ArgDescr a -> String -> String
fmtLong  ArgDescr a
ad) (forall a. Int -> [a] -> [a]
take Int
1 [String]
los)
        , optHelp :: String
optHelp = String
d
        }

    maxOptNameWidth :: Int
maxOptNameWidth = Int
30
    descolWidth :: Int
descolWidth = Int
80 forall a. Num a => a -> a -> a
- (Int
maxOptNameWidth forall a. Num a => a -> a -> a
+ Int
3)

    table :: [String]
    table :: [String]
table = do
      OptHelp{String
optNames :: String
optNames :: forall a. OptHelp a -> a
optNames, String
optHelp :: String
optHelp :: forall a. OptHelp a -> String
optHelp} <- [OptHelp String]
options
      let wrappedHelp :: [String]
wrappedHelp = Int -> String -> [String]
wrapText Int
descolWidth String
optHelp
      if forall (t :: * -> *) a. Foldable t => t a -> Int
length String
optNames forall a. Ord a => a -> a -> Bool
>= Int
maxOptNameWidth
        then [String
" " forall a. [a] -> [a] -> [a]
++ String
optNames] forall a. [a] -> [a] -> [a]
++
             [String] -> [String] -> [String]
renderColumns [] [String]
wrappedHelp
        else [String] -> [String] -> [String]
renderColumns [String
optNames] [String]
wrappedHelp

    renderColumns :: [String] -> [String] -> [String]
    renderColumns :: [String] -> [String] -> [String]
renderColumns [String]
xs [String]
ys = do
      (String
x, String
y) <- forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipDefault String
"" String
"" [String]
xs [String]
ys
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
" " forall a. [a] -> [a] -> [a]
++ Int -> String -> String
padTo Int
maxOptNameWidth String
x forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
y

    padTo :: Int -> String -> String
padTo Int
n String
x  = forall a. Int -> [a] -> [a]
take Int
n (String
x forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Char
' ')

zipDefault :: a -> b -> [a] -> [b] -> [(a,b)]
zipDefault :: forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipDefault a
_  b
_  []     []     = []
zipDefault a
_  b
bd (a
a:[a]
as) []     = (a
a,b
bd) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (,b
bd) [a]
as
zipDefault a
ad b
_  []     (b
b:[b]
bs) = (a
ad,b
b) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (a
ad,) [b]
bs
zipDefault a
ad b
bd (a
a:[a]
as) (b
b:[b]
bs) = (a
a,b
b)  forall a. a -> [a] -> [a]
: forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipDefault a
ad b
bd [a]
as [b]
bs

fmtShort :: ArgDescr a -> Char -> String
fmtShort :: forall a. ArgDescr a -> Char -> String
fmtShort (NoArg  a
_   ) Char
so = String
"-" forall a. [a] -> [a] -> [a]
++ [Char
so]
fmtShort (ReqArg String -> a
_  String
_) Char
so = String
"-" forall a. [a] -> [a] -> [a]
++ [Char
so]
fmtShort (OptArg Maybe String -> a
_  String
_) Char
so = String
"-" forall a. [a] -> [a] -> [a]
++ [Char
so]
  -- unlike upstream GetOpt we omit the arg name for short options

fmtLong :: ArgDescr a -> String -> String
fmtLong :: forall a. ArgDescr a -> String -> String
fmtLong (NoArg  a
_   ) String
lo = String
"--" forall a. [a] -> [a] -> [a]
++ String
lo
fmtLong (ReqArg String -> a
_ String
ad) String
lo = String
"--" forall a. [a] -> [a] -> [a]
++ String
lo forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ String
ad
fmtLong (OptArg Maybe String -> a
_ String
ad) String
lo = String
"--" forall a. [a] -> [a] -> [a]
++ String
lo forall a. [a] -> [a] -> [a]
++ String
"[=" forall a. [a] -> [a] -> [a]
++ String
ad forall a. [a] -> [a] -> [a]
++ String
"]"

wrapText :: Int -> String -> [String]
wrapText :: Int -> String -> [String]
wrapText Int
width = forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String] -> [[String]]
wrap Int
0 [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words
  where wrap :: Int -> [String] -> [String] -> [[String]]
        wrap :: Int -> [String] -> [String] -> [[String]]
wrap Int
0   []   (String
w:[String]
ws)
          | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w forall a. Num a => a -> a -> a
+ Int
1 forall a. Ord a => a -> a -> Bool
> Int
width
          = Int -> [String] -> [String] -> [[String]]
wrap (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w) [String
w] [String]
ws
        wrap Int
col [String]
line (String
w:[String]
ws)
          | Int
col forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w forall a. Num a => a -> a -> a
+ Int
1 forall a. Ord a => a -> a -> Bool
> Int
width
          = forall a. [a] -> [a]
reverse [String]
line forall a. a -> [a] -> [a]
: Int -> [String] -> [String] -> [[String]]
wrap Int
0 [] (String
wforall a. a -> [a] -> [a]
:[String]
ws)
        wrap Int
col [String]
line (String
w:[String]
ws)
          = let col' :: Int
col' = Int
col forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w forall a. Num a => a -> a -> a
+ Int
1
             in Int -> [String] -> [String] -> [[String]]
wrap Int
col' (String
wforall a. a -> [a] -> [a]
:[String]
line) [String]
ws
        wrap Int
_ []   [] = []
        wrap Int
_ [String]
line [] = [forall a. [a] -> [a]
reverse [String]
line]

{-|
Process the command-line, and return the list of values that matched
(and those that didn\'t). The arguments are:

* The order requirements (see 'ArgOrder')

* The option descriptions (see 'OptDescr')

* The actual command line arguments (presumably got from
  'System.Environment.getArgs').

'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 command-line arguments
       -> ([a],[String],[String])      -- (options,non-options,error messages)
getOpt :: forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder a
ordering [OptDescr a]
optDescr [String]
args = ([a]
os,[String]
xs,[String]
es forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map String -> String
errUnrec [String]
us)
   where ([a]
os,[String]
xs,[String]
us,[String]
es) = forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' ArgOrder a
ordering [OptDescr a]
optDescr [String]
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' :: forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' ArgOrder a
_        [OptDescr a]
_        []         =  ([],[],[],[])
getOpt' ArgOrder a
ordering [OptDescr a]
optDescr (String
arg:[String]
args) = OptKind a -> ArgOrder a -> ([a], [String], [String], [String])
procNextOpt OptKind a
opt ArgOrder a
ordering
   where procNextOpt :: OptKind a -> ArgOrder a -> ([a], [String], [String], [String])
procNextOpt (Opt a
o)      ArgOrder a
_                 = (a
oforall a. a -> [a] -> [a]
:[a]
os,[String]
xs,[String]
us,[String]
es)
         procNextOpt (UnreqOpt String
u) ArgOrder a
_                 = ([a]
os,[String]
xs,String
uforall a. a -> [a] -> [a]
:[String]
us,[String]
es)
         procNextOpt (NonOpt String
x)   ArgOrder a
RequireOrder      = ([],String
xforall a. a -> [a] -> [a]
:[String]
rest,[],[])
         procNextOpt (NonOpt String
x)   ArgOrder a
Permute           = ([a]
os,String
xforall a. a -> [a] -> [a]
:[String]
xs,[String]
us,[String]
es)
         procNextOpt (NonOpt String
x)   (ReturnInOrder String -> a
f) = (String -> a
f String
x forall a. a -> [a] -> [a]
:[a]
os, [String]
xs,[String]
us,[String]
es)
         procNextOpt OptKind a
EndOfOpts    ArgOrder a
RequireOrder      = ([],[String]
rest,[],[])
         procNextOpt OptKind a
EndOfOpts    ArgOrder a
Permute           = ([],[String]
rest,[],[])
         procNextOpt OptKind a
EndOfOpts    (ReturnInOrder String -> a
f) = (forall a b. (a -> b) -> [a] -> [b]
map String -> a
f [String]
rest,[],[],[])
         procNextOpt (OptErr String
e)   ArgOrder a
_                 = ([a]
os,[String]
xs,[String]
us,String
eforall a. a -> [a] -> [a]
:[String]
es)

         (OptKind a
opt,[String]
rest) = forall a.
String -> [String] -> [OptDescr a] -> (OptKind a, [String])
getNext String
arg [String]
args [OptDescr a]
optDescr
         ([a]
os,[String]
xs,[String]
us,[String]
es) = forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' ArgOrder a
ordering [OptDescr a]
optDescr [String]
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])
getNext :: forall a.
String -> [String] -> [OptDescr a] -> (OptKind a, [String])
getNext (Char
'-':Char
'-':[]) [String]
rest [OptDescr a]
_        = (forall a. OptKind a
EndOfOpts,[String]
rest)
getNext (Char
'-':Char
'-':String
xs) [String]
rest [OptDescr a]
optDescr = forall a.
String -> [String] -> [OptDescr a] -> (OptKind a, [String])
longOpt String
xs [String]
rest [OptDescr a]
optDescr
getNext (Char
'-': Char
x :String
xs) [String]
rest [OptDescr a]
optDescr = forall a.
Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String])
shortOpt Char
x String
xs [String]
rest [OptDescr a]
optDescr
getNext String
a            [String]
rest [OptDescr a]
_        = (forall a. String -> OptKind a
NonOpt String
a,[String]
rest)

-- handle long option
longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
longOpt :: forall a.
String -> [String] -> [OptDescr a] -> (OptKind a, [String])
longOpt String
ls [String]
rs [OptDescr a]
optDescr = [ArgDescr a] -> String -> [String] -> (OptKind a, [String])
long [ArgDescr a]
ads String
arg [String]
rs
   where (String
opt,String
arg) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
'=') String
ls
         getWith :: (String -> String -> Bool) -> [OptDescr a]
getWith String -> String -> Bool
p = [ OptDescr a
o  | o :: OptDescr a
o@(Option String
_ [String]
xs ArgDescr a
_ String
_) <- [OptDescr a]
optDescr
                          , forall a. Maybe a -> Bool
isJust (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> String -> Bool
p String
opt) [String]
xs)]
         exact :: [OptDescr a]
exact     = (String -> String -> Bool) -> [OptDescr a]
getWith forall a. Eq a => a -> a -> Bool
(==)
         options :: [OptDescr a]
options   = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [OptDescr a]
exact then (String -> String -> Bool) -> [OptDescr a]
getWith forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf else [OptDescr a]
exact
         ads :: [ArgDescr a]
ads       = [ ArgDescr a
ad | Option String
_ [String]
_ ArgDescr a
ad String
_ <- [OptDescr a]
options ]
         optStr :: String
optStr    = String
"--" forall a. [a] -> [a] -> [a]
++ String
opt

         long :: [ArgDescr a] -> String -> [String] -> (OptKind a, [String])
long (ArgDescr a
_:ArgDescr a
_:[ArgDescr a]
_)      String
_        [String]
rest     = (forall a. [OptDescr a] -> String -> OptKind a
errAmbig [OptDescr a]
options String
optStr,[String]
rest)
         long [NoArg  a
a  ] []       [String]
rest     = (forall a. a -> OptKind a
Opt a
a,[String]
rest)
         long [NoArg  a
_  ] (Char
'=':String
_)  [String]
rest     = (forall a. String -> OptKind a
errNoArg String
optStr,[String]
rest)
         long [ReqArg String -> a
_ String
d] []       []       = (forall a. String -> String -> OptKind a
errReq String
d String
optStr,[])
         long [ReqArg String -> a
f String
_] []       (String
r:[String]
rest) = (forall a. a -> OptKind a
Opt (String -> a
f String
r),[String]
rest)
         long [ReqArg String -> a
f String
_] (Char
'=':String
xs) [String]
rest     = (forall a. a -> OptKind a
Opt (String -> a
f String
xs),[String]
rest)
         long [OptArg Maybe String -> a
f String
_] []       [String]
rest     = (forall a. a -> OptKind a
Opt (Maybe String -> a
f forall a. Maybe a
Nothing),[String]
rest)
         long [OptArg Maybe String -> a
f String
_] (Char
'=':String
xs) [String]
rest     = (forall a. a -> OptKind a
Opt (Maybe String -> a
f (forall a. a -> Maybe a
Just String
xs)),[String]
rest)
         long [ArgDescr a]
_            String
_        [String]
rest     = (forall a. String -> OptKind a
UnreqOpt (String
"--"forall a. [a] -> [a] -> [a]
++String
ls),[String]
rest)

-- handle short option
shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
shortOpt :: forall a.
Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String])
shortOpt Char
y String
ys [String]
rs [OptDescr a]
optDescr = [ArgDescr a] -> String -> [String] -> (OptKind a, [String])
short [ArgDescr a]
ads String
ys [String]
rs
  where options :: [OptDescr a]
options = [ OptDescr a
o  | o :: OptDescr a
o@(Option String
ss [String]
_ ArgDescr a
_ String
_) <- [OptDescr a]
optDescr, Char
s <- String
ss, Char
y forall a. Eq a => a -> a -> Bool
== Char
s ]
        ads :: [ArgDescr a]
ads     = [ ArgDescr a
ad | Option String
_ [String]
_ ArgDescr a
ad String
_ <- [OptDescr a]
options ]
        optStr :: String
optStr  = Char
'-'forall a. a -> [a] -> [a]
:[Char
y]

        short :: [ArgDescr a] -> String -> [String] -> (OptKind a, [String])
short (ArgDescr a
_:ArgDescr a
_:[ArgDescr a]
_)        String
_  [String]
rest     = (forall a. [OptDescr a] -> String -> OptKind a
errAmbig [OptDescr a]
options String
optStr,[String]
rest)
        short (NoArg  a
a  :[ArgDescr a]
_) [] [String]
rest     = (forall a. a -> OptKind a
Opt a
a,[String]
rest)
        short (NoArg  a
a  :[ArgDescr a]
_) String
xs [String]
rest     = (forall a. a -> OptKind a
Opt a
a,(Char
'-'forall a. a -> [a] -> [a]
:String
xs)forall a. a -> [a] -> [a]
:[String]
rest)
        short (ReqArg String -> a
_ String
d:[ArgDescr a]
_) [] []       = (forall a. String -> String -> OptKind a
errReq String
d String
optStr,[])
        short (ReqArg String -> a
f String
_:[ArgDescr a]
_) [] (String
r:[String]
rest) = (forall a. a -> OptKind a
Opt (String -> a
f String
r),[String]
rest)
        short (ReqArg String -> a
f String
_:[ArgDescr a]
_) String
xs [String]
rest     = (forall a. a -> OptKind a
Opt (String -> a
f String
xs),[String]
rest)
        short (OptArg Maybe String -> a
f String
_:[ArgDescr a]
_) [] [String]
rest     = (forall a. a -> OptKind a
Opt (Maybe String -> a
f forall a. Maybe a
Nothing),[String]
rest)
        short (OptArg Maybe String -> a
f String
_:[ArgDescr a]
_) String
xs [String]
rest     = (forall a. a -> OptKind a
Opt (Maybe String -> a
f (forall a. a -> Maybe a
Just String
xs)),[String]
rest)
        short []             [] [String]
rest     = (forall a. String -> OptKind a
UnreqOpt String
optStr,[String]
rest)
        short []             String
xs [String]
rest     = (forall a. String -> OptKind a
UnreqOpt (String
optStrforall a. [a] -> [a] -> [a]
++String
xs),[String]
rest)
        -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)
        -- Apparently this was part of the change so that flags that are
        -- not recognised as global flags are passed on to the sub-command.
        -- But why was no equivalent change required for longOpt? So could
        -- this change go upstream?

-- miscellaneous error formatting

errAmbig :: [OptDescr a] -> String -> OptKind a
errAmbig :: forall a. [OptDescr a] -> String -> OptKind a
errAmbig [OptDescr a]
ods String
optStr = forall a. String -> OptKind a
OptErr (forall a. String -> [OptDescr a] -> String
usageInfo String
header [OptDescr a]
ods)
   where header :: String
header = String
"option `" forall a. [a] -> [a] -> [a]
++ String
optStr forall a. [a] -> [a] -> [a]
++ String
"' is ambiguous; could be one of:"

errReq :: String -> String -> OptKind a
errReq :: forall a. String -> String -> OptKind a
errReq String
d String
optStr = forall a. String -> OptKind a
OptErr (String
"option `" forall a. [a] -> [a] -> [a]
++ String
optStr forall a. [a] -> [a] -> [a]
++ String
"' requires an argument " forall a. [a] -> [a] -> [a]
++ String
d forall a. [a] -> [a] -> [a]
++ String
"\n")

errUnrec :: String -> String
errUnrec :: String -> String
errUnrec String
optStr = String
"unrecognized option `" forall a. [a] -> [a] -> [a]
++ String
optStr forall a. [a] -> [a] -> [a]
++ String
"'\n"

errNoArg :: String -> OptKind a
errNoArg :: forall a. String -> OptKind a
errNoArg String
optStr = forall a. String -> OptKind a
OptErr (String
"option `" forall a. [a] -> [a] -> [a]
++ String
optStr forall a. [a] -> [a] -> [a]
++ String
"' doesn't allow an argument\n")