module Text.ParserCombinators.Poly.StateText ( -- * The Parser datatype Parser(P) , Result(..) , runParser -- ** Basic parsers , next , eof , satisfy , onFail -- ** Derived parsers (but implemented more efficiently) , manySatisfy , many1Satisfy -- ** State-handling , stUpdate -- :: (s->s) -> Parser s t () , stQuery -- :: (s->a) -> Parser s t a , stGet -- :: Parser s t s -- ** Re-parsing , reparse -- * Re-export all more general combinators , module Text.ParserCombinators.Poly.Base , module Control.Applicative ) where import Text.ParserCombinators.Poly.Base import Text.ParserCombinators.Poly.Result import qualified Data.Text.Lazy as T import Data.Text.Lazy (Text) import Control.Applicative -- | This @Parser@ datatype is a specialised parsing monad with error -- reporting. Whereas the standard version can be used for arbitrary -- token types, this version is specialised to Text input only. newtype Parser s a = P (s -> Text -> Result (Text,s) a) -- | Apply a parser to an input token sequence. runParser :: Parser s a -> s -> Text -> (Either String a, s, Text) runParser (P p) = \s -> reTuple . resultToEither . p s where reTuple (either, (z,s)) = (either, s, z) instance Functor (Parser s) where fmap f (P p) = P (\s-> fmap f . p s) instance Monad (Parser s) 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 r) = Committed (continue r) continue (Failure ts e) = Failure ts e instance Commitment (Parser s) where commit (P p) = P (\s-> Committed . squash . p s) where squash (Committed r) = squash r squash r = r (P p) `adjustErr` f = P (\s-> adjust . p s) where adjust (Failure z e) = Failure z (f e) adjust (Committed r) = Committed (adjust r) adjust good = good 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 _ _) -> r r@(Committed _) -> r ) showErr (name,err) = name++":\n"++indent 2 err instance Applicative (Parser s) where pure f = return f pf <*> px = do { f <- pf; x <- px; return (f x) } #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610 p <* q = p `discard` q #endif instance Alternative (Parser s) where empty = fail "no parse" p <|> q = p `onFail` q instance PolyParse (Parser s) ------------------------------------------------------------------------ -- | Simply return the next token in the input tokenstream. next :: Parser s Char next = P (\s bs-> case T.uncons bs of Nothing -> Failure (bs,s) "Ran out of input (EOF)" Just (c, bs') -> Success (bs',s) c ) -- | Succeed if the end of file/input has been reached, fail otherwise. eof :: Parser s () eof = P (\s bs -> if T.null bs then Success (bs,s) () else Failure (bs,s) "Expected end of input (EOF)" ) -- | Return the next token if it satisfies the given predicate. satisfy :: (Char -> Bool) -> Parser s Char satisfy f = do { x <- next ; if f x then return x else fail "Parse.satisfy: failed" } -- | @p `onFail` q@ means parse p, unless p fails, in which case -- parse q instead. -- Can be chained together to give multiple attempts to parse something. -- (Note that q could itself be a failing parser, e.g. to change the error -- message from that defined in p to something different.) -- However, a severe failure in p cannot be ignored. onFail :: Parser s a -> Parser s a -> Parser s a (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 ------------------------------------------------------------------------ -- | @manySatisfy p@ is a more efficient fused version of @many (satisfy p)@ manySatisfy :: (Char->Bool) -> Parser s Text manySatisfy f = P (\s bs-> let (pre,suf) = T.span f bs in Success (suf,s) pre) -- | @many1Satisfy p@ is a more efficient fused version of @many1 (satisfy p)@ many1Satisfy :: (Char->Bool) -> Parser s Text many1Satisfy f = do x <- manySatisfy f if T.null x then fail "Parse.many1Satisfy: failed" else return x ------------------------------------------------------------------------ -- State handling -- | Update the internal state. stUpdate :: (s->s) -> Parser s () stUpdate f = P (\s bs-> Success (bs, f s) ()) -- | Query the internal state. stQuery :: (s->a) -> Parser s a stQuery f = P (\s bs-> Success (bs,s) (f s)) -- | Deliver the entire internal state. stGet :: Parser s s stGet = P (\s bs-> Success (bs,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 :: Text -> Parser s () reparse ts = P (\s inp-> Success (ts `T.append` inp,s) ()) ------------------------------------------------------------------------