module Text.ParserCombinators.Poly.StateLazy
( -- * The Parser datatype
Parser(P) -- datatype, instance of: Functor, Monad, PolyParse
, Result(..) -- internal to the parser monad
, runParser -- :: Parser s t a -> s -> [t] -> (Either String a, s, [t])
-- ** basic parsers
, next -- :: Parser s t t
, satisfy -- :: (t->Bool) -> Parser s t t
, manyFinally -- :: Parser s t a -> Parser s t z -> Parser s t [a]
-- ** State-handling
, stUpdate -- :: (s->s) -> Parser s t ()
, stQuery -- :: (s->a) -> Parser s t a
, stGet -- :: Parser s t s
-- ** re-parsing
, reparse -- :: [t] -> Parser s t ()
-- * Re-export all more general combinators
, 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
-- | This @Parser@ datatype is a fairly generic parsing monad with error
-- reporting. It can be used for arbitrary token types, not just
-- String input. (If you require a running state, use module PolyState
-- instead)
newtype Parser s t a = P (s -> [t] -> Result [t] s a)
-- | A return type like Either, that distinguishes not only between
-- right and wrong answers, but also has gradations of wrongness.
-- This should only be used for writing very primitive
-- parsers - really it is an internal detail of the library.
data Result z s a = Success z s a
| Failure z s String
| Committed (Result z s a)
instance Functor (Result z s) where
fmap f (Success z s a) = Success z s (f a)
fmap f (Failure z s e) = Failure z s e
fmap f (Committed r) = Committed (fmap f r)
-- | Apply a parser to an input token sequence.
runParser :: Parser s t a -> s -> [t] -> (a, s, [t])
runParser (P p) = \s -> fromResult . p s
where
fromResult :: Result z s a -> (a, s, z)
fromResult (Success z s a) = (a, s, z)
fromResult (Failure z s e) = throwE e
fromResult (Committed r) = fromResult r
instance Functor (Parser s t) where
fmap f (P p) = P (\s -> fmap f . p s)
instance Monad (Parser s t) where
return x = P (\s ts-> Success ts s x)
fail e = P (\s ts-> Failure ts s e)
(P f) >>= g = P (\s-> continue . f s)
where
continue (Success ts s x) = let (P g') = g x in g' s ts
continue (Committed (Committed r)) = continue (Committed r)
continue (Committed r) = Committed (continue r)
continue (Failure ts s e) = Failure ts s e
instance PolyParse (Parser s t) where
commit (P p) = P (\s-> Committed . p s)
(P p) `adjustErr` f = P (\s-> adjust . p s)
where
adjust (Failure z s e) = Failure z s (f e)
adjust (Committed r) = Committed (adjust r)
adjust good = good
(P p) `onFail` (P q) = P (\s ts-> continue s ts $ p s ts)
where
continue s ts (Failure _ _ _) = q s ts
-- continue _ _ (Committed r) = r -- no, remain Committed
continue _ _ r = r
oneOf' = accum []
where accum errs [] =
fail ("failed to parse any of the possible choices:\n"
++indent 2 (concatMap showErr (reverse errs)))
accum errs ((e,P p):ps) =
P (\s ts-> case p s ts of
Failure _ _ err ->
let (P p) = accum ((e,err):errs) ps
in p s ts
r@(Success z _ a) -> r
r@(Committed _) -> r )
showErr (name,err) = name++":\n"++indent 2 err
-- Apply a parsed function to a parsed value. This version
-- is strict in the result of the function parser, but
-- lazy in the result of the argument parser. (Argument laziness is
-- the distinctive feature over other implementations.)
(P pf) `apply` px = P (\s-> continue . pf s)
where
continue (Success z s f) = let (x,s',z') = runParser px s z
in Success z' s' (f x)
continue (Failure z s e) = Failure z s e
continue (Committed r) = Committed (continue r)
manyFinally :: Parser s t a -> Parser s t z -> Parser s t [a]
{-
manyFinally pp@(P p) pt@(P t) = P (\s ts -> item s ts (p s ts))
where
item _ _ (Success ts s x) = success ts s x
item s ts (Failure _ _ e) = terminate (t s ts)
item s ts (Committed r) = Committed (within r)
success ts s x =
let (tail,s',ts') = runParser (manyFinally pp pt) s ts
in Success ts' s' (x:tail)
terminate (Success ts s _) = Success ts s []
terminate (Failure ts s e) = Failure ts s e
terminate (Committed r) = Committed (terminate r)
within (Success ts s x) = success ts s x
within (Failure ts s e) = Failure ts s e
within (Committed r) = within r
-}
manyFinally p z =
(do x <- p; return (x:) `apply` manyFinally p z)
`onFail`
(do z; return [])
`onFail`
oneOf' [ ("item in sequence", (do p; return []))
, ("sequence terminator", (do z; return [])) ]
------------------------------------------------------------------------
next :: Parser s t t
next = P (\s ts-> case ts of
[] -> Failure [] s "Ran out of input (EOF)"
(t:ts') -> Success ts' s t )
satisfy :: (t->Bool) -> Parser s t t
satisfy pred = do { x <- next
; if pred x then return x else fail "Parse.satisfy: failed"
}
------------------------------------------------------------------------
-- State handling
-- | Update the internal state.
stUpdate :: (s->s) -> Parser s t ()
stUpdate f = P (\s ts-> Success ts (f s) ())
-- | Query the internal state.
stQuery :: (s->a) -> Parser s t a
stQuery f = P (\s ts-> Success ts s (f s))
-- | Deliver the entire internal state.
stGet :: Parser s t s
stGet = P (\s ts-> Success ts s s)
------------------------------------------------------------------------
-- | Push some tokens back onto the front of the input stream and reparse.
-- This is useful e.g. for recursively expanding macros. When the
-- user-parser recognises a macro use, it can lookup the macro
-- expansion from the parse state, lex it, and then stuff the
-- lexed expansion back down into the parser.
reparse :: [t] -> Parser s t ()
reparse ts = P (\s inp-> Success (ts++inp) s ())
------------------------------------------------------------------------