module Distribution.GetOpt (
getOpt, getOpt',
usageInfo,
ArgOrder(..),
OptDescr(..),
ArgDescr(..),
) where
import Prelude ()
import Distribution.Compat.Prelude
data ArgOrder a
= RequireOrder
| Permute
data OptDescr a =
Option [Char]
[String]
(ArgDescr a)
String
instance Functor OptDescr where
fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c
data ArgDescr a
= NoArg a
| ReqArg (String -> Either String a) String
| OptArg (Maybe String -> Either String a) String
instance Functor ArgDescr where
fmap f (NoArg a) = NoArg (f a)
fmap f (ReqArg g s) = ReqArg (fmap f . g) s
fmap f (OptArg g s) = OptArg (fmap f . g) s
data OptKind a
= Opt a
| UnreqOpt String
| NonOpt String
| EndOfOpts
| OptErr String
data OptHelp = OptHelp {
optNames :: String,
optHelp :: String
}
usageInfo :: String
-> [OptDescr a]
-> String
usageInfo header optDescr = unlines (header : table)
where
options = flip map optDescr $ \(Option sos los ad d) ->
OptHelp
{ optNames =
intercalate ", " $
map (fmtShort ad) sos ++
map (fmtLong ad) (take 1 los)
, optHelp = d
}
maxOptNameWidth = 30
descolWidth = 80 (maxOptNameWidth + 3)
table :: [String]
table = do
OptHelp{optNames, optHelp} <- options
let wrappedHelp = wrapText descolWidth optHelp
if length optNames >= maxOptNameWidth
then [" " ++ optNames] ++
renderColumns [] wrappedHelp
else renderColumns [optNames] wrappedHelp
renderColumns :: [String] -> [String] -> [String]
renderColumns xs ys = do
(x, y) <- zipDefault "" "" xs ys
return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y
padTo n x = take n (x ++ repeat ' ')
zipDefault :: a -> b -> [a] -> [b] -> [(a,b)]
zipDefault _ _ [] [] = []
zipDefault _ bd (a:as) [] = (a,bd) : map (,bd) as
zipDefault ad _ [] (b:bs) = (ad,b) : map (ad,) bs
zipDefault ad bd (a:as) (b:bs) = (a,b) : zipDefault ad bd as bs
fmtShort :: ArgDescr a -> Char -> String
fmtShort (NoArg _ ) so = "-" ++ [so]
fmtShort (ReqArg _ _) so = "-" ++ [so]
fmtShort (OptArg _ _) so = "-" ++ [so]
fmtLong :: ArgDescr a -> String -> String
fmtLong (NoArg _ ) lo = "--" ++ lo
fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
wrapText :: Int -> String -> [String]
wrapText width = map unwords . wrap 0 [] . words
where wrap :: Int -> [String] -> [String] -> [[String]]
wrap 0 [] (w:ws)
| length w + 1 > width
= wrap (length w) [w] ws
wrap col line (w:ws)
| col + length w + 1 > width
= reverse line : wrap 0 [] (w:ws)
wrap col line (w:ws)
= let col' = col + length w + 1
in wrap col' (w:line) ws
wrap _ [] [] = []
wrap _ line [] = [reverse line]
getOpt :: ArgOrder a
-> [OptDescr a]
-> [String]
-> ([a],[String],[String])
getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
where (os,xs,us,es) = getOpt' ordering optDescr args
getOpt' :: ArgOrder a
-> [OptDescr a]
-> [String]
-> ([a],[String], [String] ,[String])
getOpt' _ _ [] = ([],[],[],[])
getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
where procNextOpt (Opt o) _ = (o:os,xs,us,es)
procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
procNextOpt EndOfOpts Permute = ([],rest,[],[])
procNextOpt (OptErr e) _ = (os,xs,us,e:es)
(opt,rest) = getNext arg args optDescr
(os,xs,us,es) = getOpt' ordering optDescr rest
getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
getNext a rest _ = (NonOpt a,rest)
longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
longOpt ls rs optDescr = long ads arg rs
where (opt,arg) = break (=='=') ls
getWith p = [ o | o@(Option _ xs _ _) <- optDescr
, isJust (find (p opt) xs)]
exact = getWith (==)
options = if null exact then getWith isPrefixOf else exact
ads = [ ad | Option _ _ ad _ <- options ]
optStr = "--" ++ opt
fromRes = fromParseResult optStr
long (_:_:_) _ rest = (errAmbig options optStr,rest)
long [NoArg a ] [] rest = (Opt a,rest)
long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
long [ReqArg _ d] [] [] = (errReq d optStr,[])
long [ReqArg f _] [] (r:rest) = (fromRes (f r),rest)
long [ReqArg f _] ('=':xs) rest = (fromRes (f xs),rest)
long [OptArg f _] [] rest = (fromRes (f Nothing),rest)
long [OptArg f _] ('=':xs) rest = (fromRes (f (Just xs)),rest)
long _ _ rest = (UnreqOpt ("--"++ls),rest)
shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
shortOpt y ys rs optDescr = short ads ys rs
where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]
ads = [ ad | Option _ _ ad _ <- options ]
optStr = '-':[y]
fromRes = fromParseResult optStr
short (_:_:_) _ rest = (errAmbig options optStr,rest)
short (NoArg a :_) [] rest = (Opt a,rest)
short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
short (ReqArg f _:_) [] (r:rest) = (fromRes (f r),rest)
short (ReqArg f _:_) xs rest = (fromRes (f xs),rest)
short (OptArg f _:_) [] rest = (fromRes (f Nothing),rest)
short (OptArg f _:_) xs rest = (fromRes (f (Just xs)),rest)
short [] [] rest = (UnreqOpt optStr,rest)
short [] xs rest = (UnreqOpt (optStr++xs),rest)
fromParseResult :: String -> Either String a -> OptKind a
fromParseResult optStr res = case res of
Right x -> Opt x
Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n")
errAmbig :: [OptDescr a] -> String -> OptKind b
errAmbig ods optStr = OptErr (usageInfo header ods)
where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
errReq :: String -> String -> OptKind a
errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
errUnrec :: String -> String
errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
errNoArg :: String -> OptKind a
errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")