module Text.ParserCombinators.Poly.StateLazy
(
Parser(P)
, runParser
, next
, satisfy
, stUpdate
, stQuery
, stGet
, reparse
, module Text.ParserCombinators.Poly.Base
) where
import Text.ParserCombinators.Poly.Base
#if __GLASGOW_HASKELL__
import Control.Exception hiding (bracket)
throwE :: String -> a
throwE msg = throw (ErrorCall msg)
#else
throwE :: String -> a
throwE msg = error msg
#endif
newtype Parser s t a = P (s -> [t] -> (Either String a, s, [t]))
type EitherE a b = Either (Bool,a) b
runParser :: Parser s t a -> s -> [t] -> (a, s, [t])
runParser (P p) s =
(\ (e,s,ts)-> (case e of {Left m->throwE m; Right x->x}, s, ts))
. p s
instance Functor (Parser s t) where
fmap f (P p) = P (\s ts-> case p s ts of
(Left msg, s', ts') -> (Left msg, s', ts')
(Right x, s', ts') -> (Right (f x), s', ts'))
instance Monad (Parser s t) where
return x = P (\s ts-> (Right x, s, ts))
(P f) >>= g = P (\s ts-> case f s ts of
(Left msg, s', ts') -> (Left msg, s', ts')
(Right x, s', ts') -> let (P g') = g x
in g' s' ts')
fail msg = P (\s ts-> (Left msg, s, ts))
instance PolyParse (Parser s t) where
commit (P p) = P (\s ts-> case p s ts of
(Left e, s', ts') -> (throwE e, s', ts')
right -> right )
(P p) `adjustErr` f =
P (\s ts-> case p s ts of
(Left msg, s', ts') -> (Left (f msg), s, ts')
right -> right )
(P p) `onFail` (P q) = P (\s ts-> case p s ts of
(Left _, _, _) -> q s ts
right -> right )
oneOf' ps = accum [] ps
where accum errs [] =
case errs of
[] -> failBad ("internal failure in parser (oneOf'):\n"
++indent 2 (show (map fst ps)))
[(_,e)] -> fail e
es -> fail ("one of the following failures occurred:\n"
++indent 2 (concatMap showErr (reverse es)))
accum errs ((e,P p):ps) =
P (\u ts-> case p u ts of
(Left err,_,_) -> let (P p) = accum ((e,err):errs) ps
in p u ts
right -> right )
showErr (name,err) = name++":\n"++indent 2 err
(P pf) `apply` (P px) = P (\s ts->
case pf s ts of
(Left msg, s', ts') -> (Left msg, s', ts')
(Right f, s', ts') -> let (x',s'',ts'') = px s' ts'
x = case x' of { Right x -> x
; Left e -> throwE e }
in (Right (f x), s'', ts'') )
next :: Parser s t t
next = P (\s ts-> case ts of
[] -> (Left "Ran out of input (EOF)", s, [])
(t:ts') -> (Right t, s, ts') )
satisfy :: (t->Bool) -> Parser s t t
satisfy p = do{ x <- next
; if p x then return x else fail "Parse.satisfy: failed"
}
stUpdate :: (s->s) -> Parser s t ()
stUpdate f = P (\s ts-> (Right (), f s, ts))
stQuery :: (s->a) -> Parser s t a
stQuery f = P (\s ts-> (Right (f s), s, ts))
stGet :: Parser s t s
stGet = P (\s ts-> (Right s, s, ts))
reparse :: [t] -> Parser s t ()
reparse ts = P (\s inp-> (Right (), s, ts++inp))