{-# 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