{-# 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 :: (a -> b) -> ArgOrder a -> ArgOrder b
fmap _ RequireOrder = ArgOrder b
forall a. ArgOrder a
RequireOrder
fmap _ Permute = ArgOrder b
forall a. ArgOrder a
Permute
fmap f :: a -> b
f (ReturnInOrder g :: 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 :: (a -> b) -> OptDescr a -> OptDescr b
fmap f :: a -> b
f (Option a :: String
a b :: [String]
b argDescr :: ArgDescr a
argDescr c :: 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 (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 :: (a -> b) -> ArgDescr a -> ArgDescr b
fmap f :: a -> b
f (NoArg a :: a
a) = b -> ArgDescr b
forall a. a -> ArgDescr a
NoArg (a -> b
f a
a)
fmap f :: a -> b
f (ReqArg g :: String -> a
g s :: 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 f :: a -> b
f (OptArg g :: Maybe String -> a
g s :: 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 :: String -> [OptDescr a] -> String
usageInfo header :: String
header optDescr :: [OptDescr a]
optDescr = [String] -> String
unlines (String
headerString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
table)
where (ss :: [String]
ss,ls :: [String]
ls,ds :: [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 x :: String
x y :: String
y z :: String
z = " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
z
sameLen :: [String] -> [String]
sameLen xs :: [String]
xs = Int -> [String] -> [String]
flushLeft (([Int] -> Int
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 (t :: * -> *) a. Foldable t => t a -> Int
length) [String]
xs) [String]
xs
flushLeft :: Int -> [String] -> [String]
flushLeft n :: Int
n xs :: [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 ' ') | String
x <- [String]
xs ]
fmtOpt :: OptDescr a -> [(String,String,String)]
fmtOpt :: OptDescr a -> [(String, String, String)]
fmtOpt (Option sos :: String
sos los :: [String]
los ad :: ArgDescr a
ad descr :: String
descr) =
case String -> [String]
lines String
descr of
[] -> [(String
sosFmt,String
losFmt,"")]
(d :: String
d:ds :: [String]
ds) -> (String
sosFmt,String
losFmt,String
d) (String, String, String)
-> [(String, String, String)] -> [(String, String, String)]
forall a. a -> [a] -> [a]
: [ ("","",String
d') | String
d' <- [String]
ds ]
where sepBy :: Char -> [String] -> String
sepBy _ [] = ""
sepBy _ [x :: String
x] = String
x
sepBy ch :: Char
ch (x :: String
x:xs :: [String]
xs) = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
chChar -> String -> String
forall a. a -> [a] -> [a]
:' 'Char -> String -> String
forall a. a -> [a] -> [a]
:Char -> [String] -> String
sepBy Char
ch [String]
xs
sosFmt :: String
sosFmt = Char -> [String] -> String
sepBy ',' ((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 ',' ((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 :: ArgDescr a -> Char -> String
fmtShort (NoArg _ ) so :: Char
so = "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
so]
fmtShort (ReqArg _ ad :: String
ad) so :: Char
so = "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
so] String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad
fmtShort (OptArg _ ad :: String
ad) so :: Char
so = "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
so] String -> String -> String
forall a. [a] -> [a] -> [a]
++ "[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]"
fmtLong :: ArgDescr a -> String -> String
fmtLong :: ArgDescr a -> String -> String
fmtLong (NoArg _ ) lo :: String
lo = "--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo
fmtLong (ReqArg _ ad :: String
ad) lo :: String
lo = "--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo String -> String -> String
forall a. [a] -> [a] -> [a]
++ "=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad
fmtLong (OptArg _ ad :: String
ad) lo :: String
lo = "--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lo String -> String -> String
forall a. [a] -> [a] -> [a]
++ "[=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ad String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]"
getOpt :: ArgOrder a
-> [OptDescr a]
-> [String]
-> ([a],[String],[String])
getOpt :: ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ordering :: ArgOrder a
ordering optDescr :: [OptDescr a]
optDescr args :: [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 (os :: [a]
os,xs :: [String]
xs,us :: [String]
us,es :: [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' :: ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' _ _ [] = ([],[],[],[])
getOpt' ordering :: ArgOrder a
ordering optDescr :: [OptDescr a]
optDescr (arg :: String
arg:args :: [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 o :: a
o) _ = (a
oa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
os,[String]
xs,[String]
us,[String]
es)
procNextOpt (UnreqOpt u :: String
u) _ = ([a]
os,[String]
xs,String
uString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
us,[String]
es)
procNextOpt (NonOpt x :: String
x) RequireOrder = ([],String
xString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rest,[],[])
procNextOpt (NonOpt x :: String
x) Permute = ([a]
os,String
xString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs,[String]
us,[String]
es)
procNextOpt (NonOpt x :: String
x) (ReturnInOrder f :: 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 EndOfOpts RequireOrder = ([],[String]
rest,[],[])
procNextOpt EndOfOpts Permute = ([],[String]
rest,[],[])
procNextOpt EndOfOpts (ReturnInOrder f :: String -> a
f) = ((String -> a) -> [String] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map String -> a
f [String]
rest,[],[],[])
procNextOpt (OptErr e :: String
e) _ = ([a]
os,[String]
xs,[String]
us,String
eString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
es)
(opt :: OptKind a
opt,rest :: [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
(os :: [a]
os,xs :: [String]
xs,us :: [String]
us,es :: [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 :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])
getNext ('-':'-':[]) rest :: [String]
rest _ = (OptKind a
forall a. OptKind a
EndOfOpts,[String]
rest)
getNext ('-':'-':xs :: String
xs) rest :: [String]
rest optDescr :: [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 ('-': x :: Char
x :xs :: String
xs) rest :: [String]
rest optDescr :: [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 a :: String
a rest :: [String]
rest _ = (String -> OptKind a
forall a. String -> OptKind a
NonOpt String
a,[String]
rest)
longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])
longOpt ls :: String
ls rs :: [String]
rs optDescr :: [OptDescr a]
optDescr = [ArgDescr a] -> String -> [String] -> (OptKind a, [String])
long [ArgDescr a]
ads String
arg [String]
rs
where (opt :: String
opt,arg :: 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
=='=') String
ls
getWith :: (String -> String -> Bool) -> [OptDescr a]
getWith p :: String -> String -> Bool
p = [ OptDescr a
o | o :: OptDescr a
o@(Option _ xs :: [String]
xs _ _) <- [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 (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 _ _ ad :: ArgDescr a
ad _ <- [OptDescr a]
options ]
optStr :: String
optStr = ("--"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
opt)
long :: [ArgDescr a] -> String -> [String] -> (OptKind a, [String])
long (_:_:_) _ rest :: [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
a ] [] rest :: [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt a
a,[String]
rest)
long [NoArg _ ] ('=':_) rest :: [String]
rest = (String -> OptKind a
forall a. String -> OptKind a
errNoArg String
optStr,[String]
rest)
long [ReqArg _ d :: String
d] [] [] = (String -> String -> OptKind a
forall a. String -> String -> OptKind a
errReq String
d String
optStr,[])
long [ReqArg f :: String -> a
f _] [] (r :: String
r:rest :: [String]
rest) = (a -> OptKind a
forall a. a -> OptKind a
Opt (String -> a
f String
r),[String]
rest)
long [ReqArg f :: String -> a
f _] ('=':xs :: String
xs) rest :: [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt (String -> a
f String
xs),[String]
rest)
long [OptArg f :: Maybe String -> a
f _] [] rest :: [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 f :: Maybe String -> a
f _] ('=':xs :: String
xs) rest :: [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 _ _ rest :: [String]
rest = (String -> OptKind a
forall a. String -> OptKind a
UnreqOpt ("--"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ls),[String]
rest)
shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String])
shortOpt y :: Char
y ys :: String
ys rs :: [String]
rs optDescr :: [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 ss :: String
ss _ _ _) <- [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 _ _ ad :: ArgDescr a
ad _ <- [OptDescr a]
options ]
optStr :: String
optStr = '-'Char -> String -> String
forall a. a -> [a] -> [a]
:[Char
y]
short :: [ArgDescr a] -> String -> [String] -> (OptKind a, [String])
short (_:_:_) _ rest :: [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
a :_) [] rest :: [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt a
a,[String]
rest)
short (NoArg a :: a
a :_) xs :: String
xs rest :: [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt a
a,('-'Char -> String -> String
forall a. a -> [a] -> [a]
:String
xs)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
rest)
short (ReqArg _ d :: String
d:_) [] [] = (String -> String -> OptKind a
forall a. String -> String -> OptKind a
errReq String
d String
optStr,[])
short (ReqArg f :: String -> a
f _:_) [] (r :: String
r:rest :: [String]
rest) = (a -> OptKind a
forall a. a -> OptKind a
Opt (String -> a
f String
r),[String]
rest)
short (ReqArg f :: String -> a
f _:_) xs :: String
xs rest :: [String]
rest = (a -> OptKind a
forall a. a -> OptKind a
Opt (String -> a
f String
xs),[String]
rest)
short (OptArg f :: Maybe String -> a
f _:_) [] rest :: [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 f :: Maybe String -> a
f _:_) xs :: String
xs rest :: [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 [] [] rest :: [String]
rest = (String -> OptKind a
forall a. String -> OptKind a
UnreqOpt String
optStr,[String]
rest)
short [] xs :: String
xs rest :: [String]
rest = (String -> OptKind a
forall a. String -> OptKind a
UnreqOpt String
optStr,('-'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 :: [OptDescr a] -> String -> OptKind a
errAmbig ods :: [OptDescr a]
ods optStr :: 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 = "option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' is ambiguous; could be one of:"
errReq :: String -> String -> OptKind a
errReq :: String -> String -> OptKind a
errReq d :: String
d optStr :: String
optStr = String -> OptKind a
forall a. String -> OptKind a
OptErr ("option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' requires an argument " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n")
errUnrec :: String -> String
errUnrec :: String -> String
errUnrec optStr :: String
optStr = "unrecognized option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'\n"
errNoArg :: String -> OptKind a
errNoArg :: String -> OptKind a
errNoArg optStr :: String
optStr = String -> OptKind a
forall a. String -> OptKind a
OptErr ("option `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
optStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' doesn't allow an argument\n")