implementation module sem

import qualified Data.Map as Map

from Data.Func import $
from StdFunc import o, id

import Control.Monad
import Data.Either
import Data.Monoid
import Data.List 

import StdString
import StdList
import StdMisc
import StdEnum
import RWST
import GenEq

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

import AST

:: Scheme = Forall [String] Type
:: Gamma :== 'Map'.Map String Scheme
:: Constraints :== [(Type, Type)]
:: Infer a :== RWST Gamma Constraints [String] (Either SemError) a
:: SemError
	= ParseError Pos String 
	| UnifyError Pos Type Type 
    | FieldSelectorError Pos Type FieldSelector 
	| OperatorError Pos Op2 Type
    | UndeclaredVariableError Pos String
    | ArgumentMisMatchError Pos String
	| Error String

variableStream :: [String]
variableStream = map toString [1..]

sem :: AST -> SemOutput
sem (AST fd) = Right (AST fd, 'Map'.newMap)

instance toString Scheme where
	toString (Forall x t) = 
		concat ["Forall ": map ((+++) "\n") x] +++ toString t

instance toString Gamma where
	toString mp = 
		concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]

instance toString SemError where
	toString se = "SemError: "

uni :: Type Type -> Infer ()
uni t1 t2 = tell [(t1, t2)]

inEnv :: (String, Scheme) (Infer a) -> (Infer a)
inEnv (x, sc) m = local scope m
	where
		scope e = 'Map'.put x sc ('Map'.del x e )

fresh :: Infer Type
fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)

class infer a :: a -> Infer Type

op2Type :: Op2 -> Infer Type
op2Type op  | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
                = pure (IntType ->> IntType ->> IntType)
            | elem op [BiEquals, BiUnEqual]
                = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
            | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
                = pure (IntType ->> IntType ->> BoolType)
            | elem op [BiAnd, BiOr]
                = pure (BoolType ->> BoolType ->> BoolType)
            | op == BiCons 
                = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)

instance infer Expr where
	infer (VarExpr _ vd) = undef
	infer (Op2Expr _ e1 op e2) = case op of
		BiPlus = pure IntType
		BiMinus = pure IntType
		BiTimes = pure IntType
		BiDivide = pure IntType
		BiMod = pure IntType
		BiLesser = pure IntType
		BiGreater = pure IntType
		BiLesserEq = pure IntType
		BiGreaterEq = pure IntType
		BiAnd = pure BoolType
		BiOr = pure BoolType
		BiEquals = infer e1
		BiUnEqual = infer e1 // maybe check e2?
		BiCons = infer e1 >>= \it1->pure $ ListType it1
	infer (Op1Expr _ op e) = case op of
		UnMinus = pure IntType
		UnNegation = pure BoolType
	infer (IntExpr _ _) = pure IntType
	infer (CharExpr _ _) = pure CharType
	infer (BoolExpr _ _) = pure BoolType
	infer (FunExpr _ _ _ _) = undef
	infer (EmptyListExpr _) = undef
	infer (TupleExpr _ (e1, e2)) =
		infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)

//:: VarDef = VarDef String [FieldSelector]
//:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
//:: Op1 = UnNegation | UnMinus
//:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
//	BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
//:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
//:: FunCall = FunCall String [Expr]
//:: Stmt 
//	= IfStmt Expr [Stmt] [Stmt]
//	| WhileStmt Expr [Stmt]
//	| AssStmt VarDef Expr
//	| FunStmt FunCall
//	| ReturnStmt (Maybe Expr)
//:: Pos = {line :: Int, col :: Int}
//:: AST = AST [VarDecl] [FunDecl]
//:: VarDecl = VarDecl Pos Type String Expr
//:: Type 
//	= TupleType (Type, Type)
//	| ListType Type
//	| IdType String 
//	| IntType 
//	| BoolType
//	| CharType
//	| VarType
//    | VoidType
//    | (->>) infixl 7 Type Type