implementation module Sil.Util.Parser

from StdFunc import iter, o
import StdList
import StdOverloaded

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

import Sil.Error

instance getPos ParsePosition where getPos pp = pp

:: *ParseState a =
	{ ps_line    :: Int
	, ps_input   :: [ParseInput a]
	, ps_read    :: [ParseInput a]
	, ps_pos     :: Int
	, ps_commits :: [Int]
	}

makeParseState :: [ParseInput a] -> ParseState a
makeParseState i =
	{ ps_line    = 1
	, ps_input   = i
	, ps_read    = []
	, ps_pos     = 0
	, ps_commits = []
	}

nextToken :: (ParseState a) -> (Maybe a, ParseState a)
nextToken ps=:{ps_input=[]} = (Nothing, ps)
nextToken ps=:{ps_input=[i:is]} = case i of
	PI_Token t -> (Just t, {advance & ps_pos=ps.ps_pos + 1})
	PI_NewLine -> nextToken {advance & ps_line=ps.ps_line + 1}
where
	advance = {ps & ps_read=[i:ps.ps_read], ps_input=is}

tokenBack :: (ParseState a) -> ParseState a
tokenBack ps=:{ps_read=[]} = ps
tokenBack ps=:{ps_read=[r:rs]} = case r of
	PI_Token t -> {rewind & ps_pos=ps.ps_pos - 1}
	PI_NewLine -> tokenBack {rewind & ps_line=ps.ps_line-1}
where
	rewind = {ps & ps_read=rs, ps_input=[r:ps.ps_input]}

commit :: (ParseState a) -> ParseState a
commit ps = {ps & ps_commits=[ps.ps_pos:ps.ps_commits]}

dropCommit :: (ParseState a) -> ParseState a
dropCommit ps = {ps & ps_commits=tl ps.ps_commits}

restoreCommit :: (ParseState a) -> ParseState a
restoreCommit ps=:{ps_commits=[c:cs]} = iter (ps.ps_pos - c) tokenBack {ps & ps_commits=cs}

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

instance pure (Parser a)
where
	pure a = Parser \st -> (Ok a, st)

instance <*> (Parser a)
where
	(<*>) sf p = ap sf p

instance <* (Parser a)
instance *> (Parser a)

instance Monad (Parser a)
where
	bind p f = Parser \st -> case runParser p (commit st) of
		(Error e, st) -> (Error e, restoreCommit st)
		(Ok r,    st) -> case runParser (f r) st of
			(Ok r,    st) -> (Ok r,    dropCommit    st)
			(Error e, st) -> (Error e, restoreCommit st)

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

instance name String where name s = s

doPS :: ((ParseState a) -> ParseState a) -> Parser a ()
doPS f = Parser \st -> (Ok (), f st)

runParser :: (Parser a b) *(ParseState a) -> *(MaybeError Error b, *ParseState a)
runParser (Parser f) i = f i

getPosition :: Parser a ParsePosition
getPosition = Parser \st=:{ps_line,ps_pos} -> (Ok {pp_line=ps_line,pp_token=ps_pos}, st)

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

(<#>) :: (Parser a b) String -> Parser a b | toString a
(<#>) p what = p <|> (getPosition >>= \pos -> peek >>= \e -> Parser \st -> (Error $ P_Expected (errpos pos) what e, st))

fail :: Parser a b
fail = empty

top :: Parser a a
top = Parser \st -> case nextToken st of
	(Nothing, st) -> (Error $ UnknownError "top in Parser failed", st)
	(Just x,  st) -> (Ok x, st)

peek :: Parser a a
peek = Parser \st -> case nextToken st of
	(Nothing, st) -> (Error $ UnknownError "peek in Parser failed", st)
	(Just x,  st) -> (Ok x, tokenBack st)

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 \st -> case runParser guard (commit st) of
		(Ok _,    st) -> (Ok acc, dropCommit st)
		(Error _, st) -> case runParser p (commit $ restoreCommit st) of
			(Ok r,    st) -> runParser (until` p guard [r:acc]) (dropCommit st)
			(Error e, st) -> (Error e, restoreCommit st)

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

item :: a -> Parser a a | ==, name, toString a
item a = satisfy ((==) a) <#> name a

anyItem :: ([a] -> Parser a a) | ==, name, toString a
anyItem = foldr (<|>) empty o map item

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

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

seplistUntil :: a a (Parser a b) -> Parser a [b] | ==, name, toString a
seplistUntil end sep p =
	liftM2 (\e es -> [e:es]) p ((item sep *> p) until` (item end))
	<|> liftM pure (p <* item end)
	<|> (empty <$ item end)
where
	(until`) infix 2 :: (Parser a b) (Parser a c) -> Parser a [b]
	(until`) p1 guard = (p1 until guard) >>= \xs -> case xs of
		[] -> fail
		xs -> pure xs

eof :: Parser a () | toString a
eof = Parser \st=:{ps_line,ps_pos} -> case nextToken st of
	(Nothing, st) -> (Ok (), st)
	(Just t, st)  -> (Error $ P_Expected (errpos {pp_line=ps_line,pp_token=ps_pos}) "eof" t, st)