module GF.Infra.GetOpt (
getOpt, getOpt',
usageInfo,
ArgOrder(..),
OptDescr(..),
ArgDescr(..),
) where
import Prelude
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
data OptKind a
= Opt a
| UnreqOpt String
| NonOpt String
| EndOfOpts
| OptErr String
usageInfo :: String
-> [OptDescr a]
-> String
usageInfo :: 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 (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 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 :: 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 :: 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 :: 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 :: 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' :: 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 :: 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
'-' :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 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 :: 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
options :: [OptDescr a]
options = [ OptDescr a
o | o :: OptDescr a
o@(Option String
ss [String]
xs ArgDescr a
_ String
_) <- [OptDescr a]
optDescr
, String
opt String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> String
forall a. a -> [a] -> [a]
:[]) String
ss Bool -> Bool -> Bool
|| String
opt String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
xs ]
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)
errAmbig :: [OptDescr a] -> String -> OptKind a
errAmbig :: [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 :: 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 :: 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")