http://stackoverflow.com/questions/3524485/mutually-recursive-evaluator-in-haskell

ExprLang.hs

{-# LANGUAGE DoRec #-}

module ExprLang where

import Control.Monad.Error
import Data.List
import Data.Maybe

-- Language

type Var = String
type Binds = [(Var, Val)]

data Val
  = Con     Int
  | Lam     Var    Expr
  deriving (Show, Eq)

data Expr
  = Val     Val
  | Var     Var
  | App     Expr   Expr
  | Sub     Expr   Expr
  | If      Expr   Expr  Expr
  | Let     Var    Expr  Expr
  | LetRec  Binds  Expr
  deriving (Show, Eq)


-- Evaluator

data Value
  = ValInt   Int
  | ValFun   Env   Var  Expr
  deriving (Show, Eq)

type Env = [(Var, Value)]

eval :: Env -> Expr -> Either String Value
eval env (Val v)       = evalVal env v
eval env (Var x)       = maybe (throwError  $ x ++ " not found")
                               return
                               (lookup x env)
eval env (App e1 e2)   = do
                         v1 <- eval env e1
                         v2 <- eval env e2
                         case v1 of
                           ValFun env1 x e -> eval ((x, v2):env1) e
                           _               -> throwError "First arg to App not a function"
eval env (Sub e1 e2)   = do
                         v1 <- eval env e1
                         v2 <- eval env e2
                         case (v1, v2) of
                           (ValInt x, ValInt y) -> return $ ValInt (x - y)
                           _                    -> throwError "Both args to Sub must be ints"
eval env (If p t f)    = do 
                         v1 <- eval env p
                         case v1 of
                           ValInt x -> if x /= 0
                                       then eval env t
                                       else eval env f
                           _        -> throwError "First arg of If must be an int"
eval env (Let x e1 e2) = do
                         v1 <- eval env e1
                         eval ((x, v1):env) e2
eval env (LetRec bs e) = do
                         rec env' <- mapM (evalBind env') bs
                         eval (env' ++ env) e
  where
    evalBind env' (x, v) = do
                      v' <- evalVal (env' ++ env) v
                      return (x, v')

evalVal :: Env -> Val -> Either String Value
evalVal _   (Con x)   = return $ ValInt x
evalVal env (Lam x e) = return $ ValFun env' x e
  where
    env' = filter ((`elem` fvs) . fst) env
    fvs  = fv e

fv :: Expr -> [Var]
fv (Val v)       = fvVal v
fv (Var x)       = [x]
fv (App e1 e2)   = nub (fv e1 ++ fv e2)
fv (Sub e1 e2)   = nub (fv e1 ++ fv e2)
fv (If p t f)    = nub (fv p ++ fv t ++ fv f)
fv (Let x e1 e2) = nub (fv e1 ++ (fv e2 \\ [x]))
fv (LetRec bs e) = nub (concatMap (fvVal . snd) bs ++ fv e)

fvVal :: Val -> [Var]
fvVal (Con _)   = []
fvVal (Lam x e) = fv e \\ [x]


-- Type Inferencer/Inferrer (what's the right word?)
data Type
  = Int
  | Fun    Type  Type
  | TyVar  Int
  deriving (Show, Eq)

type TyEnv  = [(Var, Type)]
type Substs = [(Int, Type)]

infer :: TyEnv -> Expr -> (Substs, Type)
infer env (Val v)         = inferVal env v
infer env (Var x)         = maybe (error $ "Var " ++ x ++ " not in type environment")
                                  (\t -> ([], t))
                                  (lookup x env)
infer env (App e1 e2)     = let (sbs1, ft1) = infer env e1
                                (sbs2, at1) = infer env e2
                                rt1         = TyVar 1234 -- Somewhat unique...
                                (sbs3, _)   = unify ft1 (Fun at1 rt1)
                                sbs4        = nub (sbs1 ++ sbs2 ++ sbs3)
                                rt3         = subst sbs4 rt1
                            in (sbs4, rt3)
infer env (Sub e1 e2)     = let (sbs1, ty1) = infer env e1
                                (sbs2, ty2) = infer env e2
                                (sbs3, _)   = unify ty1 Int
                                (sbs4, _)   = unify ty2 Int
                            in (nub (sbs1 ++ sbs2 ++ sbs3 ++ sbs4), Int)
infer env (If p t f)      = let (sbs1, ty1) = infer env p
                                (sbs2, ty2) = infer env t
                                (sbs3, ty3) = infer env f
                                sbs4        = nub (sbs1 ++ sbs2 ++ sbs3)
                                (sbs5, ty4)   = unify (subst sbs4 ty1) Int
                                sbs6        = nub (sbs4 ++ sbs5)
                                (sbs7, ty5) = unify (subst sbs5 ty2) (subst sbs5 ty3)
                            in ty4 `seq` (nub (sbs6 ++ sbs7), ty5)
infer env (Let x e1 e2)   = let (sbs1, xt) = infer env e1
                                env'       = (x, xt) : env
                                (sbs2, ty) = infer env' e2
                            in (nub (sbs1 ++ sbs2), ty)
infer env (LetRec bnds e) = let env1 = zip (map fst bnds) (map TyVar [length env + 1..]) ++ env
                                sbstys = map (inferVal env1 . snd) bnds
                                sbss = map fst sbstys
                                sbs1 = nub (concat sbss)
                                tys2 = map (subst sbs1 . snd) sbstys
                                env2 = zip (map fst bnds) tys2 ++ env
                                (sbs2, ty) = infer env2 e
                            in (nub (sbs1 ++ sbs2), ty)

inferVal :: TyEnv -> Val -> (Substs, Type)
inferVal _   (Con _)   = ([], Int)
inferVal env (Lam x e) = let at        = TyVar (length env) -- This is unique, right?
                             env'      = (x, at) : env
                             (sbs, rt) = infer env' e
                         in (sbs, Fun (subst sbs at) rt)

unify :: Type -> Type -> (Substs, Type)
unify (TyVar x)   (TyVar y)   = if x == y
                                then ([], TyVar x)
                                else ([(x, TyVar y)], TyVar y)
unify ty          (TyVar y)   = ([(y, ty)], ty)
unify (TyVar x)   ty          = ([(x, ty)], ty)
unify Int         Int         = ([], Int)
unify (Fun a1 r1) (Fun a2 r2) = let (sbs1, a3) = unify a1 a2
                                    (sbs2, r3) = unify r1 r2
                                in (nub (sbs1 ++ sbs2), Fun a3 r3)
unify ty1         ty2         = error $ "Can't unify " ++ show ty1 ++ " with " ++ show ty2

subst :: Substs -> Type -> Type
subst _   (Int) = Int
subst sbs (Fun at rt) = Fun (subst sbs at) (subst sbs rt)
subst sbs (TyVar x)   = fromMaybe (TyVar x) (lookup x sbs)

typeInfer :: Expr -> Type
typeInfer e = snd (infer [] e)


-- Test expressions

test1 :: Expr
test1 = Let "sub2" (Val (Lam "x" (Var "x" `Sub` Val (Con 2))))
            (Var "sub2" `App` Val (Con 5))

test2 :: Expr
test2 = Let "zero" (Val (Con 0))
            (If (Val (Con 0)) (Val (Lam "x" (Var "x"))) (Val (Lam "y" (Var "zero" `Sub` Var "y"))))

test3 :: Expr
test3 = LetRec [ ("even", Lam "x" (If (Var "x")
                                      (Var "odd" `App` (Var "x" `Sub` Val (Con 1)))
                                      (Val (Con 1))
                                  ))
               , ("odd",  Lam "x" (If (Var "x")
                                      (Var "even" `App` (Var "x" `Sub` Val (Con 1)))
                                      (Val (Con 0))
                                  ))
               ]
               (Var "even" `App` Val (Con 6))

test4 :: Expr
test4 = LetRec [ ("x", (Con 3))
           --  , ("y", Var "x") -- A variable reference in a letrec is impossible.
                                -- It is an expression, not a value.
               ]
               (Val (Con 0))