implementation module Sil.Util.Parser

import StdList
import StdOverloaded

import Control.Applicative
import Control.Monad
import Data.Error
from Data.Func import $
import Data.Functor
import Data.List

import Sil.Error

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

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

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

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

instance name String where name s = s

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

(<?>) :: (Parser a b) Error -> Parser a b
(<?>) p e = Parser \i -> case runParser p i of
	(Error _, rest) -> (Error e, rest)
	o               -> o

fail :: Parser a b
fail = empty

top :: Parser a a
top = Parser \i -> case i of
	[]     = (Error $ UnknownError "top in Parser failed", [])
	[x:xs] = (Ok x, xs)

peek :: Parser a a
peek = Parser \i -> case i of
	[]     = (Error $ UnknownError "peek in Parser failed", [])
	[x:xs] = (Ok x, [x:xs])

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

check :: (a -> Bool) -> Parser a a
check f = peek >>= \r -> if (f r) (pure r) fail

(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
		(Ok _, rest) -> (Ok acc, rest)
		(Error _, _) -> case runParser p i of
			(Ok r, rest) -> runParser (until` p guard [r:acc]) rest
			(Error e, _) -> (Error e, i)

	try :: (Parser a b) -> Parser a b
	try p = Parser \i -> case runParser p i of
		(Error e, _) -> (Error e, i)
		(Ok r, rest) -> (Ok r, rest)

item :: a -> Parser a a | ==, name a
item a  = satisfy ((==) a) <?> P_Expected (name a)

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

seplist :: a (Parser a b) -> Parser a [b] | ==, name a
seplist sep p = liftM2 (\es e-> es ++ [e]) (some (p <* item sep)) p
	<|> liftM pure p
	<|> pure empty

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