implementation module parse

import StdString
import StdTuple
import StdList
from StdFunc import const
import Data.Either
import Data.Functor
import Data.Maybe
import Control.Monad
import Control.Applicative
import Data.Func
from Text import class Text(concat), instance Text String

import yard
import lex

parser :: LexerOutput -> ParserOutput
parser (Left e) = Left $ toString $ LexError e
parser (Right r) = case runParser parseProgram r of
	(Right p, _) = Right p
	(Left e, _) = Left $ toString e

parseProgram :: Parser Token AST
parseProgram = parseVarDecl >>= \t.pure $ AST [t] []

parseVarDecl :: Parser Token VarDecl
parseVarDecl = 
	(parseType <|> trans1 VarToken VarType )
	>>= \t->parseIdent <* satTok AssignmentToken
	>>= \i->parseExpr <* satTok SColonToken
	>>= \e->pure $ VarDecl i t e

parseType :: Parser Token Type
parseType = 
	trans1 IntTypeToken IntType <|>
	trans1 CharTypeToken CharType <|>
	trans1 BoolTypeToken BoolType <|>
	(satTok SquareOpenToken *> parseType <* satTok SquareCloseToken 
		>>= \t.pure $ ListType t) <|>
	(satTok BraceOpenToken *> parseType <* satTok CommaToken 
		>>= \t1->parseType <* satTok BraceCloseToken 
		>>= \t2->pure $ TupleType t1 t2) <|>
	(parseIdent >>= \e.pure $ IdType e) <|>
	empty

parseExpr :: Parser Token Expr
parseExpr = parseOps (trans1 ColonToken BiCons) parseBinOrExpr 
	where
		//Dit generaliseert het onderstaande, ik moet het nog even in elkaar
		//sleutelen. Dan werkt bindingssterkte, associativiteit moet nog
		// Wat je hier boven ziet wordt dan een cascade van operators met op
		// het einde de parseBasicExpr. In volgorde van bindingssterkte, de
		// zwaktste eerst...
		parseOps :: (Parser Token Op2) (Parser Token Expr) -> Parser Token Expr
		parseOps ops prev = prev >>= \e1->optional (
				ops >>= \op->parseOps ops prev >>= \e->pure (op, e)
			) >>= \moe-> pure case moe of
				Nothing = e1
				(Just (op, e2)) = Op2Expr e1 op e2

		parseBinOrExpr :: Parser Token Expr
		parseBinOrExpr =
			parseBinAndExpr >>= \e1-> optional (
				trans1 PipesToken BiOr
				>>= \op->parseBinOrExpr >>= \e->pure (op, e))
			>>= \moe->pure case moe of
				Nothing = e1
				(Just (op, e2)) = Op2Expr e1 op e2

		parseBinAndExpr :: Parser Token Expr
		parseBinAndExpr =
			parseCompareExpr >>= \e1-> optional (
				trans1 AmpersandsToken BiAnd
				>>= \op->parseBinAndExpr >>= \e->pure (op, e))
			>>= \moe->pure case moe of
				Nothing = e1
				(Just (op, e2)) = Op2Expr e1 op e2
	
		parseCompareExpr :: Parser Token Expr
		parseCompareExpr =
			parsePlusMinusExpr >>= \e1-> optional (
				(	trans1 EqualsToken BiEquals <|>
					trans1 LesserToken BiLesser <|>
					trans1 BiggerToken BiGreater <|>
					trans1 LesserEqToken BiLesserEq <|>
					trans1 GreaterEqToken BiGreaterEq <|>
					trans1 NotEqualToken BiUnEqual
				) >>= \op->parseCompareExpr >>= \e->pure (op, e))
			>>= \moe->pure case moe of
				Nothing = e1
				(Just (op, e2)) = Op2Expr e1 op e2

		parsePlusMinusExpr :: Parser Token Expr
		parsePlusMinusExpr =
			parseTimesDivExpr >>= \e1-> optional (
				(	trans1 PlusToken BiPlus <|>
					trans1 DashToken BiMinus
				) >>= \op->parsePlusMinusExpr >>= \e->pure (op, e))
			>>= \moe->pure case moe of
				Nothing = e1
				(Just (op, e2)) = Op2Expr e1 op e2

		parseTimesDivExpr :: Parser Token Expr
		parseTimesDivExpr =
			parseBasicExpr >>= \e1->optional (
				(	trans1 StarToken BiTimes <|>
					trans1 SlashToken BiDivide <|>
					trans1 PercentToken BiMod 
				) >>= \op->parseTimesDivExpr >>= \e->pure (op, e))
			>>= \moe-> pure case moe of
				Nothing = e1
				(Just (op, e2)) = Op2Expr e1 op e2

		parseBasicExpr :: Parser Token Expr
		parseBasicExpr = 
			(satTok BraceOpenToken *> parseExpr <* satTok BraceCloseToken) <|>
			(satTok BraceOpenToken *> parseExpr <* satTok CommaToken 
				>>= \e1->parseExpr <* satTok BraceCloseToken 
				>>= \e2->pure $ TupleExpr e1 e2) <|>
			trans1 EmptyListToken EmptyListExpr <|>
			trans2 TrueToken (const $ BoolExpr True) <|>
			trans2 FalseToken (const $ BoolExpr True) <|>
			trans2 (NumberToken zero) (\(NumberToken i)->IntExpr i) <|>
			trans2 (CharToken zero) (\(CharToken c)->CharExpr c) <|>
			(parseOp1 >>= \o->parseExpr >>= \e.pure $ Op1Expr o e) <|>
			(parseIdent <* satTok BraceOpenToken 
				>>= \i->parseActArgs <* satTok BraceCloseToken
				>>= \es->pure $ FunExpr i es) <|>
			(parseIdent >>= \i. parseFieldSelector >>= \f.pure $ VarExpr i f)

parseActArgs :: Parser Token [Expr]
parseActArgs = 
	(some (parseExpr <* satTok CommaToken) >>= \es->parseExpr 
		>>= \e.pure [e:es]) <|>
	(parseExpr >>= \e->pure [e]) <|>
	empty

parseOp1 :: Parser Token Op1
parseOp1 = trans1 DashToken UnMinus <|> 
	trans1 ExclamationToken UnNegation

parseFieldSelector :: Parser Token (Maybe FieldSelector)
parseFieldSelector = optional (satTok DotToken *> (
	(parseIdent >>= (\i.if (i == "hd") (pure FieldHd) empty)) <|>
	(parseIdent >>= \i.if (i == "tl") (pure FieldTl) empty) <|>
	(parseIdent >>= \i.if (i == "fst") (pure FieldFst) empty) <|>
	(parseIdent >>= \i.if (i == "snd") (pure FieldSnd) empty)))

trans2 :: TokenValue (TokenValue -> a) -> Parser Token a
trans2 t f = satTok t >>= \(_, r).pure (f r)

trans1 :: TokenValue a -> Parser Token a
trans1 t r = trans2 t $ const r

satTok :: TokenValue -> Parser Token Token
satTok t = satisfy ((===) t)

parseIdent :: Parser Token String
parseIdent = trans2 (IdentToken []) (\(IdentToken e).toString e)

instance toString AST where
	toString (AST v f) = concat (print v ++ ["\n":print f])

class print a :: a -> [String]

instance print [a] | print a where
	print [] = ["\n"]
	print [v:vs] = print v ++ ["\n":print vs]

instance print VarDecl where
	print (VarDecl i t e) = print t ++ [" ":i:"=":print e] ++ [";"]
instance print FunDecl where
	print _ = ["Function printing not yet implemented"]

instance print Type where
	print (TupleType t1 t2) = ["(":print t1] ++ [", ":print t2] ++ [")"]
	print (ListType t) = ["[":print t] ++ ["]"]
	print (IdType s) = [s]
	print IntType = ["Int"]
	print BoolType = ["Bool"]
	print CharType = ["Char"]
	print VarType = ["var"]

instance print Expr where
	print (VarExpr i Nothing) = [i]
	print (VarExpr i (Just mf)) = [i, case mf of
		FieldHd = ".hd"; FieldTl = ".tl"
		FieldSnd = ".snd"; FieldFst = ".fst"]
	print (Op2Expr e1 o e2) = print e1 ++ [case o of
		BiPlus = "+"; BiMinus = "-"; BiTimes = "*"; BiDivide = "/"
		BiMod = "%"; BiEquals = "="; BiLesser = "<"; BiGreater = ">"
		BiLesserEq = "<="; BiGreaterEq = ">="; BiUnEqual = "!=";
		BiAnd = "&&"; BiOr = "||"; BiCons = ":"
		:print e2]
	print (Op1Expr o e) = [case o of
		UnNegation = "!"; UnMinus = "-"
		:print e]
	print (IntExpr i) = [toString i]
	print (CharExpr c) = ["\'", case c of
		'\b' = "\\b"; '\f' = "\\f"; '\n' = "\\n"
		'\r' = "\\r"; '\t' = "\\t"; '\v' = "\\v"
		c = if (c == toChar 7) "\\a" (toString c)
		,"\'"]
	print (BoolExpr b) = [toString b]
	print (FunExpr i es) = pe ++ flatten [[",":x]\\x<-tl pes]
		where [pe:pes] = map print es
	print EmptyListExpr = ["[]"]
	print (TupleExpr e1 e2) = ["(":print e1] ++ [",":print e2] ++ [")"]