A simple interpreter (that works). Supports ADT/pattern matching. No type system/callcc/macro.

gistfile1.hs

import qualified Data.Map as Map

type Env = Map.Map String Val

data Exp =
    ConstExp Val
    | VarExp String
    | LambdaExp Pat Exp
    | LetrecExp [(Pat,Exp)] Exp
    | IfExp Exp Exp Exp
    | CaseExp Exp [(Pat,Exp)]
    | AppExp Exp Exp
    | ADTExp String [Exp]
    | UnaryOpExp String Exp
    | BinaryOpExp String Exp Exp

data Val =
    UnitVal
    | BoolVal Bool
    | IntVal Int
    | FloatVal Float
    | ClosureVal Pat Exp Env
    | ADTVal String [Val]

data Pat =
    NilPat
    | ConstPat Val
    | VarPat String
    | ADTPat String [Pat]

instance Eq Val where
    UnitVal == UnitVal = True
    (BoolVal x) == (BoolVal y) = x == y
    (IntVal x) == (IntVal y) = x == y
    (FloatVal x) == (FloatVal y) = x == y
    (ADTVal x_adt x_val_list) == (ADTVal y_adt y_val_list) = (x_adt == y_adt) && (and [x==y|(x,y)<-zip x_val_list y_val_list])

match :: Pat -> Val -> Maybe Env
match NilPat _ = Just Map.empty
match (ConstPat pval) val = if pval == val then Just (Map.empty) else Nothing
match (VarPat var) val = Just (Map.singleton var val)
match (ADTPat pname plist) (ADTVal vname vlist) =
    let merge Nothing _ = Nothing
        merge _ Nothing = Nothing
        merge (Just env0) (Just env1) = Just (Map.union env0 env1)
    in if pname == vname then (foldl merge (Just Map.empty) [match p v|(p,v)<-zip plist vlist]) else Nothing

evalExp :: Exp -> Env -> Val
evalExp (ConstExp val) _ = val
evalExp (VarExp var) env = env Map.! var
evalExp (LambdaExp pat exp) env = ClosureVal pat exp env
evalExp (LetrecExp pat_exp_list exp) env =
    let new_env = Map.union delta_env env
        Just delta_env = match (ADTPat "" pat_list) (ADTVal "" val_list)
        pat_list = [p|(p,_)<-pat_exp_list]
        val_list = [evalExp e new_env|(_,e)<-pat_exp_list]
    in evalExp exp new_env
evalExp (IfExp cond_exp then_exp else_exp) env =
    let (BoolVal flag) = evalExp cond_exp env in
        if flag then evalExp then_exp env else evalExp else_exp env
evalExp (CaseExp exp pat_exp_list) env =
    let val = evalExp exp env
        f ((p,e):p_e_list) =
            case match p val of
                Just delta_env -> evalExp e (Map.union delta_env env)
                Nothing -> f p_e_list
    in f pat_exp_list
evalExp (AppExp f_exp x_exp) env =
    let (ClosureVal c_pat c_exp c_env) = evalExp f_exp env
        x_val = evalExp x_exp env
        (Just delta_env) = match c_pat x_val
    in evalExp c_exp (Map.union delta_env c_env)
evalExp (ADTExp adt_name exp_list) env = ADTVal adt_name [evalExp exp env|exp<-exp_list]
evalExp (UnaryOpExp op x_exp) env = error "todo"
evalExp (BinaryOpExp op x_exp y_exp) env =
    let x_val = evalExp x_exp env
        y_val = evalExp y_exp env
    in if op == "==" then BoolVal (x_val == y_val) else
        let f = (Map.fromList [("+",(+)),("-",(-)),("*",(*))]) Map.! op
            (IntVal x_int) = x_val
            (IntVal y_int) = y_val
        in IntVal (f x_int y_int)

top_exp :: Exp
top_exp =
    LetrecExp
        [(VarPat "f",
            LambdaExp (VarPat "x")
                (IfExp (BinaryOpExp "==" (VarExp "x") (ConstExp (IntVal 0)))
                    (ConstExp (IntVal 1))
                    (BinaryOpExp "*" (VarExp "x") (AppExp (VarExp "f") (BinaryOpExp "-" (VarExp "x") (ConstExp (IntVal 1)))))))]
        (AppExp (VarExp "f") (ConstExp (IntVal 5)))

top_exp_2 :: Exp
top_exp_2 =
    LetrecExp
        [(VarPat "even",
            LambdaExp (VarPat "x")
                (IfExp (BinaryOpExp "==" (VarExp "x") (ConstExp (IntVal 0)))
                    (ConstExp (BoolVal True))
                    (AppExp (VarExp "odd") (BinaryOpExp "-" (VarExp "x") (ConstExp (IntVal 1)))))),
         (VarPat "odd",
            LambdaExp (VarPat "x")
                (IfExp (BinaryOpExp "==" (VarExp "x") (ConstExp (IntVal 0)))
                    (ConstExp (BoolVal False))
                    (AppExp (VarExp "even") (BinaryOpExp "-" (VarExp "x") (ConstExp (IntVal 1))))))]
        (AppExp (VarExp "even") (ConstExp (IntVal 19)))

top_exp_3 :: Exp
top_exp_3 =
    LetrecExp
        [(VarPat "f",
            LambdaExp (VarPat "x")
                (CaseExp (VarExp "x")
                    [(ConstPat (IntVal 0),ConstExp (IntVal 1)),
                     (VarPat "x",BinaryOpExp "*" (VarExp "x") (AppExp (VarExp "f") (BinaryOpExp "-" (VarExp "x") (ConstExp (IntVal 1)))))]))]
    (AppExp (VarExp "f") (ConstExp (IntVal 5)))

top_exp_4 :: Exp
top_exp_4 =
    LetrecExp
        [(VarPat "make_adder",
            LambdaExp (VarPat "x")
                (LambdaExp (VarPat "y") (BinaryOpExp "+" (VarExp "x") (VarExp "y")))),
         (VarPat "adder",
            AppExp (VarExp "make_adder") (ConstExp (IntVal 5)))]
    (AppExp (VarExp "adder") (ConstExp (IntVal 42)))

main :: IO ()
main = let (IntVal x) = evalExp top_exp_4 Map.empty in print x