implementation module yard

import StdTuple
import StdClass
import StdString
import StdList
import StdInt
from Data.List import intersperse
from Text import instance Text String, class Text(concat)
import Data.Functor
import Data.Either
import Control.Monad
import Control.Applicative
from Data.Func import $

instance toString Error where
	toString ParseError = "General parse error"
	toString (LexError e) = "Lexer error: " +++ e
    toString (Expected ts pos) = "Expected " +++ (concat $ intersperse ", " ts) 
                                             +++ " at position " +++ (toString pos)

instance + Error where
    (+) (Expected as _) (Expected bs p) = Expected (as++bs) p
    (+) _ r                             = r

runParser :: (Parser a b) [a] -> (Either Error b, [a])
runParser (Parser f) i = f i

instance Functor (Parser a) where
    fmap f m = liftM f m

instance Applicative (Parser a) where
    pure a      = Parser \i -> (Right a, i)
    (<*>) sf p  = ap sf p

instance Monad (Parser a) where
    bind p f    = Parser \i -> case runParser p i of
        (Right r, rest) = runParser (f r) rest
        (Left e, rest)  = (Left e, rest)

instance Alternative (Parser a) where
    empty       = Parser \i -> (Left ParseError, i)
    (<|>) p1 p2 = Parser \i -> case runParser p1 i of
        (Right r, rest) = (Right r, rest)
        (Left e1, rest) = case runParser p2 i of
            (Right r, rest) = (Right r, rest)
            (Left e2, rest) = (Left (e1+e2), rest)

//Try the parser, if it fails decorate the error with Expected of the given String and position
(<?>) :: (Parser a b) (String, Int) -> Parser a b
(<?>) p (e,pos) = Parser \i -> case runParser p i of
    (Left e1, rest) = let error = (e1+(Expected [e] pos)) in (Left error, rest)
    (Right r, rest) = (Right r, rest)

fail :: Parser a b
fail = empty

top :: Parser a a
top = Parser \i -> case i of
    []      = (Left ParseError, [])
    [x:xs]  = (Right x, xs)

satisfy :: (a -> Bool) -> Parser a a
satisfy f = top >>= \r -> if (f r) (return r) fail

item :: a -> Parser a a | Eq a
item a  = satisfy ((==)a)

list :: [a] -> Parser a [a] | Eq a
list as = mapM item as