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 (UnifyErrorStub t1 t2) = toString (UnifyError {line=0,col=0} t1 t2)
	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 vd=:(VarDecl pos type ident ex) = unify type ex
	>>= \et->pure (
		et >>= \t->pure $ VarDecl pos t ident ex)
//Right v
//	//TODO ident in de environment
//	Right e = Right $ pure vd

typeOp1 :: Pos Expr Type -> Env Type
typeOp1 p expr rtype = unify rtype expr

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 (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 Expr where
	unify (_ ->> _) e = pure $ Left $ ParseError (extrPos e)
			"Expression cannot be a higher order function. Yet..."
	unify VoidType e = pure $ Left $ ParseError (extrPos e)
			"Expression cannot be a Void type."
	unify (IdType _) e = pure $ Left $ ParseError (extrPos e)
			"Expression cannot be an polymorf type."
	unify t e = typeExpr e
		>>= \eithertype->case eithertype of
			Left e = pure $ Left e
			Right tex = unify t tex >>= \eitherun->case eitherun of
				Left err = pure $ Left $ decErr e err
				Right t = pure $ Right t

instance unify Type where
	unify IntType IntType = pure $ Right IntType
	unify BoolType BoolType = pure $ Right BoolType
	unify CharType CharType = pure $ Right CharType
	unify t1 t2 = pure $ Left $ UnifyError zero t1 t2

instance zero Pos where
	zero = {line=0,col=0}

decErr :: Expr SemError -> SemError
decErr e (UnifyError _ t1 t2) = UnifyError (extrPos e) t1 t2
decErr e (ParseError _ s) = ParseError (extrPos e) s
decErr e err = err

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