问题描述
本练习是北大本研合上课程编程语言的设计原理的一次上机作业，完整的代码可以参考这里。该课程教材是经典的TAPL，作业要为书中fullsimple类型系统（源码可以在TAPL官网下载）添加一种新的term：TmPLet
通俗一点讲，我们要对这样的语句进行扩展：
let x = y in exp
目前的fullsimple系统只支持x和y为单个变量，我们要修改代码使其支持x和y为tuple（元组），使得我们的新类型系统可以对下面的语句进行求值：
/* Examples for testing */
let {x, y, z} = {true, 1, {2}} in z;
let {x, y, z} = {true, 1, {2}} in (lambda x:Nat. x) y;
let {x, y, z} = let x = 1 in {true, x, {2}} in z;
lambda x:Nat. let {x, y} = {true, 1} in x;
let x = 0 in let {y, z} = {1, 2} in x;
let {y, z} = {1, 2} in let y = 3 in y;
解决方案
练习时语法和输出部分已经提前实现
语法
在syntax.ml文件中增加TmPLet语法定义：
type term =
...
| TmPLet of info * string list * term * term
let tminfo t = match t with
...
| TmPLed(fi,_,_,_) -> fi
在parser.mly中增加：
Term :
...
| LET Pattern EQ Term IN Term
{ fun ctx -> TmPLet($1, $2, $4 ctx, $6 (List.fold_left (fun x y -> addname x y) ctx $2)) }
Pattern :
LCURLY MetaVars RCURLY
{ $2 }
| LCURLY RCURLY
{ [] }
输出
在syntax.ml中增加打印信息：
let rec printtm_Term outer ctx t = match t with
...
| TmPLet(fi, xs, t1, t2) ->
obox0();
pr "let {";
let rec print xs = match xs with
x::x'::rest -> pr x; pr ","; print (x'::rest);
| x::[] -> pr x;
| [] -> pr ""; in
print xs;
pr "} = ";
printtm_Term false ctx t1;
print_space(); pr "in"; print_space();
let ctx' = List.fold_left (fun ctx x -> addname ctx x) ctx xs
in printtm_Term false ctx' t2;
cbox()
求值
求值前我们需要弄清楚一个TmPLet项的结构，回顾一下定义：
TmPLet of info * string list * term * term
对应let x = y in exp的形式，x是一个string列表，exp是完成绑定后需要继续求值的表达式，关键是y，在测试用例中我们发现y是一个大括号包含了一堆东西，在parser.mly中我们可以发现它对应一个TyRecord类型的项：
AType :
...
| LCURLY FieldTypes RCURLY
{ fun ctx ->
TyRecord($2 ctx 1) }
对于一个TmPLet(fi, xs, t1, t2)，求值的思路是：先对t1求值，顺利的话会得到一个TmRecord；接着我们每次从xs和t1中取第一个元素，展开成一个TmLet，一个例子如下：
let {x, y} = {true, 1} in x
-> let x = true in let {y} = {1} in x
-> let x = true in let y = 1 in x
而TmLet的求值是fullsimple已经实现好的，因此也就完成了对TmPLet的求值，具体代码就是在core.ml中增加如下内容：
let rec eval1 ctx t = match t with
...
| TmPLet(fi, xs, t1, t2) when (isval ctx t1) ->
(match (xs, t1) with
([x], TmRecord(fi_, [(l, v)])) ->
TmLet(fi, x, v, t2)
| (x::rest1, TmRecord(fi_, (l, v)::rest2)) ->
TmLet(fi, x, v, TmPLet(fi, rest1, TmRecord(fi_, rest2), t2))
| (_, _) -> raise NoRuleApplies)
| TmPLet(fi, xs, t1, t2) ->
let t1' = eval1 ctx t1 in TmPLet(fi, xs, t1', t2)
类型推导
在core.ml中增加如下内容：
let rec typeof ctx t =
| TmPLet(fi, xs, t1, t2) ->
let tyT1 = typeof ctx t1 in
let rec typePLet ctx xs' t1' =
(match (xs', t1') with
([x], TyRecord([(l, t)])) ->
let ctx' = addbinding ctx x (VarBind(t)) in
typeShift (-1) (typeof ctx' t2)
| (x::rest1, TyRecord((l, t)::rest2)) ->
let ctx' = addbinding ctx x (VarBind(t)) in
typeShift (-1) (typePLet ctx' rest1 (TyRecord(rest2)))
| (_, _) -> error fi "error in TyPLet")
in typePLet ctx xs tyT1
写完之后发现有些奇怪的报错，提示我们还要修改syntax.ml的tmmap函数，照猫画虎增加对TmPLet的处理就好了，在syntax.ml中增加：
let tmmap onvar ontype c t =
...
| TmPLet(fi, [x], TmRecord(fi_, [(l, t)]), t2) ->
walk c (TmLet(fi, x, t, t2))
| TmPLet(fi, x::rest1, TmRecord(fi_, (l, t)::rest2), t2) ->
walk c (TmLet(fi, x, t, TmPLet(fi, rest1, TmRecord(fi_, rest2), t2)))
测试
对于开篇的测试语句，运行结果如下：
对于语句let {x, y} = {true} in x，上述代码会输出我们在类型推导时设定的错误信息：error in TyPLet
