# [基础软件理论与实践] 第五节作业实现 lxr2010

5 篇文章 0 订阅
##### 作业信息
• 课程信息：https://bbs.csdn.net/topics/608593392
##### 作业内容描述：
1. Complete the type inference ( two substitution functions )
2. Complete the implementation for let-polymorphism
3. Think about how to handle recursive functions
##### 作业实现

###### type_subst函数

type_subst函数的实现如下：

let type_subst = (t: typ, s: subst) : typ => {
let rec real_type = (t:typ, s: subst):typ => switch t {
| TInt | TBool => t
| TVar(x) => switch s->Belt.List.getAssoc(x,(a,b)=>a==b) {
| Some(tx) => real_type(tx, s)
| _ => t // might exist variable with no specific type
}
| TArr(t1, t2) => TArr(real_type(t1,s), real_type(t2,s))
}

let s_reduced = {
let mapDict = (d) => {
let (k, st) = d
(k, real_type(st, s))
}
s->Belt.List.map(mapDict)
}
let get_cached_real_type = (x: string): typ => switch s_reduced
->Belt.List.getAssoc(x, (a,b)=>a==b) {
| Some (tx) => tx
| _ => TVar(x)
}
let rec go = (t: typ): typ => switch t {
| TInt | TBool => t
| TVar(x) => get_cached_real_type(x)
| TArr(t1, t2) => TArr(go(t1),go(t2))
}
go(t)
}


###### 实现rest[t/x]

// replace all TVar(x) in type expression s with type t
let rec tvar_subst = (x: string, s: typ, t: typ) : typ => switch s {
| TInt | TBool => s
| TVar(a) if a == x => t
| TVar(_) => s
| TArr(t1, t2) => TArr(tvar_subst(x, t1, t), tvar_subst(x, t2, t))
}

let tvar_list_subst = (x: string, r:constraints, t:typ): constraints => {
let mapDict = (d) => {
let (t1, t2) = d
(tvar_subst(x, t1, t), tvar_subst(x, t2, t))
}
let sameKeyVal = (d) => {
let (t1, t2) = d
(t1 == t2)
}

// remove identical type bindings
r->Belt.List.map(mapDict)->Belt.List.keep((a) => !sameKeyVal(a))
}


###### free_vars_in_ctx函数

Let表达式Let(h,Fun(f,Let(g,f,g)),h(1))中，按照Let(g,_,_) -> Let(h,_,_)的顺序计算类型变量T_h

1. 处理Fun(f,_)，此时context中为{(f,T_f)}

2. 处理Let(g,f,_)，此时context中仍为{(f,T_f)},按照Let多态规则，g的类型T_g为：

1. 处理Let(g,_,g)，按照Let多态规则，T_g在被使用时会被实例化。设Let表达式中第2个g被实例化的类型为T_g_g，则有：

1. 处理Fun(f,Let(g,f,g))，此时函数的类型为：

1. 处理Let(h,Fun(f,Let(g,f,g)),_)，按照Let多态规则，h的类型T_h为：

1. 处理Let(h,_,h(1))，表达式h(1)使用了变量h，根据Let多态规则，T_h需要被实例化，设表达式h(1)h被实例化的类型为T_h_h(1)，则有：

1. 找到context中涉及的所有类型变量；
2. 从这些变量中去掉context中已经存在定义的类型变量，对于类型变量T，如果(*,TVar(Nolink(T)))不存在，则未定义。
3. 剩下的就是自由变量
###### inst函数

inst函数实现的思路也比较类似。处理类型T时，需要先找出所有的QVar表达式，去除重复项，再对这些QVar表达式每个生成对应的一个实例化类型，保存在map中。使用与任务1中type_subst类似的方法对类型T中的QVar表达式进行替换。

###### gen函数

module LetPoly = {
type rec typ = TInt | TBool| TVar(ref<tvar>) | TArr(typ, typ) | QVar(string)

type rec expr = CstI(int) | CstB(bool) | Var(string)
| If(expr, expr, expr)
| Fun(string, expr) | App(expr, expr)
| Let(string, expr, expr)

let rec toString = (t: typ) => switch t {
| TInt => "Int"
| TBool => "Bool"
| TVar(x) => switch x.contents {
}
| TArr(x,y) => "( " ++ toString(x) ++ " -> " ++ toString(y) ++ " )"
| QVar(s) => "QT_"++s
}

let tvar_cnt = ref(0)
let fresh_name = (): ref<tvar> => {
tvar_cnt.contents = tvar_cnt.contents + 1
}
let new_tvar = () : typ => TVar(fresh_name())

let inst_map = ref(list{})
let fresh_inst = (qs: string) : ref<tvar> => {
let inst_cnt = switch inst_map.contents->Belt.List.getAssoc(qs, (a,b)=>a==b) {
|Some (n) => n
|None => 0
}
inst_map.contents = Belt.List.setAssoc(inst_map.contents, qs, inst_cnt+1, (a,b)=>a==b)
}
let new_inst = (qs: string) :typ => TVar(fresh_inst(qs))

let inst = (tp: typ):typ  => {
let rec get_qvars = (t: typ) : list<string> => {
switch t {
| TInt | TBool => list{}
| TVar(x) => switch x.contents  {
}
| TArr(x, y) => Belt.List.concatMany([get_qvars(x), get_qvars(y)])
| QVar(qs) => list{qs}
}
}
let qvars = tp->get_qvars->Belt.List.toArray->Belt.Set.String.fromArray->Belt.Set.String.toList
let subst_map = qvars->Belt.List.map(qs=>(qs,new_inst(qs)))
let rec subst_inst = (t: typ, m:list<(string,typ)>) : typ => switch t {
| TInt | TBool => t
| TVar(x) => switch x.contents {
}
| TArr(x, y)=> TArr(subst_inst(x,m), subst_inst(y,m))
| QVar(qs) => switch m->Belt.List.getAssoc(qs, (a,b)=>a==b) {
| Some(r) => r
| _ => assert false
}
}
subst_inst(tp, subst_map)
}

// tell if TVar(x) is in type expression t
let rec occurs = (x: ref<tvar>,t: typ) : bool => switch t {
| TInt | TBool => false
| TVar(a) if a.contents == x.contents => true
| TVar(b) => switch b.contents {
| _ => false
}
| TArr(t1, t2) => occurs(x, t1) || occurs(x, t2)
| QVar(_) => false
}

let rec repr_type = (t:typ): typ => {
switch t {
| TVar(tvar: ref<tvar>) => switch tvar.contents {
let t1' = repr_type(t1)
t1'
}
}
| _ => t
}
}

let rec unify = (t1: typ, t2: typ) : unit => {
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)) => {
if occurs(tvar,t) {
Js.log("Can't solve these constraints")
assert false
}
}
| _ => {
Js.log("Wrong constraint : ("++ t1'->toString ++ "," ++ t2'->toString ++")" )
assert false
}
}
}
}

type context = list<(string, typ)>
type subst = list<(string, typ)>

let toStringSubst = (s: subst) => {
let mapDictToString = (d:(string, typ)) => {
let (x, t) = d
x ++ " |-> " ++ t->toString
}
switch s {
| list{} => ""
| list{h, ...rest} => List.fold_left((a,b)=>a++","++b->mapDictToString, h->mapDictToString, rest)
}
}

//context will change when finished a let expression,
// definitions inside the let expression will be removed from context.
// Therefore those type variables whose definition cann't be found
// in context are free type variables

let map_definition = (p : (string, typ)) => switch p {
| (_ , TVar(x)) => switch x.contents {
| _ => None
}
| _ => None
}

let free_tvars_in_ctx = (ctx : context): list<string> => {
let rec get_tvar_nolink_in_typ = (t: typ) : list<string> => switch t {
| TBool | TInt => list{}
| TVar(x) => switch x.contents {
}
| QVar(_) => assert false // Rank-1 polymorphism restriction
}

let getKey = (p: (string,typ)) => {
let (_ , k) = p
k
}

// deduplicate list using Belt.Set.String, prepare to make diff between tvar_definitions
Belt.List.toArray->Belt.Array.concatMany->
Belt.Set.String.fromArray

let tvar_definitions = ctx->Belt.List.keepMap(map_definition)->Belt.List.toArray->Belt.Set.String.fromArray
undefined_tvar
}

let gen = (ty: typ, ctx: context) : typ => {
let freetvars = free_tvars_in_ctx(ctx)
let rec go = (ty:typ , subst:subst): (typ,subst) => switch ty {
| TInt | TBool => (ty,subst)
| TVar(x) => switch x.contents {
| Nolink(xs) => switch subst->Belt.List.getAssoc(xs,(a,b)=>a==b) {
| Some(qt) => (qt,subst)
| None => {
// xs is not a free type var in context.
// find xs in context to check whether it is constrained.
switch ctx->Belt.List.keepMap(map_definition)->Belt.List.has(xs,(a,b)=>a==b) {
| true => (ty,subst) // constrained by context. don't change
| false => {
// unconstrained type variable. Generalize it and add to subst list.
(QVar(xs),list{(xs,QVar(xs)),...subst})
}
}
}
}
let (xt', subst') = go(xt, subst)
}
}
| TArr(x, y) => {
let (x', subst') = go(x, subst)
let (y', subst'') = go(y, subst')
(TArr(x',y'),subst'')
}
| QVar(_) => assert false // Rank-1 polymorphism restriction
}
let (fst,_) = go(ty, freetvars->Belt.List.map(x=>(x,QVar(x))))
fst
}

let rec check_expr = (ctx: context, expr: expr) : typ =>
switch expr {
| CstI(_) => TInt
| CstB(_) => TBool
| Var(s) =>  switch ctx->Belt.List.getAssoc(s,(a,b)=>a==b) {
| Some (ts) => inst(ts)
| _ => assert false // As for well-formed expr, no Var is used before declaration
}
| If(cond, bTrue, bFalse) => {
let tx = new_tvar()
let t1 = check_expr(ctx, cond)
let t2 = check_expr(ctx, bTrue)
let t3 = check_expr(ctx, bFalse)
unify(t1, TBool)
unify(t2,tx)
unify(t3,tx)
tx
}
| Fun(x, e) => {
let tx = new_tvar()
let te = check_expr(list{(x, tx), ...ctx}, e)
TArr(tx, te)
}
| App(e1, e2) => {
let tx = new_tvar()
let t1 = check_expr(ctx, e1)
let t2 = check_expr(ctx, e2)
unify(t1, TArr(t2,tx))
tx
}
let tx = new_tvar()
let t1 = check_expr(ctx, e1)
let t2 = check_expr(ctx, e2)
unify(tx,TInt)
unify(t1,TInt)
unify(t2,TInt)
tx
}
| Let(x, e1, e2) => {
let t1 = check_expr(ctx, e1)
let ctx' = list{(x, gen(t1, ctx)), ...ctx}
let t2 = check_expr(ctx', e2)
Js.log(ctx'->toStringSubst)
t2
}
}

let infer = (expr: expr) : typ => {
let t = check_expr(list{}, expr)
t
}

let test = Let("h",Fun("f",Let("g",Var("f"),Var("g"))),If(App(Var("h"),CstB(true)),App(Var("h"),CstI(1)),App(Var("h"),CstI(0))))
let inferred = infer(test)
Js.log(inferred->toString)

}


g |-> T_@*1,f |-> T_@*1
h |-> ( QT_@*1 -> QT_@*1 )
Int

###### 任务3

module LvLetPoly = {
type rec typ = TInt | TBool | TArr(typ, typ) | TVar(ref<tvar>) | QVar(string)

type rec expr = CstI(int) | CstB(bool) | Var(string)
| If(expr, expr, expr)
| Mul(expr, expr)
| Leq(expr, expr)
| Fun(string, expr) | App(expr, expr)
| Let(string, expr, expr)

let rec toStringE= (e: expr) => switch e {
| CstI(i) => Js.Int.toString(i)
| CstB(b) => if b {"True"} else {"False"}
| Var(s) => s
| If(c, e1, e2) => "If (" ++ c->toStringE ++ ") then { " ++ e1->toStringE ++ " } else { " ++ e2->toStringE ++ " }"
| Add(e1, e2) => "( " ++ e1->toStringE ++ "+" ++ e2->toStringE ++ " )"
| Mul(e1, e2) => "( " ++ e1->toStringE ++ "*" ++ e2->toStringE ++ " )"
| Leq(e1, e2) =>  e1->toStringE ++ "<=" ++ e2->toStringE
| Fun(x, e) => "fun " ++ x ++ " -> " ++ e->toStringE
| App(e1, e2) => "( " ++ e1->toStringE ++ " )( " ++ e2->toStringE ++ " )"
| Let(x, e1, e2) => "let " ++ x ++ " = " ++ e1->toStringE ++ " in " ++ e2->toStringE
}

let rec toString = (t: typ) => switch t {
| TInt => "Int"
| TBool => "Bool"
| TVar(x) => switch x.contents {
| Nolink(sx,lv) => "T" ++Js.Int.toString(lv) ++ "_"++sx
}
| TArr(x,y) => "( " ++ toString(x) ++ " -> " ++ toString(y) ++ " )"
| QVar(s) => "QT_"++s
}

let tvar_cnt = ref(0)
let fresh_name = (): string => {
tvar_cnt.contents = tvar_cnt.contents + 1
"@*"++Js.Int.toString(tvar_cnt.contents)
}
let new_tvar = (level:int) : typ => TVar(ref(Nolink(fresh_name(),level)))

let inst_map = ref(list{})
let fresh_inst = (qs: string) : string => {
let inst_cnt = switch inst_map.contents->Belt.List.getAssoc(qs, (a,b)=>a==b) {
|Some (n) => n
|None => 0
}
let _ = Belt.List.setAssoc(inst_map.contents, qs, inst_cnt+1, (a,b)=>a==b)
qs ++ "_" ++ Js.Int.toString(inst_cnt+1)
}
let new_inst = (qs: string, level:int) :typ => TVar(ref(Nolink(fresh_inst(qs),level)))

// tell if TVar(x) is in type expression t
let rec occurs = (x: ref<tvar>,t: typ) : bool => switch t {
| TInt | TBool => false
| TVar(a) if a.contents == x.contents => true
| TVar(b) => switch b.contents {
| _ => false
}
| TArr(t1, t2) => occurs(x, t1) || occurs(x, t2)
| QVar(_) => false
}

let rec repr_type = (t:typ): typ => {
switch t {
| TVar(tvar: ref<tvar>) => switch tvar.contents {
let t1' = repr_type(t1)
t1'
}
}
| _ => t
}
}

let get_level = (tvar: ref<tvar>) : option<int> => switch tvar.contents {
| _ => assert false
}

// make sure all tvars' level equal or smaller than level
let prune_level = (level: option<int>, ty: typ):() => {
let rec checker = (t: typ, lv: int) => switch t {
| TInt | TBool => ()
| TVar(x) => switch x.contents {
| Nolink(xs, l) if (l > lv) => {
}
| _ => ()
}
| TArr(x, y) => {
checker(x, lv)
checker(y, lv)
}
| QVar(_) => ()
}
switch level {
| Some(l) => checker(ty, l)
| _ => ()
}
}

let rec unify = (t1: typ, t2: typ) : unit => {
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)) => {
// tvar must be form Nolink(_,_)
if occurs(tvar,t) {
Js.log("Can't solve these constraints")
assert false
}
prune_level(get_level(tvar),t)
}
| _ => {
Js.log("Wrong constraint : ("++ t1'->toString ++ "," ++ t2'->toString ++")" )
assert false
}
}
}
}

type context = list<(string, typ)>
type subst = list<(string, typ)>

let toStringSubst = (s: subst) => {
let mapDictToString = (d:(string, typ)) => {
let (x, t) = d
x ++ " |-> " ++ t->toString
}
switch s {
| list{} => ""
| list{h, ...rest} => List.fold_left((a,b)=>a++","++b->mapDictToString, h->mapDictToString, rest)
}
}

let inst = (ty: typ, level: int) : typ => {
let rec get_qvars = (t: typ) : list<string> => {
switch t {
| TInt | TBool => list{}
| TVar(x) => switch x.contents  {
}
| TArr(x, y) => Belt.List.concatMany([get_qvars(x), get_qvars(y)])
| QVar(qs) => list{qs}
}
}
let qvars = ty->get_qvars->Belt.List.toArray->Belt.Set.String.fromArray->Belt.Set.String.toList
let subst_map = qvars->Belt.List.map(qs=>(qs,new_inst(qs,level)))
let rec subst_inst = (t: typ, m:list<(string,typ)>) : typ => switch t {
| TInt | TBool => t
| TVar(x) => switch x.contents {
}
| TArr(x, y)=> TArr(subst_inst(x,m), subst_inst(y,m))
| QVar(qs) => switch m->Belt.List.getAssoc(qs, (a,b)=>a==b) {
| Some(r) => r
| _ => assert false
}
}
subst_inst(ty, subst_map)
}

let gen = (ty: typ, level: int) : typ => {
let rec go = (t: typ) : typ => switch t {
| TInt | TBool => t
| TVar(x) => switch x.contents {
| Nolink (xs, xlv) if xlv > level => {
QVar(xs)
}
| Nolink (_, _) => t
let xt' = go(xt)
}
}
| TArr(x,y) => {
TArr(go(x),go(y))
}
| QVar(_) => assert false // Rank-1 polymorphism restriction
}

let fst = go(ty)
fst
}

let rec check_expr = (ctx: context, expr: expr, level: int) : typ => {
let res = switch expr {
| CstI(_) => TInt
| CstB(_) => TBool
| Var(s) =>  switch ctx->Belt.List.getAssoc(s,(a,b)=>a==b) {
| Some (ts) => inst(ts, level)
| _ => assert false // As for well-formed expr, no Var is used before declaration
}
| If(cond, bTrue, bFalse) => {
let tx = new_tvar(level)
let t1 = check_expr(ctx, cond, level)
let t2 = check_expr(ctx, bTrue, level)
let t3 = check_expr(ctx, bFalse, level)
unify(t1, TBool)
unify(t2,tx)
unify(t3,tx)
tx
}
| Fun(x, e) => {
let tx = new_tvar(level)
let te = check_expr(list{(x, tx), ...ctx}, e, level+1)
TArr(tx, te)
}
| App(e1, e2) => {
let tx = new_tvar(level)
let t1 = check_expr(ctx, e1, level)
let t2 = check_expr(ctx, e2, level)
unify(t1, TArr(t2,tx))
tx
}
| Add(e1, e2) | Mul(e1, e2) => {
let tx = new_tvar(level)
let t1 = check_expr(ctx, e1, level)
let t2 = check_expr(ctx, e2, level)
unify(tx,TInt)
unify(t1,TInt)
unify(t2,TInt)
tx
}
| Leq(e1,e2) => {
let tx = new_tvar(level)
let t1 = check_expr(ctx, e1, level)
let t2 = check_expr(ctx, e2, level)
unify(tx, TBool)
unify(t1, TInt)
unify(t2, TInt)
tx
}
| Let(x, e1, e2) => {
let tx = new_tvar(level+1)
let t1 = check_expr(list{(x,tx),...ctx}, e1, level+1)
let ctx' = list{(x, gen(t1, level)), ...ctx}
let t2 = check_expr(ctx', e2, level)
unify(tx, t1)
Js.log(ctx'->toStringSubst)
t2
}
}
res
}

let infer = (expr: expr) : typ => {
let t = check_expr(list{}, expr, 0)
t
}

}

module Test = {
open! LvLetPoly
let test0 = Let("h",Fun("f",Let("g",Var("f"),Var("g"))),If(App(Var("h"),CstB(true)),App(Var("h"),CstI(1)),App(Var("h"),CstI(0))))
let fact = Let("fac",
Fun("n",If(Leq(Var("n"),CstI(0)),
CstI(1),
App(Var("fac"),CstI(5)))
let more_fact = Let("facc",
Fun("m",Fun("n",If(Leq(Var("n"),CstI(0)),
Var("m"),
Var("facc"))

let tests = list{
test0, fact, more_fact
}

let run_test = (ts: list<expr>) :  () => {
ts->Belt.List.forEach(t=>{
Js.log("Expr: " ++ t->toStringE)
let inferred = infer(t)
Js.log(inferred->toString)
})
}

let run = () => {
let _ = run_test(tests)
}
}

Test.run()


Expr: let h = fun f -> let g = f in g in If (( h )( True )) then { ( h )( 1 ) } else { ( h )( 0 ) }
g |-> T1_@*2,f |-> T1_@*2,h |-> T1_@*1
h |-> ( QT_@*2 -> QT_@*2 )
Int
Expr: let fac = fun n -> If (n<=0) then { 1 } else { ( n*( fac )( ( n+-1 ) ) ) } in ( fac )( 5 )
fac |-> ( Int -> Int )
Int
Expr: let facc = fun m -> fun n -> If (n<=0) then { m } else { ( ( facc )( m ) )( ( n+-1 ) ) } in facc
facc |-> ( QT_@*19 -> ( Int -> QT_@*19 ) )
( T0_@*19_1 -> ( Int -> T0_@*19_1 ) )


• 0
点赞
• 1
收藏
觉得还不错? 一键收藏
• 打赏
• 0
评论
06-04
11-03 89
10-25 177
03-26 3395
10-14 1532
08-24
10-27 457

### “相关推荐”对你有帮助么？

• 非常没帮助
• 没帮助
• 一般
• 有帮助
• 非常有帮助

lxr2010

¥1 ¥2 ¥4 ¥6 ¥10 ¥20

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。