public
Last active

  • Download Gist
ExprLang.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198
{-# 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))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.