{-# 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 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

data Definition = Thunk Expr | Value Value

type Env = M.Map String Definition

eval :: Expr -> Eval Value
eval (Const n) = return (Data (show n))
eval (Var x) = do
  env <- get
  case M.lookup x env of
    Just (Thunk expr) -> do
      val <- eval expr
      put (M.insert x (Value val) env)
      return val
    Just (Value val) -> return val
    Nothing -> do
      warning ("reference to undefined variable " ++ show x)
      let val = Data "<undefined>"
      put (M.insert x (Value val) env)
      return val
eval (Let decls body) = do
  let define (name,expr) = (name, Thunk expr)
       -- no evaluation yet, i.e. lazy variable definition
      updateEnv env = foldr (uncurry M.insert) env $ map define decls
  local updateEnv $ eval body
eval (Lam parm body) = do
  env <- ask
  return $ Function (\val -> local (\_ -> M.insert parm (Value val) env) (eval body))
eval (App fun arg) = do
  f <- eval fun
  case f of
    Function f -> do
      eval arg >>= f -- call-by-value, i.e. application is strict
    Data s ->
      throwError $ "application of non-function `" ++ s ++ "`"

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

newtype Eval a = Eval {
    unEval :: ErrorT String (StateT Env (Writer [String])) a
  } deriving (
    Monad, 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

-- examples

good1 = Let [("x", Const 1)] (Var "x")
-- Right 1
good2 = Let [("y", Var "x"),("x", Const 1)] (Var "y")
-- Right 1
undef1 = Let [("x", Const 1)] (Var "y")
-- Right <undefined>
letf = Let [("f",Lam "x" (Var "x"))] (App (Var "f") (Const 1))
-- Right 1
badapp = Let [("f",Lam "x" (Var "x"))] (App (Const 1) (Var "f"))
-- Left "application of non-function `1`"
undef2 = Let [("x", Var "x")] (Var "y")
-- Right <undefined>
bottom1 = Let [("x", Var "x")] (Var "x")
-- loops in ghci