231
社区成员




1. uniquify
type prim = Add | Mul | Self
type rec expr =
| Cst(int)
| Var(string)
| Let(string, expr, expr)
| Prim(prim, list<expr>)
type ident = {name: string, stamp: int}
module Resolve = {
type rec expr =
| Cst(int)
| Var(ident)
| Let(ident, expr, expr)
| Prim(prim, list<expr>)
}
let i_ident = ref(0)
let fresh = (x: string): ident => {
let a = {name: x, stamp: i_ident.contents}
i_ident := i_ident.contents + 1
a
}
Js.log(fresh("x"))
Js.log(fresh("x"))
// let fresh = (x: string)=> {
// let i_ident = ref(0)
// // 返回一个函数,该函数携带一个闭包,该闭包记录状态
// () => {
// let a = {name: x, stamp: i_ident.contents}
// i_ident := i_ident.contents + 1
// a
// }
// }
// let freshX = fresh("x");
// Js.log(freshX())
// Js.log(freshX())
let resolve = expr => {
let rec go = (env: list<(string, ident)>, expr: expr): Resolve.expr =>
switch expr {
| Cst(i) => Cst(i)
| Var(x) => Var(List.assoc(x, env))
| Let(x, e1, e2) => {
let fresh_x = fresh(x)
// 利用函数式数据结构不变的特性
Let(fresh_x, go(env, e1), go(list{(x, fresh_x), ...env}, e2))
}
| Prim(op, es) => Prim(op, List.map(go(env), es))
}
go(list{}, expr)
}
2.
type rec typ =
| TInt
| TBool
| TVar(string) // 在原来的基础上添加了一个var,类型变量
| TArr(typ, typ) // arrow
type prim = Add | Mul
// 带类型的表达式
type rec expr =
| CstI(int)
| CstB(bool)
| Var(string)
| If(expr, expr, expr)
| Fun(string, expr)
| App(expr, expr)
| Prim(prim, expr, expr) //CstI, CstI)
// 实现思路
// 1. 遍历表达式,插入类型变量并收集约束
// 2. 求解约束
// 3. 替换求解的结果
type constraints = list<(typ, typ)>
type context = list<(string, typ)>
let i_ident = ref(0)
let new_tvar = () => {
let prefix = "TVAR"
let tvar = prefix ++ Belt.Int.toString(i_ident.contents)
i_ident := i_ident.contents + 1
TVar(tvar)
}
// Js.log(new_tvar())
// Js.log(new_tvar())
let rec check_expr = (ctx: context, expr: expr): (typ, constraints) => {
switch expr {
// 值为类型,而不是eval的value
| CstI(_) => (TInt, list{})
| CstB(_) => (TBool, list{})
// 找到x的类型
| Var(x) => (List.assoc(x, ctx), list{})
| Fun(x, e) => {
// 将x的类型设置为tx
let tx = new_tvar() // TVar(fresh_name)
// 求出body体的类型
let (te, c) = check_expr(list{(x, tx), ...ctx}, e)
(TArr(tx, te), c)
}
| App(e1, e2) => {
let t = new_tvar() // TVar(fresh_name)
let (t1, c1) = check_expr(ctx, e1)
let (t2, c2) = check_expr(ctx, e2)
let c = list{(t1, TArr(t2, t))}
(t, List.concat(list{c1, c2, c}))
}
| If(e1, e2, e3) => {
let t = new_tvar() // TVar(fresh_name)
let (t1, c1) = check_expr(ctx, e1)
let (t2, c2) = check_expr(ctx, e2)
let (t3, c3) = check_expr(ctx, e3)
let c = list{(t1, TBool), (t, t2), (t, t3)}
(t, List.concat(list{c1, c2, c3, c}))
}
| Prim(_, e1, e2) => {
let (t1, c1) = check_expr(ctx, e1)
let (t2, c2) = check_expr(ctx, e2)
let c = list{(t1, TInt), (t2, TInt)}
//(t, c)
(TInt, List.concat(list{c1, c2, c}))
}
}
}
// test
Js.log(
check_expr(list{},
Fun("f", Fun("a", Fun("b", If(Var("a"), Prim(Add, App(Var("f"), Var("b")), CstI(1)), App(Var("f"), Var("a"))))))
))
type subst = list<(string, typ)>
// 生成替换规则
let solve = (cs: constraints): subst => {
let rec replaceConstraints = (cs: constraints, (t: typ, x: string)) => {
let rec replace = (t: typ, x: string) => {
switch t {
| TInt | TBool => t
| TVar(s) => {
if s == x {
TVar(x)
} else {
t
}
}
| TArr(a, b) => TArr(replace(a, x), replace(b, x))
}
}
switch cs {
| list{} => list{}
| list{(a, b), ...rest} => List.cons((replace(a, x), replace(b, x)), replaceConstraints(rest, (t, x)))
}
}
let rec occurs = (tvar: string, t: typ) : bool => {
switch t {
| TInt | TBool => false
| TVar(x) => tvar == x
| TArr(x, y) => occurs(tvar, x) && occurs(tvar, y)
}
}
let rec go = (cs, s): subst => {
switch cs {
| list{} => s
| list{c, ...rest} =>
switch c {
// 想想为什么只有这几个分支
| (TInt, TInt) | (TBool, TBool) => go(rest, s)
| (TArr(t1, t2), TArr(t3, t4)) => go(list{(t1, t3), (t2, t4), ...rest}, s)
| (TVar(x), t) | (t, TVar(x)) =>
assert !occurs(x, t) // error report
// 将x=t加入到替换规则里面
//go(rest[t / x], list{(x, t), ...s}) // pseudocode!
go(replaceConstraints(rest, (t, x)), list{(x, t), ...s}) // pseudocode!
| _ => assert false // error report
}
}
}
go(cs, list{})
}
let rec type_subst = (t: typ, s: subst): typ => {
let rec replace = (t: typ, (s: string, t1: typ)) => {
switch t {
| TInt | TBool => t
| TVar(x) => {
if x == s {
t1
} else {
t
}
}
| TArr(a, b) => {
TArr(replace(a, (s, t1)), replace(b, (s, t1)))
}
}
}
switch s {
| list{} => t
| list{(h, th), ...rest} => {
type_subst(replace(t, (h, th)), rest)
}
}
}
let infer = (expr: expr) : typ => {
let (t, cs) = check_expr(list{}, expr)
let s = solve(cs)
let res = type_subst(t, s)
res
}
3. unify
// 得到约束
// 从约束构建union find
// 总是使用函数、int、bool作为代表元
type rec typ =
| TInt
| TBool
| TArr(typ, typ)
| TVar(ref<tvar>)
and tvar = Nolink(string) | Linkto(typ)
let rec toString = (typ: typ) => {
switch typ {
| TInt => "TInt"
| TBool => "TBool"
| TArr(a, b) => "(" ++ toString(a) ++ " -> " ++ toString(b) ++ ")"
| TVar(x) => toStringTvar(x.contents)
}
}
and toStringTvar = (tvar: tvar) => {
switch tvar {
// | Nolink(s) => " nolink(" ++ s ++ ") "
// | Linkto(t) => " linkto(" ++ toString(t) ++ ") "
| Nolink(s) => s
| Linkto(t) => toString(t)
}
}
type prim = Add | Mul
// 带类型的表达式
type rec expr =
| CstI(int)
| CstB(bool)
| Var(string)
| If(expr, expr, expr)
| Fun(string, expr)
| App(expr, expr)
| Prim(prim, expr, expr) //CstI, CstI)
// 思路:
// 求表达式的类型,并将各个子表达式的类型以及整个表达式的类型,直接生成unify set
// 中间会生成一堆类型(子表达式的类型),然后将这些类型连线,最终返回整个表达式的类型
// 跟type-infer的区别
let rec unify = (t1: typ, t2: typ): unit => {
let rec occurs = (tvar: tvar, t: typ) : bool => {
switch t {
| TInt | TBool => false
// === 还是 == ??
| TVar(x) => tvar === x.contents
| TArr(x, y) => occurs(tvar, x) && occurs(tvar, y)
}
}
let t1' = repr_type(t1) and t2' = repr_type(t2)
if t1' === t2' {
()
} else {
switch (t1', t2') {
| (TInt, TInt) | (TBool, TBool) => ()
| (TArr(t1, t2), TArr(t3, t4)) => {
unify(t1, t3)
unify(t2, t4)
}
| (TVar(tvar), t) | (t, TVar(tvar)) => {
assert !(occurs(tvar.contents, t)) // error report
tvar := Linkto(t)
}
| _ => assert false // error report
}
}
}
and repr_type = (t: typ): typ => {
switch t {
| TVar(tvar: ref<tvar>) =>
switch tvar.contents {
| Nolink(_) => t
| Linkto(t1) => {
let t1' = repr_type(t1)
tvar := Linkto(t1') // Side effect: path compression!
t1'
}
}
| _ => t
}
}
let i_ident = ref(0)
let fresh_name = () => {
let prefix = "TVAR"
let tvar = prefix ++ Belt.Int.toString(i_ident.contents)
i_ident := i_ident.contents + 1
tvar
}
let new_tvar = () => TVar(ref(Nolink(fresh_name())))
type context = list<(string, typ)>
// 返回值是什么? 返回expr的类型,跟思路里面的求表达式的类型一致
// 求解表达式类型的过程中,将表达式中的各个类型进行连线
let rec check_expr = (ctx: context, expr: expr): typ => {
switch expr {
| CstI(_) => TInt
| CstB(_) => TBool
| Var(x) => //new_tvar()
{
List.assoc(x, ctx)
}
| Fun(p, b) => {
// 类型为:TArr
// 需要先求出p和b的类型
let pt = new_tvar()
let bt = check_expr(list{(p, pt), ...ctx}, b)
TArr(pt, bt)
}
| App(e1, e2) => {
// TVar(Nolink(fresh_name))
let t = new_tvar()
let t1 = check_expr(ctx, e1)
let t2 = check_expr(ctx, e2)
// unify the two types
unify(t1, TArr(t2, t))
t
}
| If(cond, e1, e2) => {
let condt = check_expr(ctx, cond)
let e1t = check_expr(ctx, e1)
let e2t = check_expr(ctx, e2)
unify(condt, TBool)
unify(e1t, e2t)
let t = new_tvar()
unify(t, e1t)
t
}
| Prim(_, e1, e2) => {
let e1t = check_expr(ctx, e1)
let e2t = check_expr(ctx, e2)
unify(e1t, TInt)
unify(e2t, TInt)
TInt
}
}
}
Js.log(
toString(
check_expr(list{},
Fun("f", Fun("a", Fun("b", If(Var("a"), Prim(Add, App(Var("f"), Var("b")), CstI(1)), App(Var("f"), Var("a"))))))
)))
let poly
type rec typ = TInt | TBool | TArr(typ, typ) | TVar(ref<tvar>)
| QVar(string) // quantified type variable (list<string>, typ)//tvar)
and tvar = Nolink(string) | Linkto(typ)
// forall X. X -> X
// TArr(QVar(X), QVar(X))
let rec toString = (typ: typ) => {
switch typ {
| TInt => "TInt"
| TBool => "TBool"
| TArr(a, b) => "(" ++ toString(a) ++ " -> " ++ toString(b) ++ ")"
| TVar(x) => toStringTvar(x.contents)
| QVar(x) => "forall " ++ x
}
}
and toStringTvar = (tvar: tvar) => {
switch tvar {
// | Nolink(s) => " nolink(" ++ s ++ ") "
// | Linkto(t) => " linkto(" ++ toString(t) ++ ") "
| Nolink(s) => s
| Linkto(t) => toString(t)
}
}
type prim = Add | Mul
// 带类型的表达式
type rec expr =
| CstI(int)
| CstB(bool)
| Var(string)
| If(expr, expr, expr)
| Fun(string, expr)
| App(expr, expr)
| Prim(prim, expr, expr) //CstI, CstI)
| Let(string, expr, expr)
// 思路:
// 在类型环境下,求解表达式的类型
// match表达式,根据不同的情况进行处理
//
type ctx = list<(string, typ)>
let lookup = (x: string, ctx: ctx) => {
List.assoc(x, ctx)
}
let i_ident = ref(0)
let fresh_name = () => {
let prefix = "TVAR"
let tvar = prefix ++ Belt.Int.toString(i_ident.contents)
i_ident := i_ident.contents + 1
tvar
}
let new_tvar = () => TVar(ref(Nolink(fresh_name())))
let rec unify = (t1: typ, t2: typ): unit => {
let rec occurs = (tvar: tvar, t: typ) : bool => {
switch t {
| TInt | TBool => false
// === 还是 == ??
| TVar(x) => tvar === x.contents
| TArr(x, y) => occurs(tvar, x) || occurs(tvar, y)
| QVar(_) => false
}
}
let t1' = repr_type(t1) and t2' = repr_type(t2)
if t1' === t2' {
()
} else {
switch (t1', t2') {
| (TInt, TInt) | (TBool, TBool) => ()
| (TArr(t1, t2), TArr(t3, t4)) => {
unify(t1, t3)
unify(t2, t4)
}
| (TVar(tvar), t) | (t, TVar(tvar)) => {
assert !(occurs(tvar.contents, t)) // error report
tvar := Linkto(t)
}
| _ => {
Js.log(toString(t1'))
Js.log(toString(t2'))
assert false // error report
}
}
}
}
and repr_type = (t: typ): typ => {
switch t {
| TInt | TBool | QVar(_) => t
| TArr(t1, t2) => TArr(repr_type(t1), repr_type(t2))
| TVar(tvar: ref<tvar>) =>
switch tvar.contents {
| Nolink(_) => t
| Linkto(t1) => {
let t1' = repr_type(t1)
tvar := Linkto(t1') // Side effect: path compression!
t1'
}
}
}
}
// let f = x => x in
// f => f(1) + 2
let inst = (ty: typ): typ => {
let l = ref(list{})
let rec goInst = (ty: typ) => {
switch ty {
| TInt | TBool => ty
| TArr(ta, tb) => TArr(goInst(ta), goInst(tb))
// l 会不会link到一个QVar?不会,因为已经限定了是一阶了
| TVar(_) => ty
// switch l.contents {
// | Nolink(s) => ty
// | Linkto(rty) => inst(rty)
// }
| QVar(s) => {
switch List.assoc_opt(s, l.contents) {
| Some(t) => t
| None => {
let tvar' = new_tvar()
l := list{(s, tvar'), ...l.contents}
tvar'
}
}
}
}
}
goInst(ty)
}
//for example, if T_1 = X -> X , we get the type scheme forall X. X -> X
let rec free_vars_in_ctx = (ctx): list<string> => {
let rec free_var = (typ: typ) => {
switch typ {
| TInt | TBool => list{}
| TArr(t1, t2) => {
List.concat(list{free_var(t1), free_var(t2)})
}
| TVar(refer) => free_var_link(refer.contents)
| QVar(_) => list{}
}
}
and free_var_link = (tvar: tvar) => {
switch tvar {
| Nolink(s) => list{s}
| Linkto(t) => free_var(t)
}
}
// 找出类型中的自由变量
switch ctx {
| list{} => list{}
| list{(_, xt), ...rest} => {
switch xt {
| TInt | TBool => free_vars_in_ctx(rest)
| TArr(t1, t2) => List.concat(list{free_var(t1), free_var(t2), free_vars_in_ctx(rest)})
| TVar(refer) => List.concat(list{free_var_link(refer.contents), free_vars_in_ctx(rest)})
| QVar(_) => free_vars_in_ctx(rest)
}
}
}
}
let fst = ((a, _)) => a
type subst = list<string>
let gen = (ty: typ, ctx: ctx): typ => {
let free_vars = free_vars_in_ctx(ctx)
let rec go = (ty: typ, subst): (typ, subst) => {
switch ty {
| TInt | TBool => (ty, subst)
| TArr(t1, t2) => (TArr(fst(go(t1, subst)), fst(go(t2, subst))), subst)
| TVar(x) => {
switch x.contents {
| Nolink(s) => switch free_vars -> Belt.List.has(s, (a, b) => a == b) {
//not to generalize type variables in T_1 that are also mentioned in the typing environment
| true => (ty, subst) // QVar(i)
| false => (QVar(s), list{s, ...subst})
}
| Linkto(refer) => go(refer, subst)
}
}
| QVar(_) => (ty, subst)
}
}
fst(go(ty, list{}))
}
let rec check_expr = (ctx: ctx, expr: expr): typ => {
switch expr {
| CstI(_) => TInt
| CstB(_) => TBool
// 变量会在什么地方碰到?在body体中,即在app中,所以需要知道变量的类型,并且此时需要实例化
// Each time we encounter an occurence of x in t_2 , the type scheme is instantiated
| Var(x) => {
//inst(lookup(x, ctx))
let xt = lookup(x, ctx)
Js.log("xt is " ++ toString(xt))
inst(xt)
}
| Fun(p, b) => {
// 类型为:TArr
// 需要先求出p和b的类型
let pt = new_tvar()
let bt = check_expr(list{(p, pt), ...ctx}, b)
TArr(pt, bt)
}
| App(e1, e2) => {
// TVar(Nolink(fresh_name))
let t = new_tvar()
//Js.log(e1)
let t1 = check_expr(ctx, e1)
Js.log("t1 is " ++ toString(t1))
let t2 = check_expr(ctx, e2)
Js.log("t2 is " ++ toString(t2))
// unify the two types
unify(t1, TArr(t2, t))
t
}
| If(cond, e1, e2) => {
let condt = check_expr(ctx, cond)
let e1t = check_expr(ctx, e1)
let e2t = check_expr(ctx, e2)
unify(condt, TBool)
unify(e1t, e2t)
let t = new_tvar()
unify(t, e1t)
t
}
| Prim(_, e1, e2) => {
let e1t = check_expr(ctx, e1)
let e2t = check_expr(ctx, e2)
unify(e1t, TInt)
unify(e2t, TInt)
TInt
}
| Let(x, e1, e2) => {
Js.log("======== " ++ x)
let ty1 = check_expr(ctx, e1)
// x与对应的类型,放入环境Γ中
// ty1假设为TArr(TVar(ref(NoLink(s123))), TVar(ref(NoLink(s123)))),ctx中包含(fun的参数名, TVar(ref(NoLink(s123))))
//let ctx' = list{(x, gen(ty1, ctx)), ...ctx}
let gen' = gen(ty1, ctx)
//Js.log("======== " ++ toString(gen'))
let ctx' = list{(x, gen'), ...ctx}
// 在新的环境中,求解e2的类型
let ty2 = check_expr(ctx', e2)
ty2
}
}
}
Js.log(
toString(
check_expr(list{},
Let("id", Fun("x", Var("x")),
Let("a", App(Var("id"), CstI(42)),
Let("b", App(Var("id"), CstB(true)), CstB(true))))
)))
Js.log(
toString(
check_expr(list{},
Let("id", Fun("x", Var("x")),
Let("a", App(Var("id"), CstI(42)),
Let("b", App(Var("id"), CstB(true)), Var("id"))))
)))