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 $
import Data.Void

instance toString Error where
	toString (PositionalError l c e) =
		concat [toString l,":",toString c,": ",e, "\n"]
	toString (Error e) = concat ["-:-: ", e, "\n"]

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

instance + Error where
	(+) r1 r2 = r2 //TODO
 
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, _)     = (Left e, i)

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

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

fail :: Parser a b
fail = empty

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

peek :: Parser a a
peek = Parser \i -> case i of
    []      = (Left $ Error "", [])
    [x:xs]  = (Right x, [x:xs])

//runs the left parser until the right parser succeeds. Returns the result of the left parser 
//Note: if the right parser consumes input then this input is lost!
//If the left parser fails before the right parser succeeds the whole parser fails
(until) infix 2 :: (Parser a b) (Parser a c) -> Parser a [b]
(until) p guard = try $ until` p guard [] 
    where
        until` :: (Parser a b) (Parser a c) [b] -> Parser a [b]
        until` p guard acc = Parser \i -> case runParser guard i of 
            (Right _, rest) = (Right acc, rest)
            (Left _, _)     = case runParser p i of
                (Right r, rest) = runParser (until` p guard [r:acc]) rest
                (Left e, _)     = (Left e, i)
        try :: (Parser a b) -> Parser a b
        try p = Parser \i -> case runParser p i of
            (Left e, _)     = (Left e, i)
            (Right r, rest) = (Right r, rest)


eof :: Parser a Void
eof = Parser \i -> case i of 
    []      = (Right Void, [])
    _       = (Left $ Error "", i)

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

check :: (a -> Bool) -> Parser a a
check f = peek >>= \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