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 Control.Monad.Trans
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 :== StateT Gamma (Either SemError) a

//we need to redefine this even though it is in Control.Monad.State
instance MonadTrans (StateT Gamma) where
    liftT m = StateT \s-> m >>= \a-> return (a, s)

get = gets id

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]

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

sem :: AST -> SemOutput
sem (AST vd fd) = case evalStateT m 'Map'.newMap of
    Left e = Left [e]
    Right (vds, fds) = Right (AST vds fds)
where 
    m :: Env (([VarDecl], [FunDecl]))
    m = (mapM semVarDecl vd) >>= \vds -> 
        mapM semFunDecl fd >>= \fds -> 
        pure (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 f

semVarDecl :: VarDecl -> Env VarDecl
semVarDecl (VarDecl pos type ident ex) = unify type ex
    >>= \t-> putIdent ident t >>| (pure $ VarDecl pos t ident ex)

typeExpr :: Expr -> Env Type
typeExpr (IntExpr _ _) = pure IntType
typeExpr (CharExpr _ _) = pure CharType
typeExpr (BoolExpr _ _) = pure BoolType
typeExpr (Op1Expr p UnNegation expr) = unify BoolType expr
typeExpr (Op1Expr p UnMinus expr) = unify IntType expr
typeExpr (TupleExpr p (e1, e2)) = typeExpr e1 
    >>= \t1-> typeExpr e2 >>= \t2-> pure $ TupleType (t1, t2)
//Int
typeExpr (Op2Expr p e1 BiPlus e2) = unify IntType e1 >>| unify IntType e2
typeExpr (Op2Expr p e1 BiMinus e2) = unify IntType e1 >>| unify IntType e2
typeExpr (Op2Expr p e1 BiTimes e2) = unify IntType e1 >>| unify IntType e2
typeExpr (Op2Expr p e1 BiDivide e2) = unify IntType e1 >>| unify IntType e2
typeExpr (Op2Expr p e1 BiMod e2) = unify IntType e1 >>| unify IntType e2
//bool, char of int
typeExpr (Op2Expr p e1 BiEquals e2) = undef
typeExpr (Op2Expr p e1 BiUnEqual e2) = undef
//char of int
typeExpr (Op2Expr p e1 BiLesser e2) = undef
typeExpr (Op2Expr p e1 BiGreater e2) = undef
typeExpr (Op2Expr p e1 BiLesserEq e2) = undef
typeExpr (Op2Expr p e1 BiGreaterEq e2) = undef
//bool
typeExpr (Op2Expr p e1 BiAnd e2) = undef
typeExpr (Op2Expr p e1 BiOr e2) = undef
//a
typeExpr (Op2Expr p e1 BiCons e2) = undef
//typeExpr (FunExpr Pos FunCall) = undef
//typeExpr (EmptyListExpr Pos) = undef
//typeExpr (VarExpr Pos VarDef) = undef //when checking var-expr, be sure to put the infered type
                                        //in the context

class unify a :: Type a -> Env Type

instance unify Expr where
	unify (_ ->> _) e = liftT $ Left $ ParseError (extrPos e)
			"Expression cannot be a higher order function. Yet..."
	unify VoidType e = liftT $ Left $ ParseError (extrPos e)
			"Expression cannot be a Void type."
	unify (IdType _) e = liftT $ Left $ ParseError (extrPos e)
			"Expression cannot be an polymorf type."
    unify VarType e = typeExpr e
    //we have to cheat to decorate the error, can be done nicer?
    unify t e = StateT $ \s0 -> let res = runStateT m s0 in case res of
        Left err = Left $ decErr e err
        Right t = Right t //note, t :: (Type, Gamma) 
    where m = typeExpr e >>= \tex-> unify t tex 

instance unify Type where
	unify IntType IntType = pure IntType
	unify BoolType BoolType = pure BoolType
	unify CharType CharType = pure CharType
	unify t1 t2 = liftT $ 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

dc2 :: Expr (Either SemError a) -> Either SemError a
dc2 e (Right t) = Right t
dc2 e (Left err) = Left 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