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

//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

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

freshIdent :: Env String
freshIdent = get >>= \(st, [ident:rest])-> put (st, rest) 
    >>| case 'Map'.get ident st of
        Nothing = pure ident
        _       = freshIdent

putIdent :: String Type -> Env Void
putIdent i t = gets (\(st, r)->'Map'.get i st) >>= \mt -> case mt of
    Nothing = modify (\(st, r)->('Map'.put i t st, r))
    Just t2 = unify t t2 >>= \t3-> 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) = case evalStateT m ('Map'.newMap, getRandomStream 1) 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)

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) = typeExpr e1 >>= \t1 -> unify t1 e2 
    >>| pure BoolType //todo, actually check t1 in Char,Bool,Int
typeExpr (Op2Expr p e1 BiUnEqual e2) = typeExpr (Op2Expr p e1 BiEquals e2)
//char of int
typeExpr (Op2Expr p e1 BiLesser e2) = typeExpr e1 >>= \t1 -> unify t1 e2 
    >>| pure BoolType //todo, actually check t1 in Char, Int
typeExpr (Op2Expr p e1 BiGreater e2) = typeExpr (Op2Expr p e1 BiLesser e2)
typeExpr (Op2Expr p e1 BiLesserEq e2) = typeExpr (Op2Expr p e1 BiLesser e2)
typeExpr (Op2Expr p e1 BiGreaterEq e2) = typeExpr (Op2Expr p e1 BiLesser e2)
//bool
typeExpr (Op2Expr p e1 BiAnd e2) = unify BoolType e1 >>| unify BoolType e2
typeExpr (Op2Expr p e1 BiOr e2) = unify BoolType e1 >>| unify BoolType e2
//a
typeExpr (Op2Expr p e1 BiCons e2) = typeExpr e1 >>= \t1-> typeExpr e2 
    >>= \t2-> unify (ListType t1) t2
typeExpr (EmptyListExpr p) = freshIdent >>= \frsh-> let t = IdType frsh in
    putIdent frsh t >>| pure t
//typeExpr (FunExpr p FunCall) = 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 

//unify e (IdType i) = unify (IdType i) e
    //note, don't use putIdent as that will call unify again
    //unify (IdType i) e=:(IdType j) = modify (\(st, r)->('Map'.put j e st, r))

instance unify Type where
	unify IntType IntType = pure IntType
	unify BoolType BoolType = pure BoolType
	unify CharType CharType = pure CharType
    //unify (ListType t1) (ListType t2) = unify t1 t2
	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