Typical CBV evaluator

CBV.hs

module CBV where

import Prelude hiding (lookup)
import qualified Data.Map as Map

type Id = String

data Exp
  = Id Id
  | Fun Id Exp
  | App Exp Exp
  | Int Int
  | Add Exp Exp
  | Div Exp Exp
  deriving (Show)

data Val
  = FunV Env Id Exp
  | IntV Int
  deriving (Show)

type Env = Map.Map Id Val

data Result a
  = OK a
  | Error String

instance Monad Result where
  return a = OK a
	
	(OK a) >>= f = f a
	(Error str) >>= _ = Error str

	fail msg = Error msg

lookup :: Id -> Env -> Result Val
lookup x env = case Map.lookup x env of
	Just x -> return x
	Nothing -> fail $ "free identifier " ++ x

bind :: Id -> Val -> Env -> Env
bind x v e = Map.insert x v e

emptyEnv :: Env
emptyEnv = Map.empty

eval :: Env -> Exp -> Result Val
eval env (Id x) = lookup x env
eval env (Fun x e) = return (FunV env x e)
eval env (App e1 e2) = do
	v1 <- eval env e1
	v2 <- eval env e2
	case v1 of
		FunV env' x e -> eval (bind x v2 env') e
		IntV _ -> fail "expected function"
eval env (Int n) = return (IntV n)
eval env (Add e1 e2) = do
  v1 <- eval env e1
  v2 <- eval env e2
  case (v1, v2) of
  	(IntV n1, IntV n2) -> return (IntV (n1 + n2))
  	_ -> fail "expected numbers"
eval env (Div e1 e2) = do
  v1 <- eval env e1
  v2 <- eval env e2
  case (v1, v2) of
  	(IntV _, IntV 0) -> fail "division by zero"
  	(IntV n1, IntV n2) -> return (IntV (n1 `div` n2))
  	_ -> fail "expected numbers"