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

採石 2023-02-07 21:24:58

作业信息

课程信息：https://bbs.csdn.net/topics/608593392

作业内容描述：

Complete the type inference ( two substitution functions )
Complete the implementation for let-polymorphism
Think about how to handle recursive functions

作业实现

作業二、三：

先設置類型系統類

type rec typ = TInt | TBool | TVar(ref<tvar>) | TArr(typ, typ) | Gen(array<string>, typ)
and tvar = NoLink(string, int) | LinkTo(typ)

跟Generation相關的類型爲Gen(array<string>, typ)，舉例來說，Gen(list{x}, TArr(Var(x), Var(x))，表示forall x. x=>x

下面先上check_expr的主體代碼

1、2的分支，直接返回類型TInt和TBool，無需unify

4的if分支，返回的是fresh出來的t，並分別對(t1, TBool)、(t, t2)、(t, t3)進行unify

5的func分支，fresh出來的tx，返回的是tx->tb，無需unify

6的apply分支，返回的是fresh出來的t，並對(t1, t2->t)進行unify

重點是3分支，遇到generation類型時需實例化類型。以及，8分支，加入遞歸和generation相關邏輯。

先上一些代碼吧，後續，我跟課堂所講的gen算法差異還是比較大的

注意1、2處，我私以爲，function和let語義，同樣是有層級的。

func x => // level n
  let y = // level n + 1
    x     // level n + 2
  y       // level n + 1

如第一行中的x是第n層fresh出來的t，類型未知。第三行中的x是let解構體的自由變量，同時又是func整體中的受控變量。let-poly中的gen的注意點，在于x變量，可能被函式體內層的其他變量類型確定，成爲更確定的類型，如U(x, TInt), U(x, TInt->y)；或x變量，不受內層變量類型影響。下面通過unify函式的邏輯來說明吧。

unify

每次fresh的變量類型，都會帶有當前所在層級的level。故當標誌1那行時，若兩個fresh變量都是未知的，則都用外層的fresh變量替換掉內層的fresh變量。其他情況則在標誌2那行由深層更詳細的類型特徵取代未確定的fresh變量。一般來說，智能識別類型，總是從深層函數推導至外層。

gen

gen(t, level)，注意點，在于識別出肯定未被確定的fresh變量，即let所在層級爲n，那麼level大于等於n的fresh變量肯定都是未確定的，而小于n的fresh變量（相對於本層級是自由變量）不一定未確定。

inst

類型實例化則比較直接，直接對需要forall的類型參數，依次進行實例化即可

遞歸

直接略過，我採用了簡單粗暴的實現。

測試輸出

input|- [f] => [a] => [b] => if a { f(b) + 1 } else { f(a) }
nogen|- (Bool -> Int) -> Bool -> Bool -> Int

input|- [x] => { let y = x { y } }
nogen|- Var(T/0)
__gen|- forall: T/0. Var(T/0) -> Var(T/0)

input|- [x] => { let y = { [z] => x } { y } }
__gen|- forall: T/2. Var(T/2) -> Var(T/0)
__gen|- forall: T/0, T/3. Var(T/0) -> Var(T/3) -> Var(T/0)

input|- let id = { [x] => x } { let a = id(42) { let b = id(true) { if b { a } else { 11 } } } }
__gen|- forall: T/1. Var(T/1) -> Var(T/1)
nogen|- Int
nogen|- Bool
nogen|- Int

input|- [f] => { let g = f { g(42) } }
nogen|- Var(T/0)
__gen|- forall: T/2. (Int -> Var(T/2)) -> Var(T/2)

input|- let fact = { [n] => if n == 0 { 1 } else { n × fact(n - 1) } } { fact(5) }
nogen|- Int -> Int
nogen|- Int

完整程式碼

mono，constraints

open Belt

let forceGet = Option.getExn
let roundString = str => "(" ++ str ++ ")"

let assoc = (env, x) => env->List.getAssoc(x, (a, b) => a == b)

type rec typ = TInt | TBool | TVar(string) | TArr(typ, typ)

let typ_to_string = typ => {
  let eagerBracket = (x, test) =>
    if test {
      x->roundString
    } else {
      x
    }

  let rec go = (typ, test) =>
    switch typ {
    | TInt => "Int"
    | TBool => "Bool"
    | TVar(x) => "Var" ++ x->roundString
    | TArr(t1, t2) => (go(t1, true) ++ " -> " ++ go(t2, false))->eagerBracket(test)
    }

  go(typ, false)
}

type prim = Add

type rec expr =
  | CstI(int)
  | Var(string)
  | If(expr, expr, expr)
  | Func(string, expr)
  | Apply(expr, expr)
  | Prim(prim, expr, expr)

type constraints = list<(typ, typ)>
type substs = list<(string, typ)>

let infer = expr => {
  let count = ref(0)
  let var_fresher = () => {
    let cur = count.contents
    let var = "T/" ++ cur->Int.toString
    count := cur + 1
    TVar(var)
  }

  let rec check_expr = (context, expr) =>
    switch expr {
    | CstI(_) => (TInt, list{})
    | Var(x) => (context->assoc(x)->forceGet, list{})
    | If(test, so_body, else_body) => {
        let t = var_fresher()
        let (t1, c1) = check_expr(context, test)
        let (t2, c2) = check_expr(context, so_body)
        let (t3, c3) = check_expr(context, else_body)
        (t, List.concatMany([c1, c2, c3, list{(t1, TBool), (t, t2), (t, t3)}]))
      }

    | Func(x, body) => {
        let tx = var_fresher()
        let (tb, cb) = check_expr(list{(x, tx), ...context}, body)
        (TArr(tx, tb), cb)
      }

    | Apply(e1, e2) => {
        let t = var_fresher()
        let (t1, c1) = check_expr(context, e1)
        let (t2, c2) = check_expr(context, e2)
        (t, List.concatMany([c1, c2, list{(t1, TArr(t2, t))}]))
      }

    | Prim(_, e1, e2) => {
        let (t1, c1) = check_expr(context, e1)
        let (t2, c2) = check_expr(context, e2)
        (TInt, List.concatMany([c1, c2, list{(t1, TInt), (t2, TInt)}]))
      }
    }

  let rec type_subst = (typ, subst) => {
    let (x, t) = subst
    switch typ {
    | TVar(y) =>
      if x == y {
        t
      } else {
        typ
      }
    | TArr(t1, t2) => TArr(type_subst(t1, subst), type_subst(t2, subst))
    | _ => typ
    }
  }

  let rec type_substs = (typ, substs) => {
    let rec has_var = typ =>
      switch typ {
      | TVar(_) => true
      | TArr(t1, t2) => has_var(t1) || has_var(t2)
      | _ => false
      }

    let rec go = (typ, substs) =>
      switch substs {
      | list{} => typ
      | list{subst, ...rest} => go(type_subst(typ, subst), rest)
      }

    let t = go(typ, substs)
    if has_var(t) {
      type_substs(t, substs)
    } else {
      t
    }
  }

  let solve = constraints => {
    let rec go = (constraints, s) => {
      let rec occurs = (x, t) =>
        switch t {
        | TVar(y) => x == y
        | TArr(t1, t2) => occurs(x, t1) || occurs(x, t2)
        | _ => false
        }

      switch constraints {
      | list{} => s
      | list{co, ...rest} =>
        switch co {
        | (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)
            let subst = (x, t)
            go(
              rest->List.map(e => {
                let (t1, t2) = e
                (type_subst(t1, subst), type_subst(t2, subst))
              }),
              list{subst, ...s},
            )
          }

        | _ => assert false
        }
      }
    }

    go(constraints, list{})
  }

  let (t, constraints) = check_expr(list{}, expr)
  let substs = solve(constraints)
  type_substs(t, substs)
}

let case = Func(
  "f",
  Func(
    "a",
    Func(
      "b",
      If(Var("a"), Prim(Add, Apply(Var("f"), Var("b")), CstI(1)), Apply(Var("f"), Var("a"))),
    ),
  ),
)

Js.log(case->infer->typ_to_string)

mono，unify

open Belt

let forceGet = Option.getExn
let roundString = str => "(" ++ str ++ ")"
let assoc = (env, x) => env->List.getAssoc(x, (a, b) => a == b)

type rec typ = TInt | TBool | TVar(ref<tvar>) | TArr(typ, typ)
and tvar = NoLink(string) | LinkTo(typ)

let typ_to_string = typ => {
  let eagerBracket = (x, test) =>
    if test {
      x->roundString
    } else {
      x
    }

  let rec go = (typ, test) =>
    switch typ {
    | TInt => "Int"
    | TBool => "Bool"
    | TVar({contents: tvar}) =>
      "Var" ++
      switch tvar {
      | NoLink(x) => roundString(x)
      | LinkTo(_) => assert false
      }
    | TArr(t1, t2) => (go(t1, true) ++ " -> " ++ go(t2, false))->eagerBracket(test)
    }

  go(typ, false)
}

type prim = Add

type rec expr =
  | CstI(int)
  | Var(string)
  | If(expr, expr, expr)
  | Func(string, expr)
  | Apply(expr, expr)
  | Prim(prim, expr, expr)

let infer = expr => {
  let count = ref(0)
  let var_fresher = () => {
    let cur = count.contents
    let var = "T/" ++ cur->Int.toString
    count := cur + 1
    TVar(ref(NoLink(var)))
  }

  let rec repr_type = t =>
    switch t {
    | TVar(tvar) =>
      switch tvar.contents {
      | NoLink(_) => t
      | LinkTo(t) => {
          let t = t->repr_type
          tvar := LinkTo(t)
          t
        }
      }

    | _ => t
    }

  let rec deep_repr_type = t =>
    switch t {
    | TVar(tvar) =>
      switch tvar.contents {
      | NoLink(_) => t
      | LinkTo(t) => {
          let t = t->deep_repr_type
          tvar := LinkTo(t)
          t
        }
      }
    | TArr(t1, t2) => TArr(t1->deep_repr_type, t2->deep_repr_type)

    | _ => t
    }

  let rec unify = (t1, t2) => {
    let rec occurs = (x, t) =>
      switch t {
      | TVar({contents: y}) => x == y
      | TArr(t1, t2) => occurs(x, t1) || occurs(x, t2)
      | _ => false
      }

    let t1 = t1->repr_type
    let t2 = t2->repr_type
    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)
          tvar := LinkTo(t)
        }

      | _ => assert false
      }
    }
  }

  let rec check_expr = (context, expr) =>
    switch expr {
    | CstI(_) => TInt
    | Var(x) => context->assoc(x)->forceGet
    | If(test, so_body, else_body) => {
        let t = var_fresher()
        let t1 = check_expr(context, test)
        let t2 = check_expr(context, so_body)
        let t3 = check_expr(context, else_body)
        unify(t1, TBool)
        unify(t, t2)
        unify(t, t3)
        t
      }

    | Func(x, body) => {
        let tx = var_fresher()
        let tb = check_expr(list{(x, tx), ...context}, body)
        TArr(tx, tb)
      }

    | Apply(e1, e2) => {
        let t = var_fresher()
        let t1 = check_expr(context, e1)
        let t2 = check_expr(context, e2)
        unify(t1, TArr(t2, t))
        t
      }

    | Prim(_, e1, e2) => {
        let t1 = check_expr(context, e1)
        let t2 = check_expr(context, e2)
        unify(t1, TInt)
        unify(t2, TInt)
        TInt
      }
    }

  check_expr(list{}, expr)->deep_repr_type
}

let case = Func(
  "f",
  Func(
    "a",
    Func(
      "b",
      If(Var("a"), Prim(Add, Apply(Var("f"), Var("b")), CstI(1)), Apply(Var("f"), Var("a"))),
    ),
  ),
)

Js.log(case->infer->typ_to_string)

poly，unify

open Belt

let forceGet = Option.getExn
let roundString = str => "(" ++ str ++ ")"
let curlyString = str => "{" ++ str ++ "}"
let assoc = (env, x) => env->List.getAssoc(x, (a, b) => a == b)

let curlyBracket = (x, test) =>
  if test {
    (" " ++ x ++ " ")->curlyString
  } else {
    x
  }

type rec typ = TInt | TBool | TVar(ref<tvar>) | TArr(typ, typ) | Gen(array<string>, typ)
and tvar = NoLink(string, int) | LinkTo(typ)

let typ_to_string = typ => {
  let eagerBracket = (x, test) =>
    if test {
      x->roundString
    } else {
      x
    }

  let rec go = (typ, test) =>
    switch typ {
    | TInt => "Int"
    | TBool => "Bool"
    | TVar({contents: tvar}) =>
      "Var" ++
      switch tvar {
      | NoLink(x, _) => x->roundString
      | LinkTo(_) => assert false
      }
    | TArr(t1, t2) => (go(t1, true) ++ " -> " ++ go(t2, false))->eagerBracket(test)
    | Gen(qvars, t) => "forall: " ++ qvars->Array.joinWith(", ", x => x) ++ ". " ++ go(t, false)
    }

  go(typ, false)
}

type prim = Add | Sub | Mul | Eq

type rec expr =
  | CstI(int)
  | CstB(bool)
  | Var(string)
  | If(expr, expr, expr)
  | Func(string, expr)
  | Apply(expr, expr)
  | Prim(prim, expr, expr)
  | Let(string, expr, expr)

let expr_to_string = expr => {
  let rec go = (parent_prior, expr) =>
    switch expr {
    | CstI(n) =>
      if n < 0 {
        n->Int.toString->roundString
      } else {
        n->Int.toString
      }
    | CstB(b) =>
      if b {
        "true"
      } else {
        "false"
      }
    | Var(x) => x
    | If(test, so_body, else_body) =>
      "if " ++
      go(0, test) ++
      " " ++
      go(0, so_body)->curlyBracket(true) ++
      " else " ++
      go(0, else_body)->curlyBracket(true)
    | Func(x, expr) => ("[" ++ x ++ "]" ++ " => " ++ go(1, expr))->curlyBracket(parent_prior > 1)
    | Apply(e1, e2) => go(0, e1) ++ go(0, e2)->roundString
    | Prim(prim, e1, e2) =>
      switch prim {
      | Add => go(0, e1) ++ " + " ++ go(0, e2)
      | Sub => go(0, e1) ++ " - " ++ go(0, e2)
      | Mul => go(0, e1) ++ " × " ++ go(0, e2)
      | Eq => go(0, e1) ++ " == " ++ go(0, e2)
      }
    | Let(x, e1, e2) =>
      ("let " ++ x ++ " = " ++ go(2, e1) ++ " " ++ go(0, e2)->curlyBracket(true))
        ->curlyBracket(parent_prior > 0)
    }

  go(0, expr)
}

let infer = expr => {
  let count = ref(0)
  let var_fresher = level => {
    let cur = count.contents
    let var = "T/" ++ cur->Int.toString
    count := cur + 1
    TVar(ref(NoLink(var, level)))
  }

  let rec repr_type = t =>
    switch t {
    | TVar(tvar) =>
      switch tvar.contents {
      | NoLink(_, _) => t
      | LinkTo(t) => {
          let t = t->repr_type
          tvar := LinkTo(t)
          t
        }
      }

    | _ => t
    }

  let rec deep_repr_type = t =>
    switch t {
    | TVar(tvar) =>
      switch tvar.contents {
      | NoLink(_, _) => t
      | LinkTo(t) => {
          let t = t->deep_repr_type
          tvar := LinkTo(t)
          t
        }
      }
    | TArr(t1, t2) => TArr(t1->deep_repr_type, t2->deep_repr_type)

    | _ => t
    }

  let rec unify = (t1, t2) => {
    let rec occurs = (x, t) =>
      switch t {
      | TVar({contents: y}) => x == y
      | TArr(t1, t2) => occurs(x, t1) || occurs(x, t2)
      | _ => false
      }

    let t1 = repr_type(t1)
    let 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({contents: NoLink(_, level1)} as tvar1),
          TVar({contents: NoLink(_, level2)} as tvar2),
        ) =>
        if level1 >= level2 {
          tvar1 := LinkTo(t2)
        } else {
          tvar2 := LinkTo(t1)
        }

      | (TVar(tvar), t) | (t, TVar(tvar)) => {
          assert !occurs(tvar.contents, t)
          tvar := LinkTo(t)
        }

      | _ => assert false
      }
    }
  }

  let inst = (t, level) => {
    let subst = (qvar, new_tvar, t) => {
      let rec go = t =>
        switch t {
        | TInt | TBool => t
        | TVar({contents: tvar}) =>
          switch tvar {
          | NoLink(x, _) =>
            if x == qvar {
              new_tvar
            } else {
              t
            }
          | _ => assert false
          }
        | TArr(t1, t2) => TArr(go(t1), go(t2))

        | Gen(_, _) => assert false
        }

      go(t)
    }

    switch t {
    | Gen(qvars, ti) => {
        let length = qvars->Array.length
        let ti = ref(ti)
        if length > 0 {
          qvars->Array.forEach(qvar => {
            ti := subst(qvar, var_fresher(level), ti.contents)
          })
          ti.contents
        } else {
          assert false
        }
      }

    | _ => t
    }
  }

  let gen = (t, level) => {
    let rec get_qvars = t => {
      switch t {
      | TInt | TBool => []
      | TVar({contents: tvar}) =>
        switch tvar {
        | NoLink(x, level_inner) =>
          if level_inner >= level {
            [x]
          } else {
            []
          }
        | _ => assert false
        }
      | TArr(t1, t2) => Array.concat(t1->get_qvars, t2->get_qvars)

      | Gen(_, _) => assert false
      }
    }

    let t = t->deep_repr_type
    let qvars = t->get_qvars
    if qvars->Array.length > 0 {
      let qvars = HashSet.String.fromArray(qvars)->HashSet.String.toArray
      let t_gen = Gen(qvars, t)
      Js.log("__gen|-\t" ++ typ_to_string(t_gen))
      t_gen
    } else {
      Js.log("nogen|-\t" ++ typ_to_string(t))
      t
    }
  }

  let rec check_expr = (context, expr, level) =>
    switch expr {
    // expr: TInt
    | CstI(_) => TInt
    // expr: TBool
    | CstB(_) => TBool
    | Var(x) => inst(context->assoc(x)->forceGet, level)
    // expr: t = fresh T && U(t1, TBool) U(t, t2) U(t, t3)
    | If(test, so_body, else_body) => {
        let t = var_fresher(level)
        let t1 = check_expr(context, test, level)
        let t2 = check_expr(context, so_body, level)
        let t3 = check_expr(context, else_body, level)
        unify(t1, TBool)
        unify(t, t2)
        unify(t, t3)
        t
      }

    // expr: tx->tb tx = fresh T
    | Func(x, body) => {
        let tx = var_fresher(level)
        let tb = check_expr(list{(x, tx), ...context}, body, level + 1)
        TArr(tx, tb)
      }

    // expr: t = fresh T && U(t1, t2->t)
    | Apply(e1, e2) => {
        let t = var_fresher(level)
        let t1 = check_expr(context, e1, level)
        let t2 = check_expr(context, e2, level)
        unify(t1, TArr(t2, t))
        t
      }

    | Prim(prim, e1, e2) => {
        let t1 = check_expr(context, e1, level)
        let t2 = check_expr(context, e2, level)
        unify(t1, TInt)
        unify(t2, TInt)
        switch prim {
        // expr: TInt && U(t1, TInt) U(t2, TInt)
        | Add | Sub | Mul => TInt
        // expr: TBool && U(t1, TInt) U(t2, TInt)
        | Eq => TBool
        }
      }

    // expr: t2
    | Let(x, e1, e2) => {
        let e1_context = list{(x, var_fresher(level)), ...context}
        let t1 = check_expr(e1_context, e1, level + 1)
        let t_gen = gen(t1, level)
        let e2_context = list{(x, t_gen), ...context}
        let t2 = check_expr(e2_context, e2, level)
        t2
      }
    }

  gen(check_expr(list{}, expr, 0), 0)
}

let cases = [
  Func(
    "f",
    Func(
      "a",
      Func(
        "b",
        If(Var("a"), Prim(Add, Apply(Var("f"), Var("b")), CstI(1)), Apply(Var("f"), Var("a"))),
      ),
    ),
  ),
  Func("x", Let("y", Var("x"), Var("y"))),
  Func("x", Let("y", Func("z", Var("x")), Var("y"))),
  Let(
    "id",
    Func("x", Var("x")),
    Let(
      "a",
      Apply(Var("id"), CstI(42)),
      Let("b", Apply(Var("id"), CstB(true)), If(Var("b"), Var("a"), CstI(11))),
    ),
  ),
  Func("f", Let("g", Var("f"), Apply(Var("g"), CstI(42)))),
  Let(
    "fact",
    Func(
      "n",
      If(
        Prim(Eq, Var("n"), CstI(0)),
        CstI(1),
        Prim(Mul, Var("n"), Apply(Var("fact"), Prim(Sub, Var("n"), CstI(1)))),
      ),
    ),
    Apply(Var("fact"), CstI(5)),
  ),
]

cases->Array.forEach(case => {
  Js.log("input|-\t" ++ expr_to_string(case))
  case->infer->ignore
  Js.log("")
})

然後，我們一起，向rust和rescript編譯器進擊吧，https://www.zhihu.com/people/not3.won

...全文