forked from MLstate/opalang
-
Notifications
You must be signed in to change notification settings - Fork 0
/
imp_SimpleRenaming.ml
226 lines (185 loc) · 6.29 KB
/
imp_SimpleRenaming.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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module J = JsAst
module Cons = JsCons
let (|>) = InfixOperator.(|>)
module IdentMap = JsAst.IdentMap;;
module IdentSet = JsAst.IdentSet;;
module List = Base.List
module String = Base.String
type jsp = JsAst.code -> JsAst.code
(*
If we need to have unicity of annotation,
we must replace rlabel by :
{[
let rlabel = Annot.refresh
]}
*)
external rlabel : Annot.label -> Annot.label = "%identity"
module Rename :
sig
type env
val empty : env
val add : JsAst.ident -> env -> env
val new_binding : env -> JsAst.ident -> env * JsAst.ident
val resolve : env -> JsAst.ident -> JsAst.ident
val assert_resolve : env -> JsAst.ident -> JsAst.ident
end =
struct
(*
Generate a short JS identifier from an int.
In case the identifier returned is a js keyword,
skip it, and inspect the next generated one.
The function return the next int to use for generating
the next short ident.
*)
let rec name_of_int i =
let name = IdentGenerator.alphanum i in
if JsAst.is_keyword name then name_of_int (i+1) else JsCons.Ident.native name, (i+1)
type env = JsAst.ident IdentMap.t * int
let empty = (IdentMap.empty, 0)
let new_binding (map, number) ident =
let new_ident, number = name_of_int number in
let map = IdentMap.add ident new_ident map in
(map, number), new_ident
let add ident (map, number) =
let new_ident, number = name_of_int number in
let map = IdentMap.add ident new_ident map in
(map, number)
let resolve (map, _) ident =
match IdentMap.find_opt ident map with
| Some ident -> ident
| None -> ident
let assert_resolve (map, _) ident =
match IdentMap.find_opt ident map with
| Some ident -> ident
| None ->
assert false
end
(*
Collect vars and function local to a statement, without entering
internal function inside other functions.
*)
let stmt_collect_locals acc s =
JsWalk.OnlyStatement.traverse_fold (
fun tra acc -> function
| J.Js_var (_, ident, _) -> Rename.add ident acc
| J.Js_function (_, ident, _, _) -> Rename.add ident acc (* NOT traversing *)
| J.Js_trycatch (_,_,catches,_) ->
let acc = List.fold_left (fun acc (ident,_,_) -> Rename.add ident acc) acc catches in
tra acc s
| s ->
tra acc s
) acc s
(*
Cf the notice for the 3 following recursive functions.
{[
let rec rename_expr
and rename_function
and rename_statement
]}
*)
let rec rename_expr (acc : Rename.env) e =
JsWalk.OnlyExpr.traverse_map (
fun tra e ->
match e with
| J.Je_function (label, ident, params, body) ->
let recons (ident, params, body) = J.Je_function (label, ident, params, body) in
recons (rename_function acc ident params body)
| J.Je_ident (label, ident) ->
let ident = Rename.resolve acc ident in
let e = J.Je_ident (label, ident) in
e
| e ->
tra e
) e
and rename_function acc ident params body =
let ident = Option.map (Rename.resolve acc) ident in
let acc, params = List.fold_left_map Rename.new_binding acc params in
let acc = List.fold_left stmt_collect_locals acc body in
let body = List.tail_map (rename_statement acc) body in
(ident, params, body)
and rename_statement acc stmt =
JsWalk.TStatement.traverse_map (
fun traS _traE s ->
match s with
| J.Js_var (label, ident, expr) ->
let ident = Rename.resolve acc ident in
let expr = Option.map (rename_expr acc) expr in
J.Js_var (label, ident, expr)
| J.Js_function (label, ident, params, body) ->
let recons (ident, params, body) =
let ident = Option.get ident in
J.Js_function (label, ident, params, body) in
recons (rename_function acc (Some ident) params body)
| J.Js_trycatch (label, body, catches, finally) ->
let catches = List.map (fun (ident, e, s) -> (Rename.resolve acc ident, e, s)) catches in
let s = J.Js_trycatch (label, body, catches, finally) in
traS s
(*
the node with is not supported by the local renaming
*)
| J.Js_with _ -> assert false
| s -> traS s
)
(fun _traE _traS e -> rename_expr acc e)
stmt
(*
Renaming function parameters, and local variables.
This renaming does not affect toplevel identifiers
*)
let local_alpha_stm stm =
let acc = Rename.empty in
rename_statement acc stm
let local_alpha code =
let acc = Rename.empty in
List.tail_map (rename_statement acc) code
(*
NOTICE:
let rec rename_expr (acc : Rename.env) e =
let rec aux e =
ExprOnly.map_down
ou un traverse_map_down où on fait gaffe aux je_function
map_down utilisant acc
sauf dans le cas Je_function,
où on appelle une regle de renommage des fonctions
qui appelle rename_statement avec (acc + quelque chose)
in
aux_expr e
and rename_function recons acc ident params body =
1) on rename ident avec ce acc,
2) collect les var et les function dans body sans rentrer dans les function
fold sur statement only, pas de tra sur Js_function
StatementOnly.traverse_fold
3) ca en fait un acc2,
on met params dans acc2
on renomme le body avec acc2 (rename_statement)
et on recons
and rename_statement acc s =
- si tombe sur Js_function, simplement appliquer rename_function
- si var : simplement appliquer le renommage
sinon : rename_expr avec le meme acc
et tra acc sur les statement
TStatement.traverse_map
avec rename_expr sur les expr
et tra sur les statement
TStatement.traverse_map
(fun traS traE e -> rename_expr acc e)
(fun traS traE s ->
match s with
| Js_function -> rename_function
| JsVar -> lookup acc pour renommer
| s -> traS s)
s
*)