module System.Console.MultiArg.Combinator (
notFollowedBy,
OptSpec(OptSpec, longOpts, shortOpts, argSpec),
InputError(..),
reader,
optReader,
ArgSpec(..),
parseOption,
formatError
) where
import Data.List (isPrefixOf, intersperse, nubBy)
import Data.Set ( Set )
import qualified Data.Set as Set
import Control.Applicative
((<*>), optional, (<$), (*>), (<|>), many)
import System.Console.MultiArg.Prim
( Parser, try, approxLongOpt,
nextWord, pendingShortOptArg, nonOptionPosArg,
pendingShortOpt, nonPendingShortOpt, nextWord, (<?>),
Error(..), Description(..))
import System.Console.MultiArg.Option
( LongOpt, ShortOpt, unLongOpt,
makeLongOpt, makeShortOpt, unShortOpt )
import qualified Data.Map as M
import Data.Map ((!))
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid ( mconcat )
import Text.Read (readMaybe)
notFollowedBy :: Parser a -> Parser ()
notFollowedBy p =
() <$ ((try p >> fail "notFollowedBy failed")
<|> return ())
unsafeShortOpt :: Char -> ShortOpt
unsafeShortOpt c =
fromMaybe (error $ "invalid short option: " ++ [c])
(makeShortOpt c)
unsafeLongOpt :: String -> LongOpt
unsafeLongOpt c =
fromMaybe (error $ "invalid long option: " ++ c)
(makeLongOpt c)
data OptSpec a = OptSpec {
longOpts :: [String]
, shortOpts :: [Char]
, argSpec :: ArgSpec a
}
instance Functor OptSpec where
fmap f (OptSpec ls ss as) = OptSpec ls ss (fmap f as)
reader :: Read a => String -> Either InputError a
reader s = case readMaybe s of
Just a -> return a
Nothing -> Left . ErrorMsg $ "could not parse option argument"
optReader
:: Read a
=> Maybe String
-> Either InputError (Maybe a)
optReader ms = case ms of
Nothing -> return Nothing
Just s -> case readMaybe s of
Just a -> return (Just a)
_ -> Left . ErrorMsg $ "could not parse option argument"
data InputError
= NoMsg
| ErrorMsg String
deriving (Eq, Show)
errorMsg
:: Either LongOpt ShortOpt
-> [String]
-> InputError
-> String
errorMsg badOpt ss err = arg ++ opt ++ msg
where
arg = let aw = if length ss > 1 then "arguments " else "argument "
ws = concat . intersperse " " . map quote $ ss
quote s = "\"" ++ s ++ "\""
in aw ++ ws
opt = " to option " ++ optDesc
optDesc = case badOpt of
Left lo -> "--" ++ unLongOpt lo
Right so -> "-" ++ [unShortOpt so]
msg = " invalid" ++ detail
detail = case err of
NoMsg -> ""
ErrorMsg s -> ": " ++ s
data ArgSpec a =
NoArg a
| OptionalArg (Maybe String -> Either InputError a)
| OneArg (String -> Either InputError a)
| TwoArg (String -> String -> Either InputError a)
| ThreeArg (String -> String -> String -> Either InputError a)
| VariableArg ([String] -> Either InputError a)
| ChoiceArg [(String, a)]
instance Functor ArgSpec where
fmap f a = case a of
NoArg i -> NoArg $ f i
ChoiceArg gs ->
ChoiceArg . map (\(s, r) -> (s, f r)) $ gs
OptionalArg g -> OptionalArg $ \ms -> fmap f (g ms)
OneArg g ->
OneArg $ \s1 -> fmap f (g s1)
TwoArg g ->
TwoArg $ \s1 s2 -> fmap f (g s1 s2)
ThreeArg g ->
ThreeArg $ \s1 s2 s3 -> fmap f (g s1 s2 s3)
VariableArg g ->
VariableArg $ \ls -> fmap f (g ls)
parseOption :: [OptSpec a] -> Parser a
parseOption os =
let longs = longOptParser os
in case mconcat ([shortOpt] <*> os) of
Nothing -> longs
Just shorts -> longs <|> shorts
longOptParser :: [OptSpec a] -> Parser a
longOptParser os = longOpt (longOptSet os) (longOptMap os)
longOptSet :: [OptSpec a] -> Set LongOpt
longOptSet = Set.fromList . concatMap toOpts where
toOpts = map unsafeLongOpt . longOpts
longOptMap :: [OptSpec a] -> M.Map LongOpt (ArgSpec a)
longOptMap = M.fromList . concatMap toPairs where
toPairs (OptSpec los _ as) = map (toPair as) los where
toPair a s = (unsafeLongOpt s, a)
longOpt ::
Set LongOpt
-> M.Map LongOpt (ArgSpec a)
-> Parser a
longOpt set mp = do
(_, lo, maybeArg) <- approxLongOpt set
let spec = mp ! lo
maybeNextArg = maybe nextWord return maybeArg
case spec of
NoArg a -> case maybeArg of
Nothing -> return a
Just _ -> fail $ "option " ++ unLongOpt lo
++ " does not take argument"
ChoiceArg ls -> do
s <- maybeNextArg
case matchAbbrev ls s of
Nothing -> fail $ "option " ++ unLongOpt lo
++ " requires an argument: "
++ (concat . intersperse ", " . map fst $ ls)
Just g -> return g
OptionalArg f -> case maybeArg of
Nothing -> either (fail . errorMsg (Left lo) []) return
$ f Nothing
Just s -> either (fail . errorMsg (Left lo) [s]) return
$ f (Just s)
OneArg f -> maybeNextArg >>= g
where
g a = either (fail . errorMsg (Left lo) [a]) return
$ f a
TwoArg f -> do
a1 <- maybeNextArg
a2 <- nextWord
either (fail . errorMsg (Left lo) [a1, a2]) return
$ f a1 a2
ThreeArg f -> do
a1 <- maybeNextArg
a2 <- nextWord
a3 <- nextWord
either (fail . errorMsg (Left lo) [a1, a2, a3]) return
$ f a1 a2 a3
VariableArg f -> do
as <- many nonOptionPosArg
let args = case maybeArg of
Nothing -> as
Just a -> a:as
either (fail . errorMsg (Left lo) args) return
$ f args
shortOpt :: OptSpec a -> Maybe (Parser a)
shortOpt o = mconcat parsers where
parsers = map mkParser . shortOpts $ o
mkParser c =
let opt = unsafeShortOpt c
in Just $ nextShort opt *> case argSpec o of
NoArg a -> return a
ChoiceArg ls -> shortChoiceArg opt ls
OptionalArg f -> shortOptionalArg opt f
OneArg f -> shortOneArg opt f
TwoArg f -> shortTwoArg opt f
ThreeArg f -> shortThreeArg opt f
VariableArg f -> shortVariableArg opt f
nextShort :: ShortOpt -> Parser ()
nextShort o = p <?> ("short option: -" ++ [unShortOpt o])
where
p = do
r1 <- optional $ pendingShortOpt o
case r1 of
Just () -> return ()
Nothing -> nonPendingShortOpt o
shortVariableArg
:: ShortOpt
-> ([String] -> Either InputError a)
-> Parser a
shortVariableArg so f = do
maybeSameWordArg <- optional pendingShortOptArg
args <- many nonOptionPosArg
let as = case maybeSameWordArg of
Nothing -> args
Just a -> a:args
either (fail . errorMsg (Right so) as) return $ f as
shortOneArg
:: ShortOpt
-> (String -> Either InputError a)
-> Parser a
shortOneArg so f = do
a <- firstShortArg
either (fail . errorMsg (Right so) [a]) return $ f a
firstShortArg :: Parser String
firstShortArg =
optional pendingShortOptArg >>= maybe nextWord return
shortChoiceArg :: ShortOpt -> [(String, a)] -> Parser a
shortChoiceArg opt ls =
firstShortArg
>>= maybe err return . matchAbbrev ls
where
err = fail $ "option " ++ [unShortOpt opt] ++ " requires "
++ "one argument: "
++ (concat . intersperse " " . map fst $ ls)
shortTwoArg
:: ShortOpt
-> (String -> String -> Either InputError a)
-> Parser a
shortTwoArg so f = do
a1 <- firstShortArg
a2 <- nextWord
either (fail . errorMsg (Right so) [a1, a2]) return
$ f a1 a2
shortThreeArg
:: ShortOpt
-> (String -> String -> String -> Either InputError a)
-> Parser a
shortThreeArg so f = do
a1 <- firstShortArg
a2 <- nextWord
a3 <- nextWord
either (fail . errorMsg (Right so) [a1, a2, a3]) return
$ f a1 a2 a3
shortOptionalArg
:: ShortOpt
-> (Maybe String -> Either InputError a)
-> Parser a
shortOptionalArg so f = do
maybeSameWordArg <- optional pendingShortOptArg
case maybeSameWordArg of
Nothing -> do
maybeArg <- optional nonOptionPosArg
case maybeArg of
Nothing -> either (fail . errorMsg (Right so) []) return
$ f Nothing
Just a -> either (fail . errorMsg (Right so) [a]) return
$ f (Just a)
Just a -> either (fail . errorMsg (Right so) [a]) return
$ f (Just a)
matchAbbrev :: [(String, a)] -> String -> Maybe a
matchAbbrev ls s =
let ls' = nubBy (\x y -> fst x == fst y) ls
in case lookup s ls' of
Just a -> return a
Nothing ->
let pdct (t, _) = s `isPrefixOf` t
in case filter pdct ls of
(_, a):[] -> return a
_ -> Nothing
formatError
:: String
-> Error
-> String
formatError p (Error loc ls) =
p ++ ": error: could not parse command line.\n"
++ "Error at: " ++ loc ++ "\n"
++ expError
++ genError
++ unk
where
toExp m = case m of { Expected s -> Just s; _ -> Nothing }
expc = unlines . mapMaybe toExp $ ls
expError = if null expc then "" else "Expecting:\n" ++ expc
toGeneral m = case m of { General s -> Just s; _ -> Nothing }
gen = unlines . mapMaybe toGeneral $ ls
genError = if null gen
then ""
else let sep = if null expError
then "" else "\n"
in sep ++ gen
unk = if any (== Unknown) ls then "Unknown error\n" else ""