module System.Console.MultiArg.Combinator (
notFollowedBy,
OptSpec(OptSpec, longOpts, shortOpts, argSpec),
ArgSpec(NoArg, OptionalArg, OneArg, TwoArg,
ThreeArg, VariableArg, ChoiceArg),
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 )
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)
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)]
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
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
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
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))
shortOneArg :: (String -> a) -> Parser a
shortOneArg f = f <$> firstShortArg
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
shortThreeArg :: (String -> String -> String -> a) -> Parser a
shortThreeArg f = f <$> firstShortArg <*> nextWord <*> nextWord
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))
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 "Other errors:\n" ++ gen
unk = if any (== Unknown) ls then "Unknown error\n" else ""