implementation module Sjit.Syntax

import StdEnv

import Control.Applicative
import Control.Monad
import Data.Either
from Data.Func import $
import Data.Functor
import Data.GenEq
import Text.Parsers.Simple.Core

:: Token
	= TIdent !String
	| TInt !Int
	| TTrue
	| TFalse

	| TEq
	| TComma

	| TParenOpen
	| TParenClose

derive gEq Token
instance == Token where == a b = a === b

instance toString Token
where
	toString t = case t of
		TIdent s    -> "'" +++ s +++ "'"
		TInt n      -> toString n
		TTrue       -> "True"
		TFalse      -> "False"
		TEq         -> "="
		TComma      -> ","
		TParenOpen  -> "("
		TParenClose -> ")"

lex :: !String -> Either String [Token]
lex s = reverse <$> lex [] 0 (size s) s
where
	lex :: ![Token] !Int !Int !String -> Either String [Token]
	lex tks i e s | i >= e = Right tks
	lex tks i e s = case s.[i] of
		w | isSpace w
			-> lex tks (i+1) e s

		n | isIdent n
			# (i,n) = readIdent isIdent [] i e s
			# tk = case n of
				"True"  -> TTrue
				"False" -> TFalse
				n       -> TIdent n
			-> lex [tk:tks] i e s

		n | isFunnyIdent n
			# (i,n) = readIdent isFunnyIdent [] i e s
			-> lex [TIdent n:tks] i e s

		n | isDigit n
			# (i,n) = readInt [] i e s
			-> lex [TInt n:tks] i e s

		'=' -> lex [TEq:        tks] (i+1) e s
		',' -> lex [TComma:     tks] (i+1) e s
		'(' -> lex [TParenOpen: tks] (i+1) e s
		')' -> lex [TParenClose:tks] (i+1) e s

		c   -> Left ("Unexpected character '" +++ {c} +++ "'")

	isIdent :: !Char -> Bool
	isIdent c = isAlpha c || c == '_'

	isFunnyIdent :: !Char -> Bool
	isFunnyIdent c = isMember c ['+-*/']

	readIdent :: !(Char -> Bool) ![Char] !Int !Int !String -> (!Int, !String)
	readIdent ok cs i e s
	| i >= e = (i,{c \\ c <- reverse cs})
	# c = s.[i]
	| ok c = readIdent ok [c:cs] (i+1) e s
	| otherwise = (i,{c \\ c <- reverse cs})

	readInt :: ![Char] !Int !Int !String -> (!Int, !Int)
	readInt cs i e s
	| i >= e = (i,toInt {#c \\ c <- reverse cs})
	# c = s.[i]
	| isDigit c = readInt [c:cs] (i+1) e s
	| otherwise = (i,toInt {#c \\ c <- reverse cs})

function :: Parser Token Function
function =:
	liftM3 make_fun ident (many arg) (pToken TEq *> expr)
where
	make_fun :: !String ![String] !Expr -> Function
	make_fun name args expr = {fun_name=name, fun_args=args, fun_expr=expr}

expr :: Parser Token Expr
expr
	= leftAssoc (tok "+" <|> tok "-")
	$ leftAssoc (tok "*" <|> tok "/")
	$ noInfix
where
	tok :: !String -> Parser Token String
	tok s = pToken (TIdent s) $> s

	leftAssoc :: !(Parser Token String) !(Parser Token Expr) -> Parser Token Expr
	leftAssoc opp exprp = exprp >>= \e1 ->
		many (opp >>= \op -> exprp >>= \e -> pure (op,e)) >>=
		foldM (\e (op,e2) -> pure $ App op [e,e2]) e1

	noInfix :: Parser Token Expr
	noInfix =
		liftM2 App ident (pToken TParenOpen *> pSepBy expr (pToken TComma) <* pToken TParenClose)
		<|> Var <$> ident
		<|> Int <$> int
		<|> Bool <$> bool
		<|> (pToken TParenOpen *> expr <* pToken TParenClose)

ident :: Parser Token String
ident =: (\(TIdent n) -> n) <$> pSatisfy (\t->t=:TIdent _)

arg :: Parser Token String
arg =: ident

int :: Parser Token Int
int =: (\(TInt n) -> n) <$> pSatisfy (\t->t=:TInt _)

bool :: Parser Token Bool
bool =:
	    pToken TTrue $> True
	<|> pToken TFalse $> False

parse_function :: !String -> Either String Function
parse_function s = lex s >>= \tks -> case parse function tks of
	Right f -> Right f
	Left _  -> Left "parsing failed"

parse_interactive_line :: !String -> Either String Function
parse_interactive_line s = lex s >>= \tks -> case parse function tks of
	Right f -> Right f
	Left _  -> case parse expr tks of
		Right e -> Right {fun_name="main", fun_args=[], fun_expr=e}
		Left _  -> Left "parsing failed"