module Eval where

import Abs
import Prelude hiding (lookup)
import Parser.AbsSchmim
import Control.Monad.Reader
import Data.Map.Lazy
import Typecheck

type Interpreter a = ReaderT Env (Either String) a

eval :: Exp -> Interpreter Val
eval (EAdd e1 e2) = do
    (VNum v1) <- eval e1
    (VNum v2) <- eval e2
    return (VNum $ v1 + v2)
eval (EMul e1 e2) = do
    (VNum v1) <- eval e1
    (VNum v2) <- eval e2
    return (VNum $ v1 * v2)
eval (ESub e1 e2) = do
    (VNum v1) <- eval e1
    (VNum v2) <- eval e2
    return (VNum $ v1 - v2)
eval (EDiv e1 e2) = do
    (VNum v1) <- eval e1
    (VNum v2) <- eval e2
    if v2 == 0
    then lift $ Left "division by 0"
    else return (VNum $ v1 `div` v2)
eval (EVar x) = do
    (Just v) <- asks $ lookup x
    return v
eval (ENum n) = return (VNum n)
eval (EAbs x t e) = do
    env <- ask
    return $ VAbs x t env e
eval (EApp e1 []) = do
    eval e1
eval (EApp e1 [e2]) = do
    (VAbs x t env e) <- eval e1
    v <- eval e2
    local (\_ -> insert x v env) $ eval e
eval (EApp e1 (e2:es)) = do
    eval (EApp (EApp e1 [e2]) es)
eval ETr = return VTr
eval EFl = return VFl
eval (EEq e1 e2) = do
    (VNum v1) <- eval e1
    (VNum v2) <- eval e2
    return $ if v1 == v2 then VTr else VFl
eval (ELeq e1 e2) = do
    (VNum v1) <- eval e1
    (VNum v2) <- eval e2
    return $ if v1 <= v2 then VTr else VFl
eval (EGeq e1 e2) = do
    (VNum v1) <- eval e1
    (VNum v2) <- eval e2
    return $ if v1 >= v2 then VTr else VFl
eval (ELess e1 e2) = do
    (VNum v1) <- eval e1
    (VNum v2) <- eval e2
    return $ if v1 < v2 then VTr else VFl
eval (EGrt e1 e2) = do
    (VNum v1) <- eval e1
    (VNum v2) <- eval e2
    return $ if v1 > v2 then VTr else VFl
eval (EAnd e1 e2) = do
    v1 <- eval e1
    v2 <- eval e2
    return $ case (v1, v2) of
                (VTr, VTr) -> VTr
                _ -> VFl
eval (EOr e1 e2) = do
    v1 <- eval e1
    v2 <- eval e2
    return $ case (v1, v2) of
                (VFl, VFl) -> VFl
                _ -> VTr
eval (EIfte e1 e2 e3) = do
    v1 <- eval e1
    let e = case v1 of
                VTr -> e2
                VFl -> e3
    eval e
eval (EVrnt l e t) = do
    v <- eval e
    return $ VVrnt l v t
eval (ETpl es) = do
    vs <- forM es eval
    return $ VTpl vs
eval (EProj e i) = do
    (VTpl vs) <- eval e
    return $ vs !! (fromIntegral (i - 1))
eval (EMtch e ms) = do
    (VVrnt l v t) <- eval e
    let (Matching _ x e') = lookupLabel l ms
    local (insert x v) $ eval e'
    where
        lookupLabel l (m@(Matching l' x e):ms)
            | l == l' = m
            | otherwise = lookupLabel l ms
eval (ENil t) = return $ VNil t
eval (ECons e1 e2) = do
    v1 <- eval e1
    v2 <- eval e2
    return (VCons v1 v2)
eval (EHead e) = do
    v <- eval e
    case v of
        (VNil _) -> lift $ Left "head of empty list"
        (VCons v _) -> return v
eval (ETail e) = do
    v <- eval e
    case v of
        (VNil _) -> lift $ Left "tail of empty list"
        (VCons _ v) -> return v
eval (EIsnil e) = do
    v <- eval e
    return $ case v of
                (VNil _) -> VTr
                _ -> VFl
eval (EFix (EAbs x t e)) = do
    env <- ask
    let env' = insert x (forcedEval (EFix (EAbs x t e)) env') env
    local (\_ -> env') $ eval e
    where
    forcedEval e env = case runReaderT (eval e) env of
        Right v -> v
eval (ELet x ps e1 e2) = do
    eval (EApp (EAbs x t e2) [e1'])
    where
        (e1', t) = Prelude.foldr (\(Param x t') (e, t) -> ((EAbs x t' e), TFun t' t)) (e1, placeholderType) ps
eval (ELetrec x _ ps e1 e2) = do
    eval (EApp (EAbs x t e2) [(EFix (EAbs x t e1'))])
    where
        (e1', t) = Prelude.foldr (\(Param x t') (e, t) -> ((EAbs x t' e), TFun t' t)) (e1, placeholderType) ps

placeholderType = TInt

interp :: Exp -> Either String Val
interp e = case runReaderT (typeof e) empty of
    (Just t) -> runReaderT (eval e) empty
    Nothing -> Left "badly typed expression"