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 Math.Random
import StdMisc
from StdFunc import id, const, o
import StdString
import StdTuple
import StdList

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

import AST
from parse import :: ParserOutput, :: Error

:: Gamma :== ('Map'.Map String Type, [String])
:: Env a :== (State Gamma (Either SemError a))

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

getRandomStream :: Int -> [String]
getRandomStream i = genIdents $ filter (isAlpha o toChar) (genRandInt i)
	where
		genIdents r = let (ic, r) = splitAt 5 r in [toString ic: genIdents r]

freshIdent :: Gamma -> (String, Gamma)
freshIdent (st, [ident:rest]) = case 'Map'.get ident st of
	Nothing = (ident, (st, rest))
	_ = freshIdent (st, rest)

putIdent :: String Type -> Env Void
putIdent i t = gets (\(st, r)->'Map'.get i st) >>= \mt -> case mt of
    Nothing = pure <$> modify (\(st, r)->('Map'.put i t st, r))
    Just t2 = unify t t2 >>= \r -> case r of
        Left e  = pure $ Left e
        Right t3 = pure <$> modify (\(st, r)->('Map'.put i t3 st, r))

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, getRandomStream 0)
# (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