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 Data.List import intercalate, replicate
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 = many parseVarDecl 
	>>= \vd->some parseFunDecl
	>>= \fd->pure $ AST vd fd

parseFunDecl :: Parser Token FunDecl
parseFunDecl = parseIdent <* satTok BraceOpenToken
	>>= \ident->parseSepList CommaToken parseIdent <* satTok BraceCloseToken
	>>= \args->parseFunType <* satTok CBraceOpenToken 
	>>= \funtype->many parseVarDecl
	>>= \vardecls->many parseStmt 
	<* satTok CBraceCloseToken
	>>= \stmts->pure $ FunDecl ident args funtype vardecls stmts

parseStmt :: Parser Token Stmt
parseStmt = parseIfStmt <|>
	parseWhileStmt <|>
	parseSColon parseAssStmt <|>
	parseSColon parseReturnStmt <|>
	(parseSColon parseFunCall >>= \fc->pure $ FunStmt fc)
	where
		parseSColon :: (Parser Token a) -> Parser Token a
		parseSColon p = p <* satTok SColonToken

		parseReturnStmt :: Parser Token Stmt
		parseReturnStmt = satTok ReturnToken 
			*> optional parseExpr >>= \me->pure $ ReturnStmt me

		parseAssStmt :: Parser Token Stmt
		parseAssStmt = parseVarDef <* satTok AssignmentToken
			>>= \var-> parseExpr >>= \expr->pure $ AssStmt var expr

		parseIfStmt :: Parser Token Stmt
		parseIfStmt = satTok IfToken 
			*> parseBBraces parseExpr
			>>= \pred->(parseBlock <|> parseOneLine)
			>>= \thens->optional (
				satTok ElseToken *> (parseBlock <|> parseOneLine)
			)>>= \elses->pure $ IfStmt pred thens (fromMaybe [] elses)

		parseWhileStmt :: Parser Token Stmt
		parseWhileStmt = satTok WhileToken *> parseBBraces parseExpr
			>>= \pred->parseBlock >>= \body->pure $ WhileStmt pred body

		parseBlock :: Parser Token [Stmt]
		parseBlock = parseBCBraces (many parseStmt)

		parseOneLine :: Parser Token [Stmt]
		parseOneLine = parseStmt >>= \s->pure [s]

parseBBraces :: (Parser Token a) -> Parser Token a
parseBBraces p = satTok BraceOpenToken *> p <* satTok BraceCloseToken

parseBCBraces :: (Parser Token a) -> Parser Token a
parseBCBraces p = satTok CBraceOpenToken *> p <* satTok CBraceCloseToken

parseFunType :: Parser Token FunType
parseFunType = satTok DoubleColonToken *> 
	(parseInOutType <|> (parseVoidOrType >>= \t->pure $ FunType [] t))
	where
		parseInOutType :: Parser Token FunType
		parseInOutType = some parseType <* satTok ArrowToken
			>>= \intypes-> parseVoidOrType
			>>= \outtypes->pure $ FunType intypes outtypes

		parseVoidOrType :: Parser Token (Maybe Type)
		parseVoidOrType = (satTok VoidToken *> pure Nothing) <|> 
			(parseType >>= \type->pure $ Just type)

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 = //Operators in order of binding strength
	parseOpR (trans1 ColonToken BiCons) $
	parseOpR (trans1 PipesToken BiOr) $
	parseOpR (trans1 AmpersandsToken BiAnd) $
	parseOpR (trans1 EqualsToken BiEquals <|>
			trans1 LesserToken BiLesser <|>
			trans1 BiggerToken BiGreater <|>
			trans1 LesserEqToken BiLesserEq <|>
			trans1 GreaterEqToken BiGreaterEq <|>
			trans1 NotEqualToken BiUnEqual) $
	parseOpL (trans1 PlusToken BiPlus <|>
			trans1 DashToken BiMinus) $
	parseOpL (trans1 StarToken BiTimes <|>
			trans1 SlashToken BiDivide <|>
			trans1 PercentToken BiMod) $ parseBasicExpr
	where
		parseOpR :: (Parser Token Op2) (Parser Token Expr) -> Parser Token Expr
		parseOpR ops prev = prev >>= \e1->optional (
				ops >>= \op->parseOpR ops prev >>= \e->pure (op, e)
			) >>= \moe->pure $ maybe e1 (\(op,e2)->Op2Expr e1 op e2) moe

		parseOpL :: (Parser Token Op2) (Parser Token Expr) -> Parser Token Expr
		parseOpL ops prev = prev >>= \e1->many (
				ops >>= \op->prev >>= \e->pure (op, e)
			) >>= \moe->foldM (\e->(\(op,e2)->pure $ Op2Expr e op e2)) e1 moe

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

parseFunCall :: Parser Token FunCall
parseFunCall = parseIdent <* satTok BraceOpenToken 
	>>= \i->parseSepList CommaToken parseExpr 
	<* satTok BraceCloseToken >>= \es->pure $ FunCall i es

parseVarDef :: Parser Token VarDef
parseVarDef = parseIdent 
	>>= \i-> many (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))
	) >>= \f->pure $ VarDef i f

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

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)

parseSepList :: TokenValue (Parser Token a) -> Parser Token [a]
parseSepList sep p = 
	(some (p <* satTok sep) >>= \es->p >>= \e.pure $ reverse [e:es]) <|>
	(p >>= \e->pure [e]) <|> pure []

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

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

class print a :: a -> [String]

printersperse :: String [a] -> [String] | print a
printersperse i j = intercalate [i] (map print j)

instance print FunDecl where
	print (FunDecl i as t vs ss) =
		["\n", i, " (":printersperse "," as] ++
		[") :: ":print t] ++
		["{":printersperse "\n\t" vs] ++
		["\n":printStatements ss 1] ++ ["}"]

printStatements :: [Stmt] Int -> [String]
printStatements [] i = []
printStatements [s:ss] i = (case s of
	(IfStmt b thens elses) = indent i ["if (":print b] ++ [")"] ++
		printCodeBlock thens i ++ 
		indent i ["else ":printCodeBlock elses i] ++ ["\n"]
	(WhileStmt b dos) = indent i ["while (":print b] ++ 
		[")":printCodeBlock dos i]
	(AssStmt vardef val) =
		indent i $ print vardef ++ ["=":print val] ++ [";\n"]
	(FunStmt fc) = indent i $ print fc ++ [";\n"]
	(ReturnStmt me) = indent i ["return ":maybe [""] print me] ++ [";\n"]
	) ++ printStatements ss i
	where
		printCodeBlock :: [Stmt] Int -> [String]
		printCodeBlock [] _ = ["{}"]
		printCodeBlock [x] i = ["\n":printStatements [x] (i+1)]
		printCodeBlock x i =
			["{\n":printStatements x (i+1)] ++ indent i ["}"]

		indent :: Int [String] -> [String]
		indent i rest = replicate i "\t" ++ rest

instance print FunType where
	print (FunType at rt) = printersperse " " at ++
		[if (isEmpty at) "" "->":maybe ["Void"] print rt]

instance print VarDecl where
	print (VarDecl i t e) = print t ++ [" ":i:"=":print e] ++ [";"]

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

instance print String where
	print s = [s]

instance print FieldSelector where	
	print FieldHd = print "hd"
	print FieldTl = print "tl"
	print FieldSnd = print "snd"
	print FieldFst = print "fst"

instance print VarDef where
	print (VarDef i fs) = printersperse "." [i:flatten $ map print fs]

instance print FunCall where
	print (FunCall i args) = [i,"(":printersperse "," args] ++ [")"]

instance print Expr where
	print (VarExpr vd) = print vd
	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 fc) = print fc
	print EmptyListExpr = ["[]"]
	print (TupleExpr e1 e2) = ["(":print e1] ++ [",":print e2] ++ [")"]