module Parsimony.Prim
( Parser, PrimParser, Reply(..)
, runParser, primParser
, parseError, try, lookAhead, labels
, foldMany, foldManyWhile, skipMany, match
, State(..), getState, updateState, mapState
) where
import Parsimony.Pos
import Parsimony.Error
import Control.Applicative(Applicative(..),Alternative(..))
import Control.Monad(liftM,ap,MonadPlus(..))
data Parser t a = P { unP :: State t -> R t a }
data R s a = R !Bool (Reply s a)
data Reply s a = Ok !a !(State s)
| Error !ParseError
data State t = State { stateInput :: !t
, statePos :: !SourcePos
}
type PrimParser s a = State s -> Reply s a
primParser :: PrimParser t a -> Parser t a
primParser prim = P $ \s -> case prim s of
r@(Error _) -> R False r
r -> R True r
runParser :: Parser t a -> PrimParser t a
runParser p s = case unP p s of
R _ x -> x
getState :: Parser t (State t)
getState = P $ \s -> R False (Ok s s)
updateState :: (State s -> State s) -> Parser s ()
updateState f = P $ \s -> R False $! Ok () (f s)
mapState :: (State big -> (State small,extra))
-> (State small -> extra -> State big)
-> Parser small a -> Parser big a
mapState extract inject p = P $ \big ->
case extract big of
(small,extra) ->
case unP p small of
R c r -> R c $ case r of
Error err -> Error err
Ok a small1 -> Ok a (inject small1 extra)
parseError :: (SourcePos -> ParseError) -> Parser t a
parseError e = P $ \s -> R False $ Error $ e $ statePos s
try :: Parser t a -> Parser t a
try p = P $ \s ->
case unP p s of
R True (Error err) -> R False $ Error $ setErrorPos (statePos s) err
other -> other
lookAhead :: Parser t a -> Parser t a
lookAhead p = P $ \s ->
R False $ case unP p s of
R _ (Error err) -> Error err
R _ (Ok a _) -> Ok a s
labels :: Parser t a -> [String] -> Parser t a
labels p msgs0 = P $ \s ->
case unP p s of
R c r -> R c (addErr r)
where setExpectErrors err [] = setErrorMessage (Expect "") err
setExpectErrors err [msg] = setErrorMessage (Expect msg) err
setExpectErrors err (msg:msgs) =
foldr (\m e -> addErrorMessage (Expect m) e)
(setErrorMessage (Expect msg) err) msgs
addErr (Error e) = Error $ setExpectErrors e msgs0
addErr r = r
foldMany :: (b -> a -> b) -> b -> Parser t a -> Parser t b
foldMany cons nil p = P $ \s ->
case unP p s of
R False (Ok {}) -> crash "Parsimony.foldMany"
R False (Error _) -> R False $ Ok nil s
R True (Ok x s1) -> R True $ (walk $! cons nil x) s1
R True (Error err) -> R True $ Error err
where
walk xs s =
case unP p s of
R False (Ok {}) -> crash "Parsimony.foldMany"
R False (Error _) -> Ok xs s
R True (Ok x s1) -> (walk $! cons xs x) s1
R True (Error e) -> Error e
foldManyWhile :: (b -> a -> b) -> b -> Parser t (Maybe a) -> Parser t b
foldManyWhile cons nil p = P $ \s ->
case unP p s of
R False (Ok Nothing _) -> R False $ Ok nil s
R False (Ok {}) -> crash "Parsimony.foldManyWhile"
R False (Error _) -> R False $ Ok nil s
R True (Ok Nothing s1) -> R True $ Ok nil s1
R True (Ok (Just x) s1) -> R True $ (walk $! cons nil x) s1
R True (Error err) -> R True $ Error err
where
walk xs s =
case unP p s of
R False (Ok Nothing _) -> Ok xs s
R False (Ok {}) -> crash "Parsimony.foldManyWhile"
R False (Error _) -> Ok xs s
R True (Ok Nothing s1) -> Ok xs s1
R True (Ok (Just x) s1) -> (walk $! cons xs x) s1
R True (Error e) -> Error e
skipMany :: Parser t a -> Parser t ()
skipMany p = P $ \s ->
case unP p s of
R False (Ok {}) -> crash "Parsimony.skipMany"
R False (Error _) -> R False $ Ok () s
R True (Ok _ s1) -> R True $ walk s1
R True (Error err) -> R True $ Error err
where
walk s =
case unP p s of
R False (Ok {}) -> crash "Parsimony.skipMany"
R False (Error _) -> Ok () s
R True (Ok _ s1) -> walk s1
R True (Error e) -> Error e
match :: (Eq a) => (a -> String) -> [a] -> Parser t a -> Parser t ()
match sh goal p = P (outer goal)
where
expected x = addErrorMessage (Expect (sh x))
unexpected x pos = newErrorMessage (UnExpect (sh x)) pos
outer [] s = R False $ Ok () s
outer (x:xs) s =
case unP (labels p [sh x]) s of
R False (Ok a s1)
| x == a -> outer xs s1
| otherwise -> R False $ Error $ expected x $ unexpected a $ statePos s
R False (Error e) -> R False $ Error e
R True r -> R True $
case r of
Error e -> Error $ expected x e
Ok a s1
| x == a -> inner xs s1
| otherwise -> Error $ expected x $ unexpected a $ statePos s
inner [] s = Ok () s
inner (x:xs) s =
case unP (labels p [sh x]) s of
R _ (Ok a s1)
| x == a -> inner xs s1
| otherwise -> Error $ expected x $ unexpected a $ statePos s
R _ (Error e) -> Error e
crash :: String -> a
crash f = error $ f ++ " applied to a parser that accepts the empty string."
instance Functor (Parser t) where
fmap = liftM
instance Monad (Parser t) where
return a = pure a
p >>= f = P $ \s ->
case unP p s of
R True r -> R True $ case r of
Error e -> Error e
Ok a s1 ->
case unP (f a) s1 of
R _ r1 -> r1
R False r -> case r of
Error e -> R False $ Error e
Ok a s1 -> unP (f a) s1
fail m = parseError (newErrorMessage (Message m))
instance Applicative (Parser t) where
pure a = P $ \s -> R False $ Ok a s
(<*>) = ap
instance Alternative (Parser t) where
empty = parseError newErrorUnknown
p1 <|> p2 = P $ \s ->
case unP p1 s of
R False (Error _) -> unP p2 s
other -> other
instance MonadPlus (Parser t) where
mzero = empty
mplus = (<|>)