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 = Env (State Gamma (Either SemError a))

instance Functor Env where
    fmap f m = liftM f m

instance Applicative Env where
    (<*>) f g   = ap f g
    pure  a     = Env $ pure $ Right a

//instance Alternative Env where
//    empty       = Env $ pure $ Left (Error "Undefined error")
//    (<|>) f g   = f >>= \ef -> g >>= \eg -> Env $ pure $ case ef of 
//        Left e  = eg
//        Right r = Right r

instance Monad Env where
    bind e f    = e >>= \ee -> Env $ pure $ case ee of
        (Left e) = Left e
        (Right r) = f r

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

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 x = undef
/*
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)

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->case et of
		Left err = pure $ Left err
		Right t = putIdent ident t >>| pure (Right $ VarDecl pos t ident ex)

typeExpr :: Expr -> Env Type
typeExpr (IntExpr _ _) = pure $ Right IntType
typeExpr (CharExpr _ _) = pure $ Right CharType
typeExpr (BoolExpr _ _) = pure $ Right BoolType
typeExpr (Op1Expr p UnNegation expr) = unify BoolType expr
typeExpr (Op1Expr p UnMinus expr) = unify IntType expr
typeExpr (TupleExpr p (e1, e2)) = typeExpr e1 
	>>= \ete1->typeExpr e2 >>= \ete2->pure (
		ete1 >>= \te1->ete2 >>= \te2->Right $ TupleType (te1, te2))
//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 = 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 VarType e = typeExpr e
	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
*/