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