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
//
typeExpr :: Expr -> Env Type
typeExpr (IntExpr _ _) = pure $ Right IntType
typeExpr (CharExpr _ _) = pure $ Right CharType
typeExpr (BoolExpr _ _) = pure $ Right BoolType
typeExpr (Op1Expr p UnNegation expr) = typeExpr expr 
	>>= \exprtype->case exprtype of
        Left e = pure $ Left e
		Right BoolType = pure $ Right BoolType
        Right (IdType ident) = putIdent ident BoolType >>| pure (Right BoolType)
		Right t = pure $ Left $ UnifyError p BoolType t
//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 (TupleExpr Pos (Expr, Expr)) = 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
//
//extrPos :: Expr -> Pos
//extrPos (VarExpr p _) = p
//extrPos (Op2Expr p _ _ _) = p
//extrPos (Op1Expr p _ _) = p
//extrPos (IntExpr p _) = p
//extrPos (CharExpr p _) = p
//extrPos (BoolExpr p _) = p
//extrPos (FunExpr p _) = p
//extrPos (EmptyListExpr p) = p
//extrPos (TupleExpr p _) = p