implementation module parse

import StdString
import StdTuple
import StdList
from StdFunc import const, o
import Data.Either
import Data.Maybe
import Data.Functor
import Control.Monad
import Control.Applicative
import Data.Func
from Data.List import intercalate, replicate, instance Functor []
from Text import class Text(concat), instance Text String
import GenPrint

import yard
import lex
import AST

parser :: LexerOutput -> ParserOutput
parser (Left e) = Left e
parser (Right r) = fst $ runParser parseProgram r

parseProgram :: Parser Token AST
parseProgram = AST <$> (many parseVarDecl) <*> (some parseFunDecl)

parseFunDecl :: Parser Token FunDecl
parseFunDecl = liftM6 FunDecl
    (peekPos)
    (parseIdent)
	(parseBBraces $ parseSepList CommaToken parseIdent)
	(optional parseFunType)
	(satTok CBraceOpenToken *> many parseVarDecl)
	(many parseStmt <* satTok CBraceCloseToken)

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

		parseReturnStmt :: Parser Token Stmt
		parseReturnStmt =
			satTok ReturnToken *> liftM ReturnStmt (optional parseExpr)

		parseAssStmt :: Parser Token Stmt
		parseAssStmt =
			AssStmt <$> (parseVarDef <* satTok AssignmentToken) <*> parseExpr

		parseIfStmt :: Parser Token Stmt
		parseIfStmt = liftM3 IfStmt
            (satTok IfToken *> parseBBraces parseExpr)
            (parseBlock <|> parseOneLine)
            (liftM (fromMaybe [])
                (optional (satTok ElseToken *> (parseBlock<|> parseOneLine))))

		parseWhileStmt :: Parser Token Stmt
		parseWhileStmt = satTok WhileToken *> (WhileStmt <$> 
			(parseBBraces parseExpr) <*> (parseBlock <|> parseOneLine))

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

		parseOneLine :: Parser Token [Stmt]
		//first pure makes singleton list from the statement
		parseOneLine = pure <$> parseStmt

parseFunType :: Parser Token FunType
parseFunType = satTok DoubleColonToken *>
	(parseInOutType <|> ((FunType []) <$> parseVoidOrType))
	where
		parseInOutType :: Parser Token FunType
		parseInOutType =  FunType <$> (some parseType <* satTok ArrowToken) <*> parseVoidOrType

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

parseVarDecl :: Parser Token VarDecl
parseVarDecl = liftM4 VarDecl
    peekPos
	(parseType <|> trans1 VarToken VarType )
	(parseIdent <* satTok AssignmentToken)
	(parseExpr <* satTok SColonToken)

parseType :: Parser Token Type
parseType =
	trans1 IntTypeToken IntType <|>
	trans1 CharTypeToken CharType <|>
	trans1 BoolTypeToken BoolType <|>
	(ListType <$> (parseBSqBraces parseType)) <|>
	(TupleType <$> (parseTuple parseType)) <|>
	(IdType <$> parseIdent)

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 = peekPos >>= \pos-> prev >>= \e1->optional (
				ops >>= \op->parseOpR ops prev >>= \e->pure (op, e)
			) >>= \moe->pure $ maybe e1 (\(op,e2)->Op2Expr pos e1 op e2) moe

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

		parseBasicExpr :: Parser Token Expr
		parseBasicExpr = peekPos >>= \pos ->
			(TupleExpr pos <$> (parseTuple parseExpr)) <|>
			(FunExpr pos <$> parseFunCall) <|>
			parseBBraces parseExpr <|>
			trans1 EmptyListToken (EmptyListExpr pos) <|>
			trans1 TrueToken (BoolExpr pos True) <|>
			trans1 FalseToken (BoolExpr pos False) <|>
			trans2 (NumberToken zero) (\(NumberToken i)->IntExpr pos i) <|>
			trans2 (CharToken zero) (\(CharToken c)->CharExpr pos c) <|>
			(Op1Expr pos <$> parseOp1 <*> parseExpr) <|>
			(VarExpr pos <$> parseVarDef)

parseFunCall :: Parser Token FunCall
parseFunCall = FunCall <$> parseIdent <*> (parseBBraces $ parseSepList CommaToken parseExpr)

parseVarDef :: Parser Token VarDef
parseVarDef = liftM2 VarDef
	parseIdent
	(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))))

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

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

parseBSqBraces :: (Parser Token a) -> Parser Token a
parseBSqBraces p = satTok SquareOpenToken *> p <* satTok SquareCloseToken

parseTuple :: (Parser Token a) -> Parser Token (a, a)
parseTuple p = satTok BraceOpenToken *>
	(liftM2 (\a->(\b->(a,b))) (p <* satTok CommaToken) p)
	<* satTok BraceCloseToken

trans :: TokenValue (TokenValue -> a) -> Parser Token (Pos, a)
trans t f = (\(pos,token)->(pos, f token)) <$> satTok t

trans2 :: TokenValue (TokenValue -> a) -> Parser Token a
trans2 t f = snd <$> trans t f

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

peekPos :: Parser Token Pos
peekPos = fst <$> peek

derive gPrint TokenValue
derive gEq TokenValue
satTok :: TokenValue -> Parser Token Token
satTok t = top >>= \tok=:({line,col},token) -> if (eq t token)
	(pure tok) (fail <?> PositionalError line col
		("ParseError: Unexpected token: " +++ printToString token))
	where
		eq (IdentToken _)  (IdentToken _) = True
		eq (NumberToken _) (NumberToken _) = True
		eq (CharToken _)   (CharToken _) = True
		eq x y = gEq {|*|} x y

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

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

//liftM only goes to liftM5
liftM6 f m1 m2 m3 m4 m5 m6 = f <$> m1 <*> m2 <*> m3 <*> m4 <*> m5 <*> m6