{-# OPTIONS_GHC -O2 #-}
module Text.ParserCombinators.LazyParse
(Parser, runParser
,get, put, modify
,eof, def, (==>), choice
,takesUntil, many, one, lit
) where
import Control.Monad.State
import Data.Maybe
import Data.Char
import Text.StringLike
infix 0 ==>
type Parser s a = State s a
runParser :: Parser s a -> s -> a
runParser = evalState
unstr :: StringLike s => String -> s -> Maybe s
unstr [] s = Just s
unstr (x:xs) s = case uncons s of
Just (c,s2) | c == x -> unstr xs s2
_ -> Nothing
data Lhs = Lit String
| Def
| EOF
data Choice a b = Choice [(Lhs,a)]
instance Monad (Choice a) where
Choice xs >> Choice ys = Choice $ xs++ys
a >>= f = a >> f undefined
return a = error "Choice does not implement return"
class AsLhs a where
asLhs :: a -> Lhs
instance AsLhs Lhs where
asLhs = id
instance CharLike a => AsLhs [a] where
asLhs = Lit . map toChar
eof = EOF
def = Def
(==>) :: (AsLhs l, StringLike s) => l -> Parser s a -> Choice (Parser s a) b
xs ==> p = Choice [(asLhs xs,p)]
choice :: StringLike s => Choice (Parser s a) b -> Parser s a
choice (Choice xs) = do
s <- get
f s xs
where
f s [] = error "Failed to match choice"
f s ((Def,x):xs) = x
f s ((EOF,x):xs) | isEmpty s = x
f s ((Lit y,x):xs) = case unstr y s of
Nothing -> f s xs
Just s2 -> do put s2; x
f s (x:xs) = f s xs
takesUntil :: (StringLike s, StringLike r) => String -> Parser s r
takesUntil xs = do
s <- get
case unstr xs s of
Just s -> do put s; return empty
Nothing -> case uncons s of
Nothing -> return empty
Just (c,s2) -> do
put s2
cs <- takesUntil xs
return $ cons c cs
many :: (StringLike s, StringLike r) => (Char -> Bool) -> Parser s r
many f = do
s <- get
case uncons s of
Just (c,s2) | f c -> do
put s2
res <- many f
return $ cons c res
_ -> return empty
one :: (StringLike s, StringLike r) => (Char -> Bool) -> Parser s r
one f = do
s <- get
case uncons s of
Just (c,s2) | f c -> do put s2 ; return $ cons c empty
_ -> return empty
lit :: (StringLike s, StringLike r) => String -> Parser s r
lit xs = do
s <- get
case unstr xs s of
Nothing -> return empty
Just s2 -> do put s2 ; return $ fromString xs