module System.Console.MultiArg.Prim (
Parser,
parse,
good,
choice,
bind,
lookAhead,
several,
several1,
manyTill,
failString,
genericThrow,
(<?>),
try,
pendingShortOpt,
nonPendingShortOpt,
pendingShortOptArg,
exactLongOpt,
approxLongOpt,
stopper,
resetStopper,
nextWord,
nextWordIs,
nonOptionPosArg,
matchApproxWord,
end,
Description(..),
Error(Error),
InputDesc
) where
import System.Console.MultiArg.Option
(ShortOpt,
unShortOpt,
LongOpt,
unLongOpt,
makeLongOpt )
import Control.Applicative ( Applicative, Alternative, optional )
import qualified Control.Applicative as A
import qualified Control.Monad.Exception.Synchronous as Ex
import qualified Data.Set as Set
import Data.Set ( Set )
import qualified Control.Monad
import Control.Monad ( when, MonadPlus(mzero, mplus), guard, liftM )
import Data.Maybe (mapMaybe)
import Data.Monoid ( Monoid ( mempty, mappend ) )
import qualified Data.List as L
import Data.List (isPrefixOf)
newtype Parser a = Parser { runParser :: State -> Consumed a }
instance Monad Parser where
(>>=) = bind
return = good
fail = failString
instance Functor Parser where
fmap = liftM
instance Applicative Parser where
(<*>) = Control.Monad.ap
pure = return
instance Alternative Parser where
empty = genericThrow
(<|>) = choice
some = several1
many = several
instance Monoid (Parser a) where
mempty = genericThrow
mappend = choice
instance MonadPlus Parser where
mzero = genericThrow
mplus = choice
type PendingShort = String
type Remaining = [String]
type SawStopper = Bool
data State = State PendingShort Remaining SawStopper
type InputDesc = String
data Description = Unknown | General String | Expected String
deriving (Eq, Show, Ord)
data Error = Error InputDesc [Description]
deriving (Eq, Show, Ord)
data Reply a = Ok a State Error
| Fail Error
data Consumed a = Consumed (Reply a)
| Empty (Reply a)
good :: a -> Parser a
good x = Parser $ \st -> Empty (Ok x st (Error (descLocation st) []))
bind :: Parser a -> (a -> Parser b) -> Parser b
bind (Parser p) f = Parser $ \s ->
case p s of
Empty r1 -> case r1 of
Ok x s' _ -> runParser (f x) s'
Fail m -> Empty (Fail m)
Consumed r1 -> Consumed $
case r1 of
Ok x s' _ -> case runParser (f x) s' of
Consumed r -> r
Empty r -> r
Fail e -> Fail e
descLocation :: State -> InputDesc
descLocation (State ps rm st) = pending ++ next ++ stop
where
pending
| null ps = ""
| otherwise = "short option or short option argument: "
++ ps ++ " "
next = case rm of
[] -> "no words remaining"
x:_ -> "next word: " ++ x
stop = if st then " (stopper already seen)" else ""
failString :: String -> Parser a
failString str = Parser $ \s ->
Empty (Fail (Error (descLocation s) [General str]))
genericThrow :: Parser a
genericThrow = Parser $ \s ->
Empty (Fail (Error (descLocation s) [Unknown]))
choice :: Parser a -> Parser a -> Parser a
choice p q = Parser $ \s ->
case runParser p s of
Empty (Fail msg1) ->
case runParser q s of
Empty (Fail msg2) -> mergeError msg1 msg2
Empty (Ok x s' msg2) -> mergeOk x s' msg1 msg2
c -> c
Empty (Ok x s' msg1) ->
case runParser q s of
Empty (Fail msg2) -> mergeOk x s' msg1 msg2
Empty (Ok _ _ msg2) -> mergeOk x s' msg1 msg2
c -> c
c -> c
where
mergeOk x s msg1 msg2 = Empty (Ok x s (merge msg1 msg2))
mergeError msg1 msg2 = Empty (Fail (merge msg1 msg2))
merge (Error loc exp1) (Error _ exp2) =
Error loc (exp1 ++ exp2)
crashOnEmptyOk
:: String
-> Parser a
-> Parser a
crashOnEmptyOk str p = Parser $ \s ->
case runParser p s of
Empty r -> case r of
Ok _ _ _ ->
error $ "multiarg: error: " ++ str
++ " applied to parser that succeeds without "
++ "consuming any input. Aborted to prevent "
++ "an infinite loop."
e -> Empty e
o -> o
several1 :: Parser a -> Parser [a]
several1 p = do
r1 <- p
rs <- several p
return $ r1:rs
several :: Parser a -> Parser [a]
several unwrapped =
let p = crashOnEmptyOk "several" unwrapped
in do
maybeA <- optional p
case maybeA of
Nothing -> return []
Just a -> do
rest <- several unwrapped
return $ a:rest
(<?>) :: Parser a -> String -> Parser a
p <?> str = Parser $ \s ->
case runParser p s of
Empty (Fail m) -> Empty (Fail (expect m str))
Empty (Ok x s' m) -> Empty (Ok x s' (expect m str))
x -> x
where
expect (Error pos ls) s =
let ls' = mapMaybe notExpected ls
notExpected d = case d of
Expected _ -> Nothing
x -> Just x
in Error pos ((Expected s) : ls')
infix 0 <?>
parse
:: [String]
-> Parser a
-> Ex.Exceptional Error a
parse ss p =
let s = State "" ss False
procReply r = case r of
Ok x _ _ -> Ex.Success x
Fail m -> Ex.Exception m
in case runParser p s of
Consumed r -> procReply r
Empty r -> procReply r
pendingShortOpt :: ShortOpt -> Parser ()
pendingShortOpt so = Parser $ \s@(State pends rm stop) ->
let msg = Error (descLocation s)
[Expected ("pending short option: -" ++ [unShortOpt so])]
gd s' = Consumed (Ok () s' msg)
err = Empty (Fail msg)
in maybe err gd $ do
guard $ not stop
(first, rest) <- case pends of
[] -> mzero
x:xs -> return (x, xs)
when (unShortOpt so /= first) mzero
return $ State rest rm stop
lookAhead :: Parser a -> Parser a
lookAhead p = Parser $ \s ->
case runParser p s of
Consumed r -> case r of
Ok x _ e -> Empty (Ok x s e)
e -> Consumed e
e -> e
nextW :: Remaining -> Maybe (String, Remaining)
nextW rm = case rm of
[] -> Nothing
x:xs -> Just (x, xs)
nonPendingShortOpt :: ShortOpt -> Parser ()
nonPendingShortOpt so = Parser $ \s@(State ps rm stop) ->
let dsc = [Expected
$ "non pending short option: -" ++ [unShortOpt so]]
err = Error (descLocation s) dsc
errRet = Empty (Fail err)
gd (ps'', rm'') = Consumed (Ok () (State ps'' rm'' stop) err)
in maybe errRet gd $ do
guard $ null ps
guard $ not stop
(a, rm') <- nextW rm
(maybeDash, word) <- case a of
[] -> mzero
x:xs -> return (x, xs)
guard (maybeDash == '-')
(letter, arg) <- case word of
[] -> mzero
x:xs -> return (x, xs)
guard (letter == unShortOpt so)
return (arg, rm')
exactLongOpt :: LongOpt -> Parser (Maybe String)
exactLongOpt lo = Parser $ \s@(State ps rm sp) ->
let msg = Error (descLocation s)
[Expected ("long option: --" ++ unLongOpt lo)]
gd (arg, newRm) = Consumed (Ok arg (State ps newRm sp) msg)
err = Empty (Fail msg)
in maybe err gd $ do
guard $ null ps
guard $ not sp
(x, rm') <- nextW rm
(word, afterEq) <- getLongOption x
guard (word == unLongOpt lo)
return (afterEq, rm')
getLongOption :: String -> Maybe (String, Maybe String)
getLongOption str = do
guard (str /= "--")
let (pre, word, afterEq) = splitLongWord str
guard (pre == "--")
return (word, afterEq)
splitLongWord :: String -> (String, String, Maybe String)
splitLongWord t = (f, s, r) where
(f, rest) = L.splitAt 2 t
(s, withEq) = L.break (== '=') rest
r = case withEq of
[] -> Nothing
_:xs -> Just xs
approxLongOptError :: [LongOpt] -> [Description]
approxLongOptError =
map (Expected . ("long option: --" ++) . unLongOpt)
approxLongOpt ::
Set LongOpt
-> Parser (String, LongOpt, Maybe String)
approxLongOpt ts = Parser $ \s@(State ps rm stop) ->
let err ls = Error (descLocation s) (approxLongOptError ls)
ert ls = Empty (Fail $ err ls)
gd (found, opt, arg, rm'') =
Consumed (Ok (found, opt, arg) (State ps rm'' stop)
(err allOpts))
allOpts = Set.toList ts
in Ex.switch ert gd $ do
Ex.assert allOpts $ null ps
Ex.assert allOpts $ not stop
(x, rm') <- Ex.fromMaybe allOpts $ nextW rm
(word, afterEq) <- Ex.fromMaybe allOpts $ getLongOption x
opt <- Ex.fromMaybe allOpts $ makeLongOpt word
if Set.member opt ts
then return (word, opt, afterEq, rm')
else do
let p t = word `isPrefixOf` unLongOpt t
matches = Set.filter p ts
case Set.toList matches of
[] -> Ex.throw allOpts
(m:[]) -> return (word, m, afterEq, rm')
ls -> Ex.throw ls
pendingShortOptArg :: Parser String
pendingShortOptArg = Parser $ \st@(State ps rm sp) ->
let msg = [Expected "pending short option argument"]
err = Error (descLocation st) msg
ert = Empty (Fail err)
gd str = Consumed (Ok str (State "" rm sp) err)
in maybe ert gd $ do
guard $ not sp
case ps of
[] -> mzero
xs -> return xs
stopper :: Parser ()
stopper = Parser $ \s@(State ps rm sp) ->
let err = Error (descLocation s)
[Expected "stopper, \"--\""]
ert = Empty (Fail err)
gd rm'' = Consumed (Ok () (State ps rm'' True) err)
in maybe ert gd $ do
guard $ not sp
guard . not . null $ ps
(x, rm') <- nextW rm
guard $ x == "--"
return rm'
resetStopper :: Parser ()
resetStopper = Parser $ \s@(State ps rm _) ->
Empty (Ok () (State ps rm False) (Error (descLocation s) []))
try :: Parser a -> Parser a
try a = Parser $ \s ->
case runParser a s of
Consumed r -> case r of
Fail e -> Empty (Fail e)
o -> Consumed o
o -> o
nextWord :: Parser String
nextWord = Parser $ \s@(State ps rm sp) ->
let err = Error (descLocation s) [dsc]
dsc = Expected "next word"
ert = Empty (Fail err)
gd (str, rm'') = Consumed $ Ok str (State ps rm'' sp) err
in maybe ert gd $ do
guard $ null ps
nextW rm
nextWordIs :: String -> Parser ()
nextWordIs str = Parser $ \s@(State ps rm sp) ->
let err = Error (descLocation s) [dsc]
dsc = Expected $ "next argument \"" ++ str ++ "\""
ert = Empty $ Fail err
gd rm'' = Consumed $ Ok () (State ps rm'' sp) err
in maybe ert gd $ do
guard $ null ps
(a, rm') <- nextW rm
guard (a == str)
return rm'
nonOptionPosArg :: Parser String
nonOptionPosArg = Parser $ \s@(State ps rm sp) ->
let err = Error (descLocation s) [dsc]
dsc = Expected "non option positional argument"
ert = Empty $ Fail err
gd (str, rm'') = Consumed $ Ok str (State ps rm'' sp) err
in maybe ert gd $ do
guard $ null ps
(x, rm') <- nextW rm
result <- if sp
then return x
else case x of
[] -> return x
'-':[] -> return "-"
f:_ -> if f == '-' then mzero else return x
return (result, rm')
end :: Parser ()
end = Parser $ \s@(State ps rm _) ->
let err = Error (descLocation s) [dsc]
dsc = Expected "end of input"
ert = Empty $ Fail err
gd = Empty $ Ok () s err
in if null ps && null rm then gd else ert
matchApproxWord :: Set String -> Parser (String, String)
matchApproxWord set = Parser $ \s@(State ps rm sp) ->
let err = Error (descLocation s) . lsDsc
lsDsc = map (Expected . ("next word: " ++))
ert = Empty . Fail . err
gd (act, mtch, rm'') =
Consumed $ Ok (act, mtch) (State ps rm'' sp) (err allWords)
allWords = Set.toList set
in Ex.switch ert gd $ do
Ex.assert allWords $ null ps
(x, rm') <- Ex.fromMaybe allWords $ nextW rm
let matches = Set.filter p set
p t = x `isPrefixOf` t
case Set.toList matches of
[] -> Ex.throw allWords
r:[] -> return (x, r, rm')
xs -> Ex.throw xs
manyTill :: Parser a -> Parser end -> Parser [a]
manyTill p e = do
maybeEnd <- optional e
case maybeEnd of
Just _ -> return []
Nothing -> do
a <- crashOnEmptyOk "manyTill" p
rs <- manyTill p e
return $ a:rs