module Text.ParserCombinators.Poly.Lazy
(
Parser(P)
, runParser
, next
, satisfy
, manyFinally
, reparse
, module Text.ParserCombinators.Poly.Base
) where
import Text.ParserCombinators.Poly.Base hiding ( manyFinally )
#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 t a = P ([t] -> (Either String a, [t]))
runParser :: Parser t a -> [t] -> (a, [t])
runParser (P p) =
(\ (e,ts)-> (case e of {Left m->throwE m; Right x->x}, ts) )
. p
instance Functor (Parser t) where
fmap f (P p) = P (\ts-> case p ts of
(Left msg, ts') -> (Left msg, ts')
(Right x, ts') -> (Right (f x), ts'))
instance Monad (Parser t) where
return x = P (\ts-> (Right x, ts))
(P f) >>= g = P (\ts-> case f ts of
(Left msg, ts') -> (Left msg, ts')
(Right x, ts') -> let (P g') = g x in g' ts')
fail e = P (\ts-> (Left e, ts))
instance PolyParse (Parser t) where
commit (P p) = P (\ts-> case p ts of
(Left e, ts') -> (throwE e, ts')
right -> right )
(P p) `onFail` (P q) = P (\ts-> case p ts of
(Left _, _) -> q ts
right -> right )
(P p) `adjustErr` f = P (\ts-> case p ts of
(Left msg, ts') -> (Left (f msg), 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 (\ts-> case p ts of
(Left err,_) -> let (P p) = accum ((e,err):errs) ps
in p ts
right -> right )
showErr (name,err) = name++":\n"++indent 2 err
(P pf) `apply` (P px) = P (\ts->
case pf ts of
(Left msg, ts') -> (Left msg, ts')
(Right f, ts') -> let (x',ts'') = px ts'
x = case x' of { Right x -> x
; Left e -> throwE e }
in (Right (f x), ts'') )
next = P (\ts-> case ts of
[] -> (Left "Ran out of input (EOF)", [])
(t:ts') -> (Right t, ts') )
satisfy :: (t->Bool) -> Parser t t
satisfy p = do{ x <- next
; if p x then return x else fail "Parse.satisfy: failed"
}
manyFinally :: Parser t a -> Parser t z -> Parser t [a]
manyFinally pp@(P p) pt@(P t) = P (\ts ->
case p ts of
(Left e, _) ->
case t ts of
(Right _, ts') -> (Right [], ts')
(Left e, ts') -> (Left e, ts')
(Right x, ts') ->
let (tail,ts'') = runParser (manyFinally pp pt) ts'
in (Right (x:tail), ts'') )
reparse :: [t] -> Parser t ()
reparse ts = P (\inp-> (Right (), ts++inp))