/
bslJsIdent.ml
187 lines (160 loc) · 4.67 KB
/
bslJsIdent.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
(*
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/>.
*)
(* depends *)
module Hashtbl = Base.Hashtbl
(* -- *)
type renaming = [
| `no
| `yes
| `fake
]
let cleaning_default_value = ref true
let cleaning = ref None
let renaming = ref `yes
let root_table = Hashtbl.create 1024
module Sa = ServerArg
let spec = [
["--js-cleaning"],
Sa.func Sa.string (
fun () string ->
match string with
| "yes" ->
cleaning := Some true
| "no" ->
cleaning := Some false
| _ ->
Printf.eprintf "--js-cleaning: unknown mode %s (ignored)%!\n" string ;
()
),
"",
"Js runtime cleaning options (no, yes)"
;
["--js-renaming"],
Sa.func Sa.string (
fun () string ->
match string with
| "yes" ->
renaming := `yes
| "no" ->
renaming := `no
| "fake" ->
renaming := `fake
| _ ->
Printf.eprintf "--js-renaming: unknown mode %s (ignored)%!\n" string ;
()
),
"",
"Js runtime renaming options (no, yes, fake)"
;
["--js-root"],
Sa.func Sa.string (
fun () string ->
Hashtbl.add root_table string ()
),
"",
"Js root declaration (testing)"
;
]
let _ = ServerArg.filter () (ServerArg.make_parser "bslJsIdent" spec)
(**
associate a ident name to a key ident,
ident are generated sequentially from an ordered set
always returns the same ident for the same key
always returns the different ident for different key
until clear is called.
rename only identifier defined with [define]
*)
##register rename : string -> string
##register define : string -> void
##register [opacapi] define_rename : string -> string
(**
break rename properties, restart the generation to the first element of the set
*)
##register clear : -> void
let rename,
define,
define_rename,
clear
=
let defined = Hashtbl.create 1024 in
let ref_ = Hashtbl.create 100024 in
let gen = IdentGenerator.alphanum_generator ~prefix:"_" in
let cleared = ref false in
let define (key_ident:string) =
Base.Hashtbl.replace defined key_ident ()
in
let rename (key_ident:string) =
assert (not !cleared);
match !renaming with
| `no -> key_ident
| (`fake | `yes) as kind ->
if Hashtbl.mem defined key_ident
then (
match Base.Hashtbl.find_opt ref_ key_ident with
| Some ident ->
#<If:JS_RENAMING>
Printf.printf "BslJsIdent.lookup: %s -> %s\n%!" key_ident ident
#<End>;
ident
| None ->
let ident =
match kind with
| `fake -> Printf.sprintf "rename_%s" key_ident
| `yes -> gen () in
#<If:JS_RENAMING>
Printf.printf "BslJsIdent.renaming: %s -> %s\n%!" key_ident ident
#<End>;
BslClosure.replace_identifier key_ident ident;
Base.Hashtbl.add ref_ key_ident ident;
ident
) else (
#<If:JS_RENAMING>
Printf.printf "BslJsIdent.not_defined: %s\n%!" key_ident
#<End>;
Base.Hashtbl.add ref_ key_ident key_ident;
key_ident
)
in
let define_rename (key_ident:string) =
define key_ident;
rename key_ident in
let clear () =
#<If:JS_RENAMING> Printf.printf "END OF RENAMING\n%!"#<End>;
cleared := true;
Base.Hashtbl.clear ref_;
Base.Hashtbl.clear defined;
in rename, define, define_rename, clear
(**
Tell if the option for the cleaning was activated
*)
##register js_cleaning : -> bool
let js_cleaning () =
match !cleaning with
| Some b -> b
| None -> !cleaning_default_value
(**
Set the value of --js-cleaning if the user doesn't set its value
It is set in the init module to [true] in full separation and to
[false] otherwise
*)
##register [opacapi] set_cleaning_default_value : bool -> void
let set_cleaning_default_value b =
cleaning_default_value := b
(**
External mechanism for registering roots.
<!> Works with identifier before renaming.
*)
##register is_root : string -> bool
let is_root ident =
Hashtbl.mem root_table ident