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

guagua070707 2023-08-08 14:42:25

作业信息

  • 课程信息：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

作业实现

 

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"))))
)))

 

...全文
275 回复 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
回复
切换为时间正序
请发表友善的回复…
发表回复
System Center Configuration Management Field Experience
整体而言，《System Center Configuration Manager Field Experience》是一本深入探讨SCCM实施和管理的实践性书籍，为IT专业人员提供了宝贵的理论知识和实操经验，对希望深入学习和掌握SCCM的读者而言，是一本值得...
生鲜配送平台源码java-rushi:问答平台
事件流等功能，同时通过一个异步消息框架来实现事件的异步处理，并使用爬虫对网站进行数据填充。 目录 项目的基本框架及配置 创建 git 仓库，本地配置 IDEA 并测试 pull 和 push。 创建 SpringBoot 工程，导入 web，...
javascript转换静态图片，增加粒子动画效果.docx
通过利用HTML5 Canvas API，开发者可以轻松实现对图像像素级别的操作，并在此基础上添加自定义的粒子动画。 #### 技术要点 1. **HTML5 Canvas API**: Canvas API 是一种在网页上绘制图形的方法，它提供了多种用于...
[Microsoft] Microsoft System Center Configuration Manager Field Experience (英文版)
[作者信息] Rushi Faldu , Manish Raval , Brandon Linton , Kaushal Pandey [出版机构] Microsoft Press [出版日期] 2013年11月15日 [图书页数] 92页 [图书语言] 英语 [图书格式] PDF 格式
wbdv-team-project-proprental
这个项目可能由Shubham Kumar、Prakash Kumar、Rushi Chaudhari和Neel Deshpande四位成员共同开发，旨在提供一个方便、高效的物业管理解决方案。 【描述】虽然描述信息较少，但从“物业出租”的主题可以推测，该...
raelidea

230

社区成员

35

社区内容

发帖
与我相关
我的任务
社区描述
日程：https://bbs.csdn.net/topics/608593392 主页：https://bobzhang.github.io/courses/ B站: “张宏波的基础软件课程”
rescript开发语言 个人社区 广东省·深圳市
社区管理员
  • raelidea
  • MoonBit月兔
  • 幻灰龙
加入社区
  • 近7日
  • 近30日
  • 至今

加载中

查看更多榜单
社区公告
暂无公告

试试用AI创作助手写篇文章吧

+ 用AI写文章