{-# LANGUAGE RecursiveDo, GeneralizedNewtypeDeriving,
TypeSynonymInstances, MultiParamTypeClasses #-}
import Control.Monad
import Control.Monad.State
import Control.Monad.Error
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.Fix
import qualified Data.Map as M

data Expr = Let [(String, Expr)] Expr | Const Int | Var String
          | Lam String Expr | App Expr Expr

data Value = Data String | Function (Value -> Eval Value)

instance Show Value where
    show (Data s) = s

type Env = M.Map String Value

eval :: Expr -> Eval Value
eval (Const n) = return (Data (show n))
eval (Var x) = Eval $ noError $ do
  env <- get
  case M.lookup x env of
    Just v -> return v
    Nothing -> do
      warning ("reference to undefined variable " ++ show x)
      let v = Data ""
      modify (M.insert x v)
      return v
eval (Let decls body) = mdo
  let (names,exprs) = unzip decls
      updateEnv env = foldr (uncurry M.insert) env $ zip names values
  (values,result) <- local updateEnv $ liftM2 (,) (mapM eval exprs) (eval body)
  return result
eval (Lam parm body) = do
  env <- ask
  return $ Function (\val -> local (\_ -> M.insert parm val env) (eval body))
eval (App fun arg) = do
  f <- eval fun
  x <- eval arg -- call-by-value, so evaluate the arg first
  case f of
    Function f -> f x

warning s = tell $ ["Warning: " ++ s]

newtype Eval a = Eval {
    unEval :: ErrorT String (StateT Env (Writer [String])) a
  } deriving (
    Monad, MonadFix, MonadWriter [String],
    MonadState Env, MonadError String
  )

runEval :: Eval Value -> Either String Value
runEval = fst . runWriter . flip evalStateT M.empty . runErrorT . unEval

evaluate = runEval . eval

instance MonadReader Env Eval where
  ask = get
  local tr act = do
    s <- get
    modify tr
    r <- act
    put s
    return r

noError ::  (Monad m, Error e) => ErrorT e m a -> ErrorT e m a
noError m = ErrorT $ do
  ~(Right r) <- runErrorT m
  return (Right r)

-- examples
good1 = Let [("x", Const 1)] (Var "x")
good2 = Let [("y", Var "x"),("x", Const 1)] (Var "y")
bad1 = Let [("x", Const 1)] (Var "y")
letf = Let [("f",Lam "x" (Var "x"))] (App (Var "f") (Const 1))
badapp = Let [("f",Lam "x" (Var "x"))] (App (Const 1) (Var "f"))