{-# OPTIONS -fglasgow-exts #-}

module LISS.Semantics where

import LISS.Syntax
import LISS.Environment

import Control.Monad.State
import Control.Monad.Error
import Control.Monad

class Semantics exp val | exp -> val where
	eval :: exp -> StateT Env IO val

evalLiss :: Liss -> IO ()
evalLiss (Liss name body) = evalStateT (eval body) emptyEnv

evalLissDebug :: Liss -> IO Env
evalLissDebug (Liss name body) = execStateT (eval body) emptyEnv

instance Semantics Body () where
	eval (Body decs st) = mapM eval decs >> eval st

instance Semantics Declaration () where
	eval (VarDec (Arg name Integer)) = addVar IntEnv name
	eval (VarDec (Arg name Boolean)) = addVar BoolEnv name
	eval (VarDec (Arg name Sequence)) = addVar SeqEnv name
	eval (VarDec (Arg name Set)) = addVar SetEnv name
	eval (VarDec (Arg name (Array size))) =
	     do guardMsg (size > 0) ("Array size \'"++show size++"\' not valid.")
		setNew ArrayEnv name (replicate size (defaultVal IntEnv))
	eval (SubprogDec specs name args Integer body (ReturnInt ie1)) =
		setNew IntFunEnv name (args, body, ie1)
	eval (SubprogDec specs name args Boolean body (ReturnBool ie1)) =
		setNew BoolFunEnv name (args, body, ie1)
	eval (SubprogDec specs name args Sequence body (ReturnSeq ie1)) =
		setNew SeqFunEnv name (args, body, ie1)
	eval (SubprogDec specs name args Set body (ReturnSet ie1)) =
		setNew SetFunEnv name (args, body, ie1)
	eval (SubprogDec specs name args (Array sz) body (ReturnArray ie1)) =
		setNew ArrayFunEnv name (args, body, ie1)
	eval _ = throwError (strMsg "Unconsistent function declaration")

instance Semantics Statement () where
	eval (IntAssign ivar ie1) = eval ie1 >>= setVal IntEnv ivar
	eval (BoolAssign bvar be1) = eval be1 >>= setVal BoolEnv bvar
	eval (SeqAssign svar se1) = eval se1 >>= setVal SeqEnv svar
	eval (SetAssign svar se1) = eval se1 >>= setVal SetEnv svar
	eval (ArrayPosAssign avar ie1 ie2) =
	     do iv1 <- eval ie1
		iv2 <- eval ie2
		setArrayPos avar iv1 iv2
	eval (SequenceS c1 c2) = eval c1 >> eval c2
	eval (IfThenElse be1 c1 c2) =
	     do bv1 <- eval be1
		if bv1 then eval c1 else eval c2
	eval (While la be1 c1) = while be1 c1
	eval (For ivar ll ul step be1 c1) =
	     eval (
		(IntAssign ivar ll) `SequenceS`
		(While (PBoolConst True, Nothing) -- probably wrong
                        (LessEq (IntVarExp ivar) ul)
			((IfThenElse be1 c1 Skip) `SequenceS`
			(IntAssign ivar (Sum (IntVarExp ivar) (IntConst step))))))
	eval (ForEach ivar se1 be1 c1) =
	     do nv <- get >>= return . freshVar SeqEnv
		eval se1 >>= setNew SeqEnv nv
		eval (
			(While (PBoolConst True, Nothing) -- probably wrong
                                (Negation (EmptySeq (SeqVarExp nv)))
				((IntAssign ivar (Head (SeqVarExp nv))) `SequenceS`
				((IfThenElse be1 c1 Skip) `SequenceS`
				(SeqAssign nv (Tail (SeqVarExp nv)))))))
	eval (Read ivar) =
	     do iv1 <- lift $ readLn
		setVal IntEnv ivar iv1
	eval (Write ie1) =
	     do iv1 <- eval ie1
		lift $ putStr (show iv1)
	eval (WriteString s) = lift $ putStr s
	eval Skip = return ()

instance Semantics IntExp Int where
	eval (IntConst i)  = return i
	eval (IntVarExp v) = getVal IntEnv v
	eval (ArrayAccess v e1) = eval e1 >>= getArrayPos v
	eval (Negative e1) = eval e1 >>= return . (0-)
	eval (Sum e1 e2)   =
	     do v1 <- eval e1
		v2 <- eval e2
		return (v1 + v2)
	eval (Sub e1 e2)   =
	     do v1 <- eval e1
		v2 <- eval e2
		return (v1 - v2)
	eval (Mult e1 e2)  =
	     do v1 <- eval e1
		v2 <- eval e2
		return (v1 * v2)
	eval (Div e1 e2)   =
	     do v1 <- eval e1
		v2 <- eval e2
		return (v1 `div` v2)
	eval (Rem e1 e2)   =
	     do v1 <- eval e1
		v2 <- eval e2
		return (v1 `mod` v2)
	eval (Head seq) =
	     do sq1 <- eval seq
		guardMsg (not $ null sq1) ("Call for 'head' on empty sequence: "++show seq++".")
		return (head sq1)
	eval (IntFunction name vars) = evalFunction IntFunEnv name vars

instance Semantics BoolExp Bool where
	eval (BoolConst b)   = return b
	eval (BoolVarExp v)  = getVal BoolEnv v
	eval (Equal ie1 ie2) =
	     do iv1 <- eval ie1
		iv2 <- eval ie2
		return (iv1 == iv2)
	eval (Diff ie1 ie2) =
	     do iv1 <- eval ie1
		iv2 <- eval ie2
		return (iv1 /= iv2)
	eval (Lesser ie1 ie2) =
	     do iv1 <- eval ie1
		iv2 <- eval ie2
		return (iv1 < iv2)
	eval (LessEq ie1 ie2) =
	     do iv1 <- eval ie1
		iv2 <- eval ie2
		return (iv1 <= iv2)
	eval (Greater ie1 ie2) =
	     do iv1 <- eval ie1
		iv2 <- eval ie2
		return (iv1 > iv2)
	eval (GreatEq ie1 ie2) =
	     do iv1 <- eval ie1
		iv2 <- eval ie2
		return (iv1 >= iv2)
	eval (Negation be1) = eval be1 >>= return . not
	eval (Conj  be1 be2) =
	     do bv1 <- eval be1
		bv2 <- eval be2
		return (bv1 && bv2)
	eval (Disj  be1 be2) =
	     do bv1 <- eval be1
		bv2 <- eval be2
		return (bv1 || bv2)
	eval (Imp  be1 be2) =
	     do bv1 <- eval be1
		bv2 <- eval be2
		if bv1 then return bv2 else return True
	eval (Equiv  be1 be2) =
	     do bv1 <- eval be1
		bv2 <- eval be2
		return (bv1 == bv2)
	eval (EmptySeq seq) = eval seq >>= return . null
	eval (ElemSet ie1 set) =
	     do iv1 <- eval ie1
		setcond <- eval set
		return (setcond iv1)
	eval (BoolFunction name vars) = evalFunction BoolFunEnv name vars

instance Semantics SeqExp [Int] where
	eval (SeqVarExp v)  = getVal SeqEnv v
	eval (SeqConst l)   = mapM eval l
	eval SeqNull = return []
	eval (Tail seq)     =
	     do sq1 <- eval seq
		guardMsg (not $ null sq1) ("Call for 'tail' on empty sequence: "++show seq++".")
		return (tail sq1)
	eval (Cons ie1 seq) =
	     do iv1 <- eval ie1
		seqv <- eval seq
		return (iv1:seqv)
	eval (SeqFunction name vars) = evalFunction SeqFunEnv name vars

instance Semantics SetExp (Int -> Bool) where
	eval (SetVarExp v) = getVal SetEnv v
	eval (SetConst v p) = eval (v,p)
	eval SetNull = return $ const False
	eval (Union se1 se2) =
	     do sv1 <- eval se1
		sv2 <- eval se2
		return (\i -> sv1 i || sv2 i)
	eval (Intersect se1 se2) =
	     do sv1 <- eval se1
		sv2 <- eval se2
		return (\i -> sv1 i && sv2 i)
	eval (SetFunction name vars) = evalFunction SetFunEnv name vars

instance Semantics ArrayExp [Int] where
	eval (ArrayVarExp v) = getVal ArrayEnv v
	eval (ArrayFunction name vars) = evalFunction ArrayFunEnv name vars

-- auxiliars
evalFunction :: (SubEnv ref (Args, Body, e), Semantics e res) => ref -> Var -> Vars -> StateT Env IO res
evalFunction ref name vars =
     do fun@(args, body, e) <- getVal ref name
     	guardMsg (length args == length vars) ("Wrong number of arguments to function \'"++name++"\'.")
	tvals <- zipWithM getTypedVal args vars
	result <- lift $ evalStateT (zipWithM_ argAssign args tvals >> eval body >> eval e) emptyEnv
	return result

data TypedVal = IntVal Int | BoolVal Bool | SeqVal Seq | SetVal Set | ArrayVal Array

getTypedVal :: (Error e, MonadError e m) => Arg -> Var -> StateT Env m TypedVal
getTypedVal (Arg _ Integer) var = getVal IntEnv var >>= return . IntVal
getTypedVal (Arg _ Boolean) var = getVal BoolEnv var >>= return . BoolVal
getTypedVal (Arg _ Sequence) var = getVal SeqEnv var >>= return . SeqVal
getTypedVal (Arg _ Set) var = getVal SetEnv var >>= return . SetVal
getTypedVal (Arg _ (Array sz)) var =
     do arr <- getVal ArrayEnv var
     	guardMsg (length arr == sz) ("Passed array \'"++var++"\' doesn't have the proper size.")
	return (ArrayVal arr)

argAssign :: (Error e, MonadError e m) => Arg -> TypedVal -> StateT Env m ()
argAssign (Arg name Integer) (IntVal val) = setNew IntEnv name val
argAssign (Arg name Boolean) (BoolVal val) = setNew BoolEnv name val 
argAssign (Arg name Sequence) (SeqVal val) = setNew SeqEnv name val 
argAssign (Arg name Set) (SetVal val) = setNew SetEnv name val 
argAssign (Arg name (Array sz)) (ArrayVal val) = setNew ArrayEnv name val
argAssign _ _ = throwError (strMsg "Uncompatible type in function argument")

while :: BoolExp -> Statement -> StateT Env IO ()
while be1 c1 =
     do bv1 <- eval be1
     	if (not bv1)
		then return ()
		else eval c1 >> while be1 c1

evalCondIntExp :: IntVar -> IntExp -> StateT Env IO (Int -> Int)
evalCondIntExp v (IntVarExp v') | v == v' = return id
evalCondIntExp v ie = eval ie >>= return . const

type Condition = (IntVar, BoolExp)
instance Semantics Condition (Int -> Bool) where
	eval (v,(Equal ie1 ie2)) =
	     do iv1 <- evalCondIntExp v ie1
		iv2 <- evalCondIntExp v ie2
		return (\i -> iv1 i == iv2 i)
	eval (v,(Diff ie1 ie2)) =
	     do iv1 <- evalCondIntExp v ie1
		iv2 <- evalCondIntExp v ie2
		return (\i -> iv1 i /= iv2 i)
	eval (v,(Lesser ie1 ie2)) =
	     do iv1 <- evalCondIntExp v ie1
		iv2 <- evalCondIntExp v ie2
		return (\i -> iv1 i < iv2 i)
	eval (v,(LessEq ie1 ie2)) =
	     do iv1 <- evalCondIntExp v ie1
		iv2 <- evalCondIntExp v ie2
		return (\i -> iv1 i <= iv2 i)
	eval (v,(Greater ie1 ie2)) =
	     do iv1 <- evalCondIntExp v ie1
		iv2 <- evalCondIntExp v ie2
		return (\i -> iv1 i > iv2 i)
	eval (v,(GreatEq ie1 ie2)) =
	     do iv1 <- evalCondIntExp v ie1
		iv2 <- evalCondIntExp v ie2
		return (\i -> iv1 i >= iv2 i)
	eval (v, be) = eval be >>= return . const

