implementation module Sil.Util.Parser

from StdFunc import iter
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

fromPositioned :: (Positioned a) -> a
fromPositioned p = p.pos_val

:: *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 Applicative (Parser a) where
	pure a     = Parser \st -> (Ok a, st)
	(<*>) sf p = ap sf p

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

getPositioner :: Parser a (b -> Positioned b)
getPositioner = Parser \st=:{ps_line} -> (Ok \x -> {pos_line=ps_line, pos_val=x}, st)

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

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 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 \st -> case nextToken st of
	(Nothing, st) -> (Ok (), st)
	(t, st)       -> (Error $ P_Expected "eof", st)