implementation module sem

import qualified Data.Map as Map
from Data.Func import $
import Data.Maybe
import Data.Either
import Data.Functor
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Identity
import StdMisc
from StdFunc import id, const
import StdString
import StdList

from Text import class Text(concat), instance Text String

import AST
from parse import :: ParserOutput, :: Error

:: Gamma :== 'Map'.Map String Type
:: Env a :== (State Gamma (Either SemError a))

get = state $ \s -> (s,s)

putIdent :: String Type -> Env Void
putIdent i t = gets ('Map'.get i) >>= \mt -> case mt of
    Nothing = pure <$> modify ('Map'.put i t)
    Just t2 = unify t t2 >>= \r -> case r of
        Left e  = pure $ Left e
        Right t3 = pure <$> modify ('Map'.put i t3)

instance toString SemError where
	toString (ParseError p e) = concat [
		toString p,"SemError: ParseError: ", e]
	toString (Error e) = "SemError: " +++ e
	toString (UnifyError p t1 t2) = concat [
		toString p,
		"SemError: Cannot unify types. Expected: ",
		toString t1, ". Given: ", toString t2]

sem :: AST -> SemOutput
sem (AST vd fd)
# (eithervds, gamma) = runState (mapM semVarDecl vd) 'Map'.newMap
# (eitherfds, gamma) = runState (mapM semFunDecl fd) gamma
= case splitEithers eithervds of
	(Left errs) = Left $ errs ++ [x\\(Left x)<-eitherfds]
	(Right vds) = case splitEithers eitherfds of
		(Left errs) = Left errs
		(Right fds) = Right $ AST vds fds

splitEithers :: [Either a b] -> Either [a] [b]
splitEithers [] = Right []
splitEithers [Right x:xs] = splitEithers xs >>= \rest->Right [x:rest]
splitEithers xs = Left $ [x\\(Left x)<-xs]

semFunDecl :: FunDecl -> Env FunDecl
semFunDecl f = pure $ Right f

semVarDecl :: VarDecl -> Env VarDecl
semVarDecl v = pure $ Right v
//Right v
//semVarDecl vd=:(VarDecl pos type ident expr) = case unify type expr of //	Left e = Left e
//	//TODO ident in de environment
//	Right e = Right $ pure vd

typeOp1 :: Pos Expr Type -> Env Type
typeOp1 p expr rtype = typeExpr expr >>= \exprtype->case exprtype of
	Left e = pure $ Left e
	Right rtype = pure $ Right rtype
	Right (IdType ident) = putIdent ident rtype >>| pure (Right rtype)
	Right t = pure $ Left $ UnifyError p rtype t

typeExpr :: Expr -> Env Type
typeExpr (IntExpr _ _) = pure $ Right IntType
typeExpr (CharExpr _ _) = pure $ Right CharType
typeExpr (BoolExpr _ _) = pure $ Right BoolType
typeExpr (Op1Expr p UnNegation expr) = typeOp1 p expr BoolType
typeExpr (Op1Expr p UnMinus expr) = typeOp1 p expr IntType
typeExpr (TupleExpr p (e1, e2)) = typeExpr e1 
	>>= \ete1->typeExpr e2 >>= \ete2->pure (
		ete1 >>= \te1->ete2 >>= \te2->Right $ TupleType (te1, te2))
//typeExpr (Op1Expr p UnMinus expr) = typeExpr expr 
//	>>= \exprtype->case exprtype of
//		IntType = pure $ Right IntType
//		t = Left $ UnifyError p IntType exprtype
//typeExpr (Op2Expr Pos Expr Op2 Expr) = undef
//typeExpr (FunExpr Pos FunCall) = undef
//typeExpr (EmptyListExpr Pos) = undef
//typeExpr (VarExpr Pos VarDef) = undef

class unify a :: Type a -> Env Type

instance unify Type where
	unify IntType IntType = pure $ Right IntType
	unify BoolType BoolType = pure $ Right BoolType
	unify CharType CharType = pure $ Right CharType
	unify _ _ = undef
//
//instance unify Expr where
//	unify type expr = case type of
//		_ ->> _ = Left $ ParseError (extrPos expr)
//			"Expression cannot be a higher order function. Yet..."
//		VoidType = Left $ ParseError (extrPos expr)
//			"Expression cannot be a Void type."
//		IdType _ = Left $ ParseError (extrPos expr)
//			"Expression cannot be an polymorf type."
//		TupleType (_, _) = undef
//		ListType _ = undef
//		IntType = undef
//		BoolType = undef
//		CharType = undef
//		VarType = undef