{-# LANGUAGE Safe #-}
module System.Console.GetOpt (
getOpt, getOpt',
usageInfo,
ArgOrder(..),
OptDescr(..),
ArgDescr(..),
) where
import Data.List ( isPrefixOf, find )
data ArgOrder a
= RequireOrder
| Permute
| ReturnInOrder (String -> a)
data OptDescr a =
Option [Char]
[String]
(ArgDescr a)
String
data ArgDescr a
= NoArg a
| ReqArg (String -> a) String
| OptArg (Maybe String -> a) String
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 String -> a
g) = (String -> b) -> ArgOrder b
forall a. (String -> a) -> ArgOrder a
ReturnInOrder (a -> b
f (a -> b) -> (String -> a) -> String -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
g)
instance Functor OptDescr where
fmap :: forall a b. (a -> b) -> OptDescr a -> OptDescr b
fmap a -> b
f (Option String
a [String]
b ArgDescr a
argDescr String
c) = String -> [String] -> ArgDescr b -> String -> OptDescr b
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
a [String]
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) String
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 String -> a
g String
s) = (String -> b) -> String -> ArgDescr b
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (a -> b
f (a -> b) -> (String -> a) -> String -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
g) String
s
fmap a -> b
f (OptArg Maybe String -> a
g String
s) = (Maybe String -> b) -> String -> ArgDescr b
forall a. (Maybe String -> a) -> String -> ArgDescr a
OptArg (a -> b
f (a -> b) -> (Maybe String -> a) -> Maybe String -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> a
g) String
s
data OptKind a
= Opt a
| UnreqOpt String
| NonOpt String
| EndOfOpts
| OptErr String
usageInfo :: String
-> [OptDescr a]
-> String
usageInfo :: forall a. String -> [OptDescr a] -> String
usageInfo String
header [OptDescr a]
optDescr = [String] -> String
unlines (String
headerString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
table)
where ([String]
ss,[String]
ls,[String]
ds) = ([(String, String, String)] -> ([String], [String], [String])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(String, String, String)] -> ([String], [String], [String]))
-> ([OptDescr a] -> [(String, String, String)])
-> [OptDescr a]
-> ([String], [String], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OptDescr a -> [(String, String, String)])
-> [OptDescr a] -> [(String, String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OptDescr a -> [(String, String, String)]
forall a. OptDescr a -> [(String, String, String)]
fmtOpt) [OptDescr a]
optDescr
table :: [String]
table = (String -> String -> String -> String)
-> [String] -> [String] -> [String] -> [String]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 String -> String -> String -> String
paste ([String] -> [String]
sameLen [String]
ss) ([String] -> [String]
sameLen [String]
ls) [String]
ds
paste :: String -> String -> String -> String
paste String
x String
y String
z = String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
z
sameLen :: [String] -> [String]
sameLen [String]
xs = Int -> [String] -> [String]
flushLeft (([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([String] -> [Int]) -> [String] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [String]
xs) [String]
xs
flushLeft :: Int -> [String] -> [String]
flushLeft Int
n [String]
xs = [ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n (String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat Char
' ') | String
x <- [String]
xs ]
fmtOpt :: OptDescr a -> [(String,String,String)]
fmtOpt :: forall a. OptDescr a -> [(String, String, String)]
fmtOpt (Option String
sos [String]
los ArgDescr a
ad String
descr) =
case String -> [String]
lines String
descr of
[] -> [(String
sosFmt,String
losFmt,String
"")]
(String
d:[String]
ds) -> (String
sosFmt,String
losFmt,String
d) (String, String, String)
-> [(String, String, String)] -> [(String, String, String)]
forall a. a -> [a] -> [a]
: [ (String
"",String
"",String
d') | String
d' <- [String]
ds ]
where sepBy :: Char -> [String] -> String
sepBy Char
_ [] = String
""
sepBy Char
_ [String
x] = String
x
sepBy Char
ch (String
x:[String]
xs) = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
chChar -> String -> String
forall a. a -> [a] -> [a]
:Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:Char -> [String] -> String
sepBy Char
ch [String]
xs
sosFmt :: String
sosFmt = Char -> [String] -> String
sepBy Char
',' ((Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ArgDescr a -> Char -> String
forall a. ArgDescr a -> Char -> String
fmtShort ArgDescr a
ad) String
sos)
losFmt :: String
losFmt = Char -> [String] -> String
sepBy Char
',' ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ArgDescr a -> String -> String
forall a. ArgDescr a -> String -> String
fmtLong ArgDescr a
ad) [String]
los)
fmtShort :: ArgDescr a -> Char -> String
fmtShort :: forall a. ArgDescr a -> Char -> String
fmtShort (NoArg a
_ ) Char
so = String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
so]
fmtShort (ReqArg String -> a
_ String
ad) Char
so = String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
so] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad
fmtShort (OptArg Maybe String -> a
_ String
ad) Char
so = String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
so] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
fmtLong :: ArgDescr a -> String -> String
fmtLong :: forall a. ArgDescr a -> String -> String
fmtLong (NoArg a
_ ) String
lo = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo
fmtLong (ReqArg String -> a
_ String
ad) String
lo = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad
fmtLong (OptArg Maybe String -> a
_ String
ad) String
lo = String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
getOpt :: ArgOrder a
-> [OptDescr a]
-> [String]
-> ([a],[String],[String])
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
errUnrec [String]
us)
where ([a]
os,[String]
xs,[String]
us,[String]
es) = ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' ArgOrder a
ordering [OptDescr a]
optDescr [String]
args
getOpt' :: ArgOrder a
-> [OptDescr a]
-> [String]
-> ([a],[String], [String] ,[String])
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
oa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
os,[String]
xs,[String]
us,[String]
es)
procNextOpt (UnreqOpt String
u) ArgOrder a
_ = ([a]
os,[String]
xs,String
uString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
us,[String]
es)
procNextOpt (NonOpt String
x) ArgOrder a
RequireOrder = ([],String
xString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rest,[],[])
procNextOpt (NonOpt String
x) ArgOrder a
Permute = ([a]
os,String
xString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs,[String]
us,[String]
es)
procNextOpt (NonOpt String
x) (ReturnInOrder String -> a
f) = (String -> a
f String
x a -> [a] -> [a]
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) = ((String -> a) -> [String] -> [a]
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
eString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
es)
(OptKind a
opt,[String]
rest) = String -> [String] -> [OptDescr a] -> (OptKind a, [String])
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) = ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' ArgOrder a
ordering [OptDescr a]
optDescr [String]
rest
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]
_ = (OptKind a
forall a. OptKind a
EndOfOpts,[String]
rest)
getNext (Char
'-':Char
'-':String
xs) [String]
rest [OptDescr a]
optDescr = String -> [String] -> [OptDescr a] -> (OptKind a, [String])
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 = Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String])
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]
_ = (String -> OptKind a
forall a. String -> OptKind a
NonOpt String
a,[String]
rest)
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) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
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
, (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> String -> Bool
p String
opt) [String]
xs Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe String
forall a. Maybe a
Nothing ]
exact :: [OptDescr a]
exact = (String -> String -> Bool) -> [OptDescr a]
getWith String -> String -> 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 (String -> String -> Bool) -> [OptDescr a]
getWith String -> String -> Bool
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
"--"String -> String -> 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 = ([OptDescr a] -> String -> OptKind a
forall a. [OptDescr a] -> String -> OptKind a
errAmbig [OptDescr a]
options String
optStr,[String]
rest)
long [NoArg a
a ] [] [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt a
a,[String]
rest)
long [NoArg a
_ ] (Char
'=':String
_) [String]
rest = (String -> OptKind a
forall a. String -> OptKind a
errNoArg String
optStr,[String]
rest)
long [ReqArg String -> a
_ String
d] [] [] = (String -> String -> OptKind a
forall a. String -> String -> OptKind a
errReq String
d String
optStr,[])
long [ReqArg String -> a
f String
_] [] (String
r:[String]
rest) = (a -> OptKind a
forall a. a -> OptKind a
Opt (String -> a
f String
r),[String]
rest)
long [ReqArg String -> a
f String
_] (Char
'=':String
xs) [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt (String -> a
f String
xs),[String]
rest)
long [OptArg Maybe String -> a
f String
_] [] [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt (Maybe String -> a
f Maybe String
forall a. Maybe a
Nothing),[String]
rest)
long [OptArg Maybe String -> a
f String
_] (Char
'=':String
xs) [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt (Maybe String -> a
f (String -> Maybe String
forall a. a -> Maybe a
Just String
xs)),[String]
rest)
long [ArgDescr a]
_ String
_ [String]
rest = (String -> OptKind a
forall a. String -> OptKind a
UnreqOpt (String
"--"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ls),[String]
rest)
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 Char -> Char -> Bool
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
'-'Char -> String -> String
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 = ([OptDescr a] -> String -> OptKind a
forall a. [OptDescr a] -> String -> OptKind a
errAmbig [OptDescr a]
options String
optStr,[String]
rest)
short (NoArg a
a :[ArgDescr a]
_) [] [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt a
a,[String]
rest)
short (NoArg a
a :[ArgDescr a]
_) String
xs [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt a
a,(Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:String
xs)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rest)
short (ReqArg String -> a
_ String
d:[ArgDescr a]
_) [] [] = (String -> String -> OptKind a
forall a. String -> String -> OptKind a
errReq String
d String
optStr,[])
short (ReqArg String -> a
f String
_:[ArgDescr a]
_) [] (String
r:[String]
rest) = (a -> OptKind a
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 = (a -> OptKind a
forall a. a -> OptKind a
Opt (String -> a
f String
xs),[String]
rest)
short (OptArg Maybe String -> a
f String
_:[ArgDescr a]
_) [] [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt (Maybe String -> a
f Maybe String
forall a. Maybe a
Nothing),[String]
rest)
short (OptArg Maybe String -> a
f String
_:[ArgDescr a]
_) String
xs [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt (Maybe String -> a
f (String -> Maybe String
forall a. a -> Maybe a
Just String
xs)),[String]
rest)
short [] [] [String]
rest = (String -> OptKind a
forall a. String -> OptKind a
UnreqOpt String
optStr,[String]
rest)
short [] String
xs [String]
rest = (String -> OptKind a
forall a. String -> OptKind a
UnreqOpt String
optStr,(Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:String
xs)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rest)
errAmbig :: [OptDescr a] -> String -> OptKind a
errAmbig :: forall a. [OptDescr a] -> String -> OptKind a
errAmbig [OptDescr a]
ods String
optStr = String -> OptKind a
forall a. String -> OptKind a
OptErr (String -> [OptDescr a] -> String
forall a. String -> [OptDescr a] -> String
usageInfo String
header [OptDescr a]
ods)
where header :: String
header = String
"option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optStr String -> String -> String
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 = String -> OptKind a
forall a. String -> OptKind a
OptErr (String
"option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' requires an argument " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
errUnrec :: String -> String
errUnrec :: String -> String
errUnrec String
optStr = String
"unrecognized option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\n"
errNoArg :: String -> OptKind a
errNoArg :: forall a. String -> OptKind a
errNoArg String
optStr = String -> OptKind a
forall a. String -> OptKind a
OptErr (String
"option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' doesn't allow an argument\n")