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 = some parseVarDecl 
	>>= \vd->pure $ AST vd []

parseFunDecl :: Parser Token FunDecl
parseFunDecl = empty

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

		parseOpLeft :: (Parser Token Op2) (Parser Token Expr) -> Parser Token Expr
		parseOpLeft 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) <|>
			(parseIdent <* satTok BraceOpenToken 
				>>= \i->parseSepList CommaToken parseExpr <* satTok BraceCloseToken
				>>= \es->pure $ FunExpr i es) <|>
			(satTok BraceOpenToken *> parseExpr <* satTok BraceCloseToken) <|>
			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) <|>
			(parseIdent >>= \i->parseFieldSelector >>= \f.pure $ VarExpr i f)

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)

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":strJoin "\n" (map print v)] ++
		["\n":strJoin "\n" (map print f)])

class print a :: a -> [String]

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

printStatements :: [Stmt] Int -> [String]
printStatements _ _ = []

//TODO
instance print FunType where
	print _ = []

//TODO
instance print Stmt where
	print _ = []

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) = [s]
	print IntType = ["Int"]
	print BoolType = ["Bool"]
	print CharType = ["Char"]
	print VarType = ["var"]

strJoin :: String [[String]] -> [String]
strJoin _ [] = []
strJoin j [s:rest] = s ++ flatten [[j:ss]\\ss<-rest]

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) = [i,"(":strJoin "," (map print es)] ++ [")"]
	print EmptyListExpr = ["[]"]
	print (TupleExpr e1 e2) = ["(":print e1] ++ [",":print e2] ++ [")"]