Skip to content

@tomlokhorst /ExprLang.hs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
{-# 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
Something went wrong with that request. Please try again.