Created
August 19, 2010 17:19
-
-
Save tomlokhorst/538409 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment