{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}

-----------------------------------------------------------------------------

-- |
-- 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.
--
-- * Parsing of option arguments is allowed to fail.
--
-- * 'ReturnInOrder' argument order is removed.
module Distribution.GetOpt
  ( -- * GetOpt
    getOpt
  , getOpt'
  , usageInfo
  , ArgOrder (..)
  , OptDescr (..)
  , ArgDescr (..)

    -- * Example

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

import Distribution.Compat.Prelude
import Prelude ()

-- | What to do with options following non-options
data ArgOrder a
  = -- | no option processing after first non-option
    RequireOrder
  | -- | freely intersperse options and non-options
    Permute

data OptDescr a -- description of a single options:
  = Option
      [Char] --    list of short option characters
      [String] --    list of long option strings (without "--")
      (ArgDescr a) --    argument descriptor
      String --    explanation of option for user

instance Functor OptDescr where
  fmap :: forall a b. (a -> b) -> OptDescr a -> OptDescr b
fmap a -> b
f (Option [Char]
a [[Char]]
b ArgDescr a
argDescr [Char]
c) = [Char] -> [[Char]] -> ArgDescr b -> [Char] -> OptDescr b
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option [Char]
a [[Char]]
b ((a -> b) -> ArgDescr a -> ArgDescr b
forall a b. (a -> b) -> ArgDescr a -> ArgDescr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ArgDescr a
argDescr) [Char]
c

-- | Describes whether an option takes an argument or not, and if so
-- how the argument is parsed to a value of type @a@.
--
-- Compared to System.Console.GetOpt, we allow for parse errors.
data ArgDescr a
  = -- |   no argument expected
    NoArg a
  | -- |   option requires argument
    ReqArg (String -> Either String a) String
  | -- |   optional argument
    OptArg String (Maybe String -> Either String a) String

instance Functor ArgDescr where
  fmap :: forall a b. (a -> b) -> ArgDescr a -> ArgDescr b
fmap a -> b
f (NoArg a
a) = b -> ArgDescr b
forall a. a -> ArgDescr a
NoArg (a -> b
f a
a)
  fmap a -> b
f (ReqArg [Char] -> Either [Char] a
g [Char]
s) = ([Char] -> Either [Char] b) -> [Char] -> ArgDescr b
forall a. ([Char] -> Either [Char] a) -> [Char] -> ArgDescr a
ReqArg ((a -> b) -> Either [Char] a -> Either [Char] b
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Either [Char] a -> Either [Char] b)
-> ([Char] -> Either [Char] a) -> [Char] -> Either [Char] b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] a
g) [Char]
s
  fmap a -> b
f (OptArg [Char]
dv Maybe [Char] -> Either [Char] a
g [Char]
s) = [Char] -> (Maybe [Char] -> Either [Char] b) -> [Char] -> ArgDescr b
forall a.
[Char] -> (Maybe [Char] -> Either [Char] a) -> [Char] -> ArgDescr a
OptArg [Char]
dv ((a -> b) -> Either [Char] a -> Either [Char] b
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Either [Char] a -> Either [Char] b)
-> (Maybe [Char] -> Either [Char] a)
-> Maybe [Char]
-> Either [Char] b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Char] -> Either [Char] a
g) [Char]
s

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 = OptHelp
  { OptHelp -> [Char]
optNames :: String
  , OptHelp -> [Char]
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 description of options
usageInfo :: forall a. [Char] -> [OptDescr a] -> [Char]
usageInfo [Char]
header [OptDescr a]
optDescr = [[Char]] -> [Char]
unlines ([Char]
header [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
table)
  where
    options :: [OptHelp]
options = ((OptDescr a -> OptHelp) -> [OptDescr a] -> [OptHelp])
-> [OptDescr a] -> (OptDescr a -> OptHelp) -> [OptHelp]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (OptDescr a -> OptHelp) -> [OptDescr a] -> [OptHelp]
forall a b. (a -> b) -> [a] -> [b]
map [OptDescr a]
optDescr ((OptDescr a -> OptHelp) -> [OptHelp])
-> (OptDescr a -> OptHelp) -> [OptHelp]
forall a b. (a -> b) -> a -> b
$ \(Option [Char]
sos [[Char]]
los ArgDescr a
ad [Char]
d) ->
      OptHelp
        { optNames :: [Char]
optNames =
            [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
              (Char -> [Char]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (ArgDescr a -> Char -> [Char]
forall a. ArgDescr a -> Char -> [Char]
fmtShort ArgDescr a
ad) [Char]
sos
                [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (ArgDescr a -> [Char] -> [Char]
forall a. ArgDescr a -> [Char] -> [Char]
fmtLong ArgDescr a
ad) (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take Int
1 [[Char]]
los)
        , optHelp :: [Char]
optHelp = [Char]
d
        }

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

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

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

    padTo :: Int -> [Char] -> [Char]
padTo Int
n [Char]
x = Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
n ([Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
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) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: (a -> (a, b)) -> [a] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map (,b
bd) [a]
as
zipDefault a
ad b
_ [] (b
b : [b]
bs) = (a
ad, b
b) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: (b -> (a, b)) -> [b] -> [(a, b)]
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) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: a -> b -> [a] -> [b] -> [(a, b)]
forall a b. a -> b -> [a] -> [b] -> [(a, b)]
zipDefault a
ad b
bd [a]
as [b]
bs

-- | Pretty printing of short options.
-- * With required arguments can be given as:
--    @-w PATH or -wPATH (but not -w=PATH)@
--   This is dislayed as:
--    @-w PATH or -wPATH@
-- * With optional but default arguments can be given as:
--    @-j or -jNUM (but not -j=NUM or -j NUM)@
--   This is dislayed as:
--    @-j[NUM]@
fmtShort :: ArgDescr a -> Char -> String
fmtShort :: forall a. ArgDescr a -> Char -> [Char]
fmtShort (NoArg a
_) Char
so = [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
so]
fmtShort (ReqArg [Char] -> Either [Char] a
_ [Char]
ad) Char
so =
  let opt :: [Char]
opt = [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
so]
   in [Char]
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ad [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" or " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ad
fmtShort (OptArg [Char]
_ Maybe [Char] -> Either [Char] a
_ [Char]
ad) Char
so =
  let opt :: [Char]
opt = [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
so]
   in [Char]
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ad [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"

-- | Pretty printing of long options.
-- * With required arguments can be given as:
--    @--with-compiler=PATH (but not --with-compiler PATH)@
--   This is dislayed as:
--    @--with-compiler=PATH@
-- * With optional but default arguments can be given as:
--    @--jobs or --jobs=NUM (but not --jobs NUM)@
--   This is dislayed as:
--    @--jobs[=NUM]@
fmtLong :: ArgDescr a -> String -> String
fmtLong :: forall a. ArgDescr a -> [Char] -> [Char]
fmtLong (NoArg a
_) [Char]
lo = [Char]
"--" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lo
fmtLong (ReqArg [Char] -> Either [Char] a
_ [Char]
ad) [Char]
lo =
  let opt :: [Char]
opt = [Char]
"--" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lo
   in [Char]
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ad
fmtLong (OptArg [Char]
_ Maybe [Char] -> Either [Char] a
_ [Char]
ad) [Char]
lo =
  let opt :: [Char]
opt = [Char]
"--" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lo
   in [Char]
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"[=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ad [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"

wrapText :: Int -> String -> [String]
wrapText :: Int -> [Char] -> [[Char]]
wrapText Int
width = ([[Char]] -> [Char]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [[Char]] -> [Char]
unwords ([[[Char]]] -> [[Char]])
-> ([Char] -> [[[Char]]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[Char]] -> [[Char]] -> [[[Char]]]
wrap Int
0 [] ([[Char]] -> [[[Char]]])
-> ([Char] -> [[Char]]) -> [Char] -> [[[Char]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words
  where
    wrap :: Int -> [String] -> [String] -> [[String]]
    wrap :: Int -> [[Char]] -> [[Char]] -> [[[Char]]]
wrap Int
0 [] ([Char]
w : [[Char]]
ws)
      | [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
width =
          Int -> [[Char]] -> [[Char]] -> [[[Char]]]
wrap ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
w) [[Char]
w] [[Char]]
ws
    wrap Int
col [[Char]]
line ([Char]
w : [[Char]]
ws)
      | Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
width =
          [[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse [[Char]]
line [[Char]] -> [[[Char]]] -> [[[Char]]]
forall a. a -> [a] -> [a]
: Int -> [[Char]] -> [[Char]] -> [[[Char]]]
wrap Int
0 [] ([Char]
w [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
ws)
    wrap Int
col [[Char]]
line ([Char]
w : [[Char]]
ws) =
      let col' :: Int
col' = Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
       in Int -> [[Char]] -> [[Char]] -> [[[Char]]]
wrap Int
col' ([Char]
w [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
line) [[Char]]
ws
    wrap Int
_ [] [] = []
    wrap Int
_ [[Char]]
line [] = [[[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse [[Char]]
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] -> [[Char]] -> ([a], [[Char]], [[Char]])
getOpt ArgOrder a
ordering [OptDescr a]
optDescr [[Char]]
args = ([a]
os, [[Char]]
xs, [[Char]]
es [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
errUnrec [[Char]]
us)
  where
    ([a]
os, [[Char]]
xs, [[Char]]
us, [[Char]]
es) = ArgOrder a
-> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]], [[Char]])
forall a.
ArgOrder a
-> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]], [[Char]])
getOpt' ArgOrder a
ordering [OptDescr a]
optDescr [[Char]]
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] -> [[Char]] -> ([a], [[Char]], [[Char]], [[Char]])
getOpt' ArgOrder a
_ [OptDescr a]
_ [] = ([], [], [], [])
getOpt' ArgOrder a
ordering [OptDescr a]
optDescr ([Char]
arg : [[Char]]
args) = OptKind a -> ArgOrder a -> ([a], [[Char]], [[Char]], [[Char]])
forall {a}.
OptKind a -> ArgOrder a -> ([a], [[Char]], [[Char]], [[Char]])
procNextOpt OptKind a
opt ArgOrder a
ordering
  where
    procNextOpt :: OptKind a -> ArgOrder a -> ([a], [[Char]], [[Char]], [[Char]])
procNextOpt (Opt a
o) ArgOrder a
_ = (a
o a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
os, [[Char]]
xs, [[Char]]
us, [[Char]]
es)
    procNextOpt (UnreqOpt [Char]
u) ArgOrder a
_ = ([a]
os, [[Char]]
xs, [Char]
u [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
us, [[Char]]
es)
    procNextOpt (NonOpt [Char]
x) ArgOrder a
RequireOrder = ([], [Char]
x [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
rest, [], [])
    procNextOpt (NonOpt [Char]
x) ArgOrder a
Permute = ([a]
os, [Char]
x [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
xs, [[Char]]
us, [[Char]]
es)
    procNextOpt OptKind a
EndOfOpts ArgOrder a
RequireOrder = ([], [[Char]]
rest, [], [])
    procNextOpt OptKind a
EndOfOpts ArgOrder a
Permute = ([], [[Char]]
rest, [], [])
    procNextOpt (OptErr [Char]
e) ArgOrder a
_ = ([a]
os, [[Char]]
xs, [[Char]]
us, [Char]
e [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
es)

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

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

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

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

    short :: [ArgDescr b] -> [Char] -> [[Char]] -> (OptKind b, [[Char]])
short (ArgDescr b
_ : ArgDescr b
_ : [ArgDescr b]
_) [Char]
_ [[Char]]
rest = ([OptDescr a] -> [Char] -> OptKind b
forall a b. [OptDescr a] -> [Char] -> OptKind b
errAmbig [OptDescr a]
options [Char]
optStr, [[Char]]
rest)
    short (NoArg b
a : [ArgDescr b]
_) [] [[Char]]
rest = (b -> OptKind b
forall a. a -> OptKind a
Opt b
a, [[Char]]
rest)
    short (NoArg b
a : [ArgDescr b]
_) [Char]
xs [[Char]]
rest = (b -> OptKind b
forall a. a -> OptKind a
Opt b
a, (Char
'-' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
rest)
    short (ReqArg [Char] -> Either [Char] b
_ [Char]
d : [ArgDescr b]
_) [] [] = ([Char] -> [Char] -> OptKind b
forall a. [Char] -> [Char] -> OptKind a
errReq [Char]
d [Char]
optStr, [])
    short (ReqArg [Char] -> Either [Char] b
f [Char]
_ : [ArgDescr b]
_) [] ([Char]
r : [[Char]]
rest) = (Either [Char] b -> OptKind b
forall {a}. Either [Char] a -> OptKind a
fromRes ([Char] -> Either [Char] b
f [Char]
r), [[Char]]
rest)
    short (ReqArg [Char] -> Either [Char] b
f [Char]
_ : [ArgDescr b]
_) [Char]
xs [[Char]]
rest = (Either [Char] b -> OptKind b
forall {a}. Either [Char] a -> OptKind a
fromRes ([Char] -> Either [Char] b
f [Char]
xs), [[Char]]
rest)
    short (OptArg [Char]
_ Maybe [Char] -> Either [Char] b
f [Char]
_ : [ArgDescr b]
_) [] [[Char]]
rest = (Either [Char] b -> OptKind b
forall {a}. Either [Char] a -> OptKind a
fromRes (Maybe [Char] -> Either [Char] b
f Maybe [Char]
forall a. Maybe a
Nothing), [[Char]]
rest)
    short (OptArg [Char]
_ Maybe [Char] -> Either [Char] b
f [Char]
_ : [ArgDescr b]
_) [Char]
xs [[Char]]
rest = (Either [Char] b -> OptKind b
forall {a}. Either [Char] a -> OptKind a
fromRes (Maybe [Char] -> Either [Char] b
f ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
xs)), [[Char]]
rest)
    short [] [] [[Char]]
rest = ([Char] -> OptKind b
forall a. [Char] -> OptKind a
UnreqOpt [Char]
optStr, [[Char]]
rest)
    short [] [Char]
xs [[Char]]
rest = ([Char] -> OptKind b
forall a. [Char] -> OptKind a
UnreqOpt ([Char]
optStr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
xs), [[Char]]
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?

fromParseResult :: String -> Either String a -> OptKind a
fromParseResult :: forall a. [Char] -> Either [Char] a -> OptKind a
fromParseResult [Char]
optStr Either [Char] a
res = case Either [Char] a
res of
  Right a
x -> a -> OptKind a
forall a. a -> OptKind a
Opt a
x
  Left [Char]
err -> [Char] -> OptKind a
forall a. [Char] -> OptKind a
OptErr ([Char]
"invalid argument to option `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
optStr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"': " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")

-- miscellaneous error formatting

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

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

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

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