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 = 
	(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)
	//TODO Parse Binary operators

parseActArgs :: Parser Token [Expr]
parseActArgs = 
	//One argument
	(some (parseExpr <* satTok CommaToken) >>= \es->parseExpr >>= \e.pure [e:es]) <|>
	//Two or more arguments
	(parseExpr >>= \e->pure [e]) <|>
	//Zero arguments, dit moet nog mooier kunnen
	empty

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

parseOp2 :: Parser Token Op2
parseOp2 = trans1 StarToken BiTimes <|> trans1 SlashToken BiDivide <|>
	trans1 PercentToken BiMod <|> trans1 EqualsToken BiEquals <|>
	trans1 LesserToken BiLesser <|> trans1 BiggerToken BiGreater <|>
	trans1 LesserEqToken BiLesserEq <|> trans1 PlusToken BiPlus <|>
	trans1 GreaterEqToken BiGreaterEq <|> trans1 DashToken BiMinus <|>
	trans1 NotEqualToken BiUnEqual <|> trans1 AmpersandsToken BiAnd <|>
	trans1 PipesToken BiOr <|> trans1 ColonToken BiCons

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] ++ [")"]