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 -> a)
| OneArg (String -> a)
| TwoArg (String -> String -> a)
| ThreeArg (String -> String -> String -> a)
| VariableArg ([String] -> a)
| ChoiceArg [(String, a)]
| OptionalArgE (Maybe String -> Either InputError a)
| OneArgE (String -> Either InputError a)
| TwoArgE (String -> String -> Either InputError a)
| ThreeArgE (String -> String -> String -> Either InputError a)
| VariableArgE ([String] -> Either InputError a)
instance Functor ArgSpec where
fmap f a = case a of
NoArg i -> NoArg $ f i
OptionalArg g ->
OptionalArg $ \ms -> f (g ms)
OneArg g ->
OneArg $ \s1 -> f (g s1)
TwoArg g ->
TwoArg $ \s1 s2 -> f (g s1 s2)
ThreeArg g ->
ThreeArg $ \s1 s2 s3 -> f (g s1 s2 s3)
VariableArg g ->
VariableArg $ \ls -> f (g ls)
ChoiceArg gs ->
ChoiceArg . map (\(s, r) -> (s, f r)) $ gs
OptionalArgE g -> OptionalArgE $ \ms -> fmap f (g ms)
OneArgE g ->
OneArgE $ \s1 -> fmap f (g s1)
TwoArgE g ->
TwoArgE $ \s1 s2 -> fmap f (g s1 s2)
ThreeArgE g ->
ThreeArgE $ \s1 s2 s3 -> fmap f (g s1 s2 s3)
VariableArgE g ->
VariableArgE $ \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"
OptionalArg f -> return (f maybeArg)
OneArg f -> f <$> maybeNextArg
TwoArg f -> f <$> maybeNextArg <*> nextWord
ThreeArg f -> f <$> maybeNextArg <*> nextWord <*> nextWord
VariableArg f -> do
as <- many nonOptionPosArg
return . f $ case maybeArg of
Nothing -> as
Just a1 -> a1 : as
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
OptionalArgE 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)
OneArgE f -> maybeNextArg >>= g
where
g a = either (fail . errorMsg (Left lo) [a]) return
$ f a
TwoArgE f -> do
a1 <- maybeNextArg
a2 <- nextWord
either (fail . errorMsg (Left lo) [a1, a2]) return
$ f a1 a2
ThreeArgE f -> do
a1 <- maybeNextArg
a2 <- nextWord
a3 <- nextWord
either (fail . errorMsg (Left lo) [a1, a2, a3]) return
$ f a1 a2 a3
VariableArgE 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
OptionalArg f -> shortOptionalArg f
OneArg f -> shortOneArg f
TwoArg f -> shortTwoArg f
ThreeArg f -> shortThreeArg f
VariableArg f -> shortVariableArg f
ChoiceArg ls -> shortChoiceArg opt ls
OptionalArgE f -> shortOptionalArgE opt f
OneArgE f -> shortOneArgE opt f
TwoArgE f -> shortTwoArgE opt f
ThreeArgE f -> shortThreeArgE opt f
VariableArgE f -> shortVariableArgE 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 :: ([String] -> a) -> Parser a
shortVariableArg f = do
maybeSameWordArg <- optional pendingShortOptArg
args <- many nonOptionPosArg
case maybeSameWordArg of
Nothing -> return (f args)
Just arg1 -> return (f (arg1:args))
shortVariableArgE
:: ShortOpt
-> ([String] -> Either InputError a)
-> Parser a
shortVariableArgE 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 :: (String -> a) -> Parser a
shortOneArg f = f <$> firstShortArg
shortOneArgE
:: ShortOpt
-> (String -> Either InputError a)
-> Parser a
shortOneArgE 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 :: (String -> String -> a) -> Parser a
shortTwoArg f = f <$> firstShortArg <*> nextWord
shortTwoArgE
:: ShortOpt
-> (String -> String -> Either InputError a)
-> Parser a
shortTwoArgE so f = do
a1 <- firstShortArg
a2 <- nextWord
either (fail . errorMsg (Right so) [a1, a2]) return
$ f a1 a2
shortThreeArg :: (String -> String -> String -> a) -> Parser a
shortThreeArg f = f <$> firstShortArg <*> nextWord <*> nextWord
shortThreeArgE
:: ShortOpt
-> (String -> String -> String -> Either InputError a)
-> Parser a
shortThreeArgE so f = do
a1 <- firstShortArg
a2 <- nextWord
a3 <- nextWord
either (fail . errorMsg (Right so) [a1, a2, a3]) return
$ f a1 a2 a3
shortOptionalArg :: (Maybe String -> a) -> Parser a
shortOptionalArg f = do
maybeSameWordArg <- optional pendingShortOptArg
case maybeSameWordArg of
Nothing -> do
maybeArg <- optional nonOptionPosArg
case maybeArg of
Nothing -> return (f Nothing)
Just a -> return (f (Just a))
Just a -> return (f (Just a))
shortOptionalArgE
:: ShortOpt
-> (Maybe String -> Either InputError a)
-> Parser a
shortOptionalArgE 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 ""