-----------------------------------------------------------------------------
-- |
-- Module      :  Agda.Utils.GetOpt
-- Copyright   :  (c) Sven Panne 2002-2005
-- License     :  BSD-style
--
-- This module provides facilities for parsing the command-line options
-- in a standalone program.  It is essentially a Haskell port of the GNU
-- @getopt@ library.
--
-- It is a fork of "System.Console.GetOpt" from the base package of GHC,
-- written by Sven Panne.
--
-- We modify it to remove the "allow prefixes of long options" behavior.
-----------------------------------------------------------------------------

module Agda.Utils.GetOpt (
   -- * GetOpt
   getOpt, getOpt',
   usageInfo,
   ArgOrder(..),
   OptDescr(..),
   ArgDescr(..),
) where

import Prelude
import Data.List (find)

-- | What to do with options following non-options.
data ArgOrder a
  = RequireOrder                -- ^ no option processing after first non-option
  | Permute                     -- ^ freely intersperse options and non-options
  | ReturnInOrder (String -> a) -- ^ wrap non-options into options

{-|
Each 'OptDescr' describes a single option.

The arguments to 'Option' are:

* list of short option characters

* list of long option strings (without \"--\")

* argument descriptor

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

-- | Describes whether an option takes an argument or not, and if so
-- how the argument is injected into a value of type @a@.
data ArgDescr a
  = NoArg                   a          -- ^ no argument expected
  | ReqArg (String       -> a) String  -- ^ option requires argument
  | OptArg (Maybe String -> a) String  -- ^ optional argument

instance Functor ArgOrder where
  fmap :: forall a b. (a -> b) -> ArgOrder a -> ArgOrder b
fmap a -> b
_ ArgOrder a
RequireOrder      = ArgOrder b
forall a. ArgOrder a
RequireOrder
  fmap a -> b
_ ArgOrder a
Permute           = ArgOrder b
forall a. ArgOrder a
Permute
  fmap a -> b
f (ReturnInOrder [Char] -> a
g) = ([Char] -> b) -> ArgOrder b
forall a. ([Char] -> a) -> ArgOrder a
ReturnInOrder (a -> b
f (a -> b) -> ([Char] -> a) -> [Char] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> a
g)

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

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] -> a
g [Char]
s) = ([Char] -> b) -> [Char] -> ArgDescr b
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg (a -> b
f (a -> b) -> ([Char] -> a) -> [Char] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> a
g) [Char]
s
  fmap a -> b
f (OptArg Maybe [Char] -> a
g [Char]
s) = (Maybe [Char] -> b) -> [Char] -> ArgDescr b
forall a. (Maybe [Char] -> a) -> [Char] -> ArgDescr a
OptArg (a -> b
f (a -> b) -> (Maybe [Char] -> a) -> Maybe [Char] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Char] -> a
g) [Char]
s

-- | Kind of command line argument (internal use only):
data OptKind a
  = 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...

-- | 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
     ([[Char]]
ss, [[Char]]
ls, [[Char]]
ds)   = [([Char], [Char], [Char])] -> ([[Char]], [[Char]], [[Char]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([Char], [Char], [Char])] -> ([[Char]], [[Char]], [[Char]]))
-> [([Char], [Char], [Char])] -> ([[Char]], [[Char]], [[Char]])
forall a b. (a -> b) -> a -> b
$ (OptDescr a -> [([Char], [Char], [Char])])
-> [OptDescr a] -> [([Char], [Char], [Char])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptDescr a -> [([Char], [Char], [Char])]
forall a. OptDescr a -> [([Char], [Char], [Char])]
fmtOpt [OptDescr a]
optDescr
     table :: [[Char]]
table          = ([Char] -> [Char] -> [Char] -> [Char])
-> [[Char]] -> [[Char]] -> [[Char]] -> [[Char]]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 [Char] -> [Char] -> [Char] -> [Char]
paste ([[Char]] -> [[Char]]
sameLen [[Char]]
ss) ([[Char]] -> [[Char]]
sameLen [[Char]]
ls) [[Char]]
ds
     paste :: [Char] -> [Char] -> [Char] -> [Char]
paste [Char]
x [Char]
y [Char]
z    = [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
y [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
z
     sameLen :: [[Char]] -> [[Char]]
sameLen [[Char]]
xs     = Int -> [[Char]] -> [[Char]]
flushLeft (([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([[Char]] -> [Int]) -> [[Char]] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Int) -> [[Char]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[Char]]
xs) [[Char]]
xs
     flushLeft :: Int -> [[Char]] -> [[Char]]
flushLeft Int
n [[Char]]
xs = [ 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
' ') | [Char]
x <- [[Char]]
xs ]

fmtOpt :: OptDescr a -> [(String, String, String)]
fmtOpt :: forall a. OptDescr a -> [([Char], [Char], [Char])]
fmtOpt (Option [Char]
sos [[Char]]
los ArgDescr a
ad [Char]
descr) =
   case [Char] -> [[Char]]
lines [Char]
descr of
     []     -> [([Char]
sosFmt, [Char]
losFmt, [Char]
"")]
     ([Char]
d:[[Char]]
ds) ->  ([Char]
sosFmt, [Char]
losFmt, [Char]
d) ([Char], [Char], [Char])
-> [([Char], [Char], [Char])] -> [([Char], [Char], [Char])]
forall a. a -> [a] -> [a]
: [ ([Char]
"", [Char]
"", [Char]
d') | [Char]
d' <- [[Char]]
ds ]
   where
     sepBy :: Char -> [[Char]] -> [Char]
sepBy Char
_  []     = [Char]
""
     sepBy Char
_  [[Char]
x]    = [Char]
x
     sepBy Char
ch ([Char]
x:[[Char]]
xs) = [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
chChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
' 'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char -> [[Char]] -> [Char]
sepBy Char
ch [[Char]]
xs
     sosFmt :: [Char]
sosFmt = Char -> [[Char]] -> [Char]
sepBy Char
',' ((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)
     losFmt :: [Char]
losFmt = Char -> [[Char]] -> [Char]
sepBy Char
',' (([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) [[Char]]
los)

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] -> a
_ [Char]
ad) Char
so = [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
so] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ad
fmtShort (OptArg Maybe [Char] -> a
_ [Char]
ad) Char
so = [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
so] [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]
"]"

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] -> a
_ [Char]
ad) [Char]
lo = [Char]
"--" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lo [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ad
fmtLong (OptArg Maybe [Char] -> a
_ [Char]
ad) [Char]
lo = [Char]
"--" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lo [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]
"]"

{-|
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
  'GHC.Internal.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]])
procNextOpt OptKind a
opt ArgOrder a
ordering
   where
     procNextOpt :: OptKind a -> ArgOrder a -> ([a], [[Char]], [[Char]], [[Char]])
procNextOpt (Opt a
o)      ArgOrder a
_                 = (a
oa -> [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 (NonOpt [Char]
x)   (ReturnInOrder [Char] -> a
f) = ([Char] -> a
f [Char]
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
os, [[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 OptKind a
EndOfOpts    (ReturnInOrder [Char] -> a
f) = (([Char] -> a) -> [[Char]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> a
f [[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]])
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
                     , ([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 Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe [Char]
forall a. Maybe a
Nothing ]
     options :: [OptDescr a]
options    = ([Char] -> [Char] -> Bool) -> [OptDescr a]
getWith [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
(==)
     -- Diff to System.Console.GetOpt here: do not allow prefixes
     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)

     long :: [ArgDescr a] -> [Char] -> [[Char]] -> (OptKind a, [[Char]])
long (ArgDescr a
_:ArgDescr a
_:[ArgDescr a]
_)      [Char]
_        [[Char]]
rest     = ([OptDescr a] -> [Char] -> OptKind a
forall a. [OptDescr a] -> [Char] -> OptKind a
errAmbig [OptDescr a]
options [Char]
optStr, [[Char]]
rest)
     long [NoArg  a
a  ] []       [[Char]]
rest     = (a -> OptKind a
forall a. a -> OptKind a
Opt a
a, [[Char]]
rest)
     long [NoArg  a
_  ] (Char
'=':[Char]
_)  [[Char]]
rest     = ([Char] -> OptKind a
forall a. [Char] -> OptKind a
errNoArg [Char]
optStr, [[Char]]
rest)
     long [ReqArg [Char] -> a
_ [Char]
d] []       []       = ([Char] -> [Char] -> OptKind a
forall a. [Char] -> [Char] -> OptKind a
errReq [Char]
d [Char]
optStr, [])
     long [ReqArg [Char] -> a
f [Char]
_] []       ([Char]
r:[[Char]]
rest) = (a -> OptKind a
forall a. a -> OptKind a
Opt ([Char] -> a
f [Char]
r), [[Char]]
rest)
     long [ReqArg [Char] -> a
f [Char]
_] (Char
'=':[Char]
xs) [[Char]]
rest     = (a -> OptKind a
forall a. a -> OptKind a
Opt ([Char] -> a
f [Char]
xs), [[Char]]
rest)
     long [OptArg Maybe [Char] -> a
f [Char]
_] []       [[Char]]
rest     = (a -> OptKind a
forall a. a -> OptKind a
Opt (Maybe [Char] -> a
f Maybe [Char]
forall a. Maybe a
Nothing), [[Char]]
rest)
     long [OptArg Maybe [Char] -> a
f [Char]
_] (Char
'=':[Char]
xs) [[Char]]
rest     = (a -> OptKind a
forall a. a -> OptKind a
Opt (Maybe [Char] -> a
f ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
xs)), [[Char]]
rest)
     long [ArgDescr a]
_            [Char]
_        [[Char]]
rest     = ([Char] -> OptKind a
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]])
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]

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

-- * Miscellaneous error formatting

errAmbig :: [OptDescr a] -> String -> OptKind a
errAmbig :: forall a. [OptDescr a] -> [Char] -> OptKind a
errAmbig [OptDescr a]
ods [Char]
optStr = [Char] -> OptKind a
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")