implementation module parse

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

import yard
import lex
import AST

parser :: [Token] -> ParserOutput
parser ts = case runParser parseProgram ts of
	(Right ast, [(p, t):xs]) = Left $ PositionalError p.line p.col (
		"Unable to parse from: " +++ printToString t)
	x = fst x

parseProgram :: Parser Token AST
parseProgram = many parseLetDecl >>= \fds1->
                some parseFunDecl >>= \fds2->
                pure $ AST (fds1++fds2)

parseLetDecl :: Parser Token FunDecl
parseLetDecl = peekPos >>= \p->
                satTok LetToken >>|
                parseFunType >>= \mt->
                parseIdent >>= \f->
                satTok AssignmentToken >>|
                parseExpr >>= \e->
                satTok SColonToken >>|
                pure (FunDecl p f [] (Just mt) [] [ReturnStmt $ Just e])

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

parseStmt :: Parser Token [Stmt]
parseStmt = (parseIfStmt <|> parseWhileStmt <|>
	parseSColon parseAssStmt <|> parseSColon parseReturnStmt <|>
	(parseSColon parseFunCall 
		>>= \(ident, args, fs)->pure $ FunStmt ident args fs))
	>>= \stmt->case stmt of
		FunStmt "print" args fs = pure $ map (\a->FunStmt "print" [a] []) args
		s = pure [s]
	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 (flatten <$> many parseStmt)

		parseOneLine :: Parser Token [Stmt]
		parseOneLine = parseStmt

parseFunType :: Parser Token Type
parseFunType = parseFT >>= \t -> case t of
        t1 ->> t2   = pure t
        simpleT     = pure $ FuncType simpleT
	where
        parseFT :: Parser Token Type
		parseFT = (liftM2 (->>) (parseSF <* satTok ArrowToken) (parseFT)) <|>
			parseSF
		parseSF :: Parser Token Type
		parseSF = parseBBraces parseFT <|> parseType

parseVarDecl :: Parser Token VarDecl
parseVarDecl = liftM4 VarDecl
    peekPos
	((parseType >>= \t->pure $ Just t)<|> trans1 VarToken Nothing)
	(parseIdent <* satTok AssignmentToken)
	(parseExpr <* satTok SColonToken)

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

parseExpr :: Parser Token Expr
parseExpr = parseValueExpr <|> parseLambda

parseValueExpr :: Parser Token Expr
parseValueExpr = //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 ->
			(trans2 (StringToken []) (\(StringToken cs)->makeStrExpr pos cs)) <|>
			(TupleExpr pos <$> (parseTuple parseExpr)) <|>
			parseBBraces parseExpr <|>
            parseListLiteral <|>
			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) <|>
			(parseFunCall >>= \(ident, args, fs)->
				pure $ FunExpr pos ident args fs) <|>
			(VarExpr pos <$> parseVarDef)

        parseListLiteral :: Parser Token Expr
        parseListLiteral = peekPos >>= \p->
            satTok SquareOpenToken >>| 
            many (parseExpr <* satTok CommaToken) >>= \es->
            parseExpr >>= \e->
            foldM   (\res e-> pure $ Op2Expr p e BiCons res) 
                    (EmptyListExpr p) 
                    [e : reverse es] >>= \res->
            satTok SquareCloseToken >>| 
            pure res

parseLambda :: Parser Token Expr
parseLambda = LambdaExpr <$> peekPos 
                        <*> (satTok BackslashToken *> many parseIdent)
                        <*> (satTok ArrowToken *> parseExpr)

makeStrExpr :: Pos [Char] -> Expr
makeStrExpr p [] = EmptyListExpr p
makeStrExpr p [x:xs] = Op2Expr p (CharExpr zero x) BiCons (makeStrExpr p xs)

parseFunCall :: Parser Token (String, [Expr], [FieldSelector])
parseFunCall = liftM3 (\x y z->(x, y, z))
	parseIdent 
	(parseBBraces $ parseSepList CommaToken parseExpr)
	parseFieldSelectors

parseVarDef :: Parser Token VarDef
parseVarDef = liftM2 VarDef parseIdent parseFieldSelectors

parseFieldSelectors :: Parser Token [FieldSelector]
parseFieldSelectors = many (satTok DotToken *> 
	parseIdent >>= \i->case i of
		"hd" = pure FieldHd
		"tl" = pure FieldTl 
		"fst" = pure FieldFst
		"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 tuple (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 (tokEq t token)
	(pure tok) (fail <?> PositionalError line col
		("ParseError: Unexpected token: " +++ printToString token 
            +++ "\nExpected: " +++ printToString t))

tokEq (IdentToken _) (IdentToken _) = True
tokEq (NumberToken _) (NumberToken _) = True
tokEq (CharToken _) (CharToken _) = True
tokEq (StringToken _) (StringToken _) = True
tokEq x y = gEq {|*|} x y

parseSepList :: TokenValue (Parser Token a) -> Parser Token [a]
parseSepList sep p = pSL` sep p <|> pure []
	where 
		pSL` sep p = (p <* satTok sep >>= \v1->parseSepList sep p >>= \vs->pure [v1:vs]) <|> (p >>= \v->pure [v])

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