forked from links-lang/links
-
Notifications
You must be signed in to change notification settings - Fork 0
/
desugarCP.ml
122 lines (118 loc) · 6.86 KB
/
desugarCP.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
open Utility
open Sugartypes
module TyEnv = Env.String
class desugar_cp env =
object (o : 'self_type)
inherit (TransformSugar.transform env) as super
method! phrasenode = function
| `CP p ->
let rec desugar_cp = fun o (p, pos) ->
let add_pos x = (x, pos) in
match p with
| `Unquote (bs, e) ->
let envs = o#backup_envs in
let (o, bs) = TransformSugar.listu o (fun o -> o#binding) bs in
let (o, e, t) = o#phrase e in
let o = o#restore_envs envs in
o, `Block (bs, e), t
| `Grab ((c, _), None, p) ->
let (o, e, t) = desugar_cp o p in
o, `Block
([add_pos (`Val ([], add_pos `Any,
add_pos (`FnAppl (add_pos (`Var "wait"),
[add_pos (`Var c)])),
`Unknown, None))],
add_pos e), t
| `Grab ((c, Some (`Input (_a, s), grab_tyargs)), Some (x, Some u, _), p) -> (* FYI: a = u *)
let envs = o#backup_envs in
let venv = TyEnv.bind (TyEnv.bind (o#get_var_env ())
(x, u))
(c, s) in
let o = {< var_env = venv >} in
let (o, e, t) = desugar_cp o p in
let o = o#restore_envs envs in
o, `Block
([add_pos (`Val ([], add_pos (`Record ([("1", add_pos (`Variable (x, Some u, pos)));
("2", add_pos (`Variable (c, Some s, pos)))], None)),
add_pos (`FnAppl (add_pos (Sugartypes.tappl (`Var "receive", grab_tyargs)),
[add_pos (`Var c)])),
`Unknown, None))],
add_pos e), t
| `Give ((c, _), None, p) ->
let (o, e, t) = desugar_cp o p in
o, `Block
([add_pos (`Val ([], add_pos `Any,
add_pos (`FnAppl (add_pos (`Var "close"),
[add_pos (`Var c)])),
`Unknown, None))],
add_pos e), t
| `Give ((c, Some (`Output (_t, s), give_tyargs)), Some e, p) ->
let envs = o#backup_envs in
let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, s) >} in
let (o, e, _typ) = o#phrase e in
let (o, p, t) = desugar_cp o p in
let o = o#restore_envs envs in
o, `Block
([add_pos (`Val ([], add_pos (`Variable (c, Some s, pos)),
add_pos (`FnAppl (add_pos (Sugartypes.tappl (`Var "send", give_tyargs)),
[e; add_pos (`Var c)])),
`Unknown, None))],
add_pos p), t
| `GiveNothing ((c, Some t, _)) ->
o, `Var c, t
| `Select ((c, Some s, _), label, p) ->
let envs = o#backup_envs in
let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, TypeUtils.select_type label s) >} in
let (o, p, t) = desugar_cp o p in
let o = o#restore_envs envs in
o, `Block
([add_pos (`Val ([], add_pos (`Variable (c, Some (TypeUtils.select_type label s), pos)),
add_pos (`Select (label, (add_pos (`Var c)))),
`Unknown, None))],
add_pos p), t
| `Offer ((c, Some s, _), cases) ->
let desugar_branch (label, p) (o, cases) =
let envs = o#backup_envs in
let o = {< var_env = TyEnv.bind (o#get_var_env ()) (c, TypeUtils.choice_at label s) >} in
let (o, p, t) = desugar_cp o p in
let pat : pattern = add_pos (`Variant (label, Some (add_pos (`Variable (c, Some (TypeUtils.choice_at label s), pos))))) in
o#restore_envs envs, ((pat, add_pos p), t) :: cases in
let (o, cases) = List.fold_right desugar_branch cases (o, []) in
(match List.split cases with
| (_, []) -> assert false (* Case list cannot be empty *)
| (cases, t :: _ts) ->
o, `Offer (add_pos (`Var c),
cases,
Some t), t)
| `Link ((c, Some ct, _), (d, Some _dt, _)) ->
o, `FnAppl (add_pos (Sugartypes.tappl (`Var "linkSync", [`Type ct; `Row o#lookup_effects])),
[add_pos (`Var c); add_pos (`Var d)]), Types.make_endbang_type
| `Comp ((c, Some s, _), left, right) ->
let envs = o#backup_envs in
let (o, left, _typ) = desugar_cp {< var_env = TyEnv.bind (o#get_var_env ()) (c, s) >} left in
let (o, right, t) = desugar_cp {< var_env = TyEnv.bind (o#get_var_env ()) (c, Types.dual_type s) >} right in
let o = o#restore_envs envs in
let left_block = add_pos (`Spawn (`Angel, `NoSpawnLocation, add_pos (`Block ([add_pos (`Val ([], add_pos (`Variable (c, Some s, pos)),
add_pos (`FnAppl (add_pos (`Var "accept"), [add_pos (`Var c)])),
`Unknown, None));
add_pos (`Val ([], add_pos (`Variable (c, Some Types.make_endbang_type, pos)),
add_pos left,
`Unknown, None))],
add_pos (`FnAppl (add_pos (`Var "close"),
[add_pos (`Var c)])))),
Some (Types.make_singleton_closed_row ("wild", `Present Types.unit_type)))) in
let o = o#restore_envs envs in
o, `Block
([add_pos (`Val ([], add_pos (`Variable (c, Some (`Application (Types.access_point, [`Type s])), pos)),
add_pos (`FnAppl (add_pos (`Var "new"), [])),
`Unknown, None));
add_pos (`Val ([], add_pos (`Any), left_block, `Unknown, None));
add_pos (`Val ([], add_pos (`Variable (c, Some (Types.dual_type s), pos)),
add_pos (`FnAppl (add_pos (`Var "request"), [add_pos (`Var c)])),
`Unknown, None))],
add_pos right), t
| _ -> assert false in
desugar_cp o p
| e -> super#phrasenode e
end
let desugar_cp env = ((new desugar_cp env) : desugar_cp :> TransformSugar.transform)