Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 353 lines (315 sloc) 10.664 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* depends *)
19 module Format = BaseFormat
20 module List = BaseList
21
22 (* shorthands *)
23 module Q = QmlAst
24
25 (* *)
26
27 (*
28 Separation.
29 We store all the identifiers containing a corresponding coding directive.
30 *)
31
32 type deprecated_argument =
33 | Use of string
34 | Hint of string
35
36 let pp_deprecated_argument fmt = function
37 | Use use -> Format.fprintf fmt "Use @{<bright>%s@} instead" use
38 | Hint hint -> Format.pp_print_string fmt hint
39
40 type deprecated_infos = {
41 argument : deprecated_argument ;
42 pos : FilePos.pos ;
43 }
44
45 type todo_infos = FilePos.pos
46
47 type env = {
48 deprecated : deprecated_infos IdentMap.t ;
49 todo : todo_infos IdentMap.t ;
50 }
51
52 module S =
53 struct
54 type t = env
55 let pass = "pass_CodingDirectives"
56
57 let pp_map pp fmt map =
58 let iter ident info =
59 Format.fprintf fmt "%s : %a@\n" (Ident.original_name ident) pp info
60 in
61 IdentMap.iter iter map
62
63 let pp_argument fmt = function
64 | Use s -> Format.fprintf fmt "use=%S" s
65 | Hint s -> Format.fprintf fmt "hint=%S" s
66
67 let pp_deprecated fmt infos =
68 Format.fprintf fmt "%a, %a" FilePos.pp infos.pos pp_argument infos.argument
69
70 let pp_todo = FilePos.pp
71
72 let pp fmt env =
73 Format.fprintf fmt "DEPRECATED@\n@[<2>" ;
74 pp_map pp_deprecated fmt env.deprecated ;
75 Format.fprintf fmt "@]TODO@\n@[<2>" ;
76 pp_map pp_todo fmt env.todo ;
77 Format.fprintf fmt "@]";
78 ()
79 end
80
81 module R = ObjectFiles.Make(S)
82
83 (*
84 Warnings
85 *)
86 let wclass =
87 let doc = "Coding directives warnings" in
88 let name = "coding" in
89 WarningClass.create ~name ~doc ~err:false ~enable:true ()
90
91 let wdeprecated =
92 let doc = "deprecated constructions" in
93 let name = "deprecated" in
94 WarningClass.create ~parent:wclass ~name ~doc ~err:false ~enable:true ()
95
96 let wtodo =
97 let doc = "unimplemented" in
98 let name = "todo" in
99 WarningClass.create ~parent:wclass ~name ~doc ~err:false ~enable:true ()
100
101 let warning_set =
102 WarningClass.Set.create_from_list [
103 wclass ;
104 wdeprecated ;
105 wtodo ;
106 ]
107
108 (*
109 Code processing
110 *)
111
112 type 'infos packaged_infos = {
113 infos : 'infos ;
114 package : ObjectFiles.package ;
115 }
116
117 let process_code _gamma annotmap code =
118
119 (* structure to store everything, previous and current packages *)
120 let deprecated : deprecated_infos packaged_infos IdentTable.t = IdentTable.create 64 in
121 let todo : todo_infos packaged_infos IdentTable.t = IdentTable.create 64 in
122
123 (* structure to store only the current package *)
124 let this_deprecated : deprecated_infos IdentTable.t = IdentTable.create 64 in
125 let this_todo : todo_infos IdentTable.t = IdentTable.create 64 in
126
127 (* separation : load *)
128 let iter package env =
129 let iter table ident infos =
130 let p_infos = {
131 infos ;
132 package ;
133 } in
134 IdentTable.add table ident p_infos
135 in
136 let table table = IdentMap.iter (iter table) in
137 table deprecated env.deprecated ;
138 table todo env.todo ;
139 ()
140 in
141 R.iter_with_name ~packages:true ~deep:false iter ;
142
143 (* process the code *)
144 (* 1/2 : collect directives, and remove them *)
145 let annotmap, code =
146 let package = ObjectFiles.get_current_package () in
147 let foldmap_expr ident annotmap expr =
148 let foldmap annotmap = function
149 | Q.Directive (label, `deprecated, args, _) -> (
150 let bad_args ?(label=label) () =
151 let context = QmlError.Context.label label in
152 QmlError.error context (
153 "Invalid arguments for directive @{<bright>@@deprecated@}@\n"^^
154 "@[<2>@{<bright>Hint@}:@\n"^^
155 "argument should be of type @{<bright>%s@},@ and "^^
156 "strings arguments should be literals only@]"
157 )
158 Opacapi.Types.Deprecated.argument
159 in
160 match args with
161 | [ hint ; sub_expr ] -> (
162 let argument =
163 match hint with
164 | Q.Record (label, [ field, Q.Const (_, Q.String literal)]) -> (
165 match field with
166 | "use" -> Use literal
167 | "hint" -> Hint literal
168 | _ -> bad_args ~label ()
169 )
170 | _ ->
171 let label = QmlAst.Label.expr hint in
172 bad_args ~label ()
173 in
174 let pos = QmlAst.Pos.expr expr in
175 let infos = {
176 argument ;
177 pos ;
178 } in
179 let pinfos = {
180 infos ;
181 package ;
182 } in
183 let () =
184 IdentTable.add deprecated ident pinfos ;
185 IdentTable.add this_deprecated ident infos ;
186 in
187 (*
188 Support for EI:
189 get the tsc of the @deprecated directive,
190 and put it on the sub expression
191 *)
192 let annotmap =
193 let sub_label = QmlAst.Label.expr sub_expr in
194 let tsc_opt = QmlAnnotMap.find_tsc_opt_label label annotmap in
195 let annotmap = QmlAnnotMap.add_tsc_opt_label sub_label tsc_opt annotmap in
196 annotmap
197 in
198 annotmap, sub_expr
199 )
200 | _ ->
201 (*
202 QmlDirective ensure the correct typing of this directive
203 *)
204 assert false
205 )
206 | Q.Directive (label, `todo, args, tys) ->
207 let infos = QmlAst.Pos.expr expr in
208 let pinfos = {
209 infos ;
210 package ;
211 } in
212 let () =
213 IdentTable.add todo ident pinfos ;
214 IdentTable.add this_todo ident infos ;
215 in
216 let expr = Q.Directive (label, `fail, args, tys) in
217 annotmap, expr
218
219 | expr -> annotmap, expr
220 in
221 QmlAstWalk.Expr.foldmap foldmap annotmap expr
222 in
223 let code_elt annotmap elt =
224 let val_ ~rec_ label vals =
225 let foldmap annotmap ((ident, expr) as tuple) =
226 let annotmap, fexpr = foldmap_expr ident annotmap expr in
227 annotmap,
228 if expr == fexpr
229 then
230 tuple
231 else
232 (ident, fexpr)
233 in
234 let annotmap, fvals = List.fold_left_map_stable foldmap annotmap vals in
235 annotmap,
236 if vals == fvals
237 then
238 elt
239 else
240 if rec_
241 then
242 Q.NewValRec (label, fvals)
243 else
244 Q.NewVal (label, fvals)
245 in
246 match elt with
247 | Q.NewVal (label, vals) -> val_ ~rec_:false label vals
248 | Q.NewValRec (label, vals) -> val_ ~rec_:true label vals
249
250 (*
251 Coding directive are not authorized on db values
252 *)
253 | Q.NewDbValue (_, dbdef) ->
254 let fmap () = function
255 | Q.Directive (label, ((`deprecated | `todo) as variant), _, _) ->
256 let context = QmlError.Context.label label in
257 QmlError.error context (
258 "The directive @{<bright>%s@} is not authorized in a database definition."
259 )
260 (QmlPrint.directive variant)
261 | expr -> (), expr
262 in
263 let (), _ = QmlAst.Db.foldmap_expr fmap () dbdef in
264 annotmap, elt
265
266 (*
267 Other declaration are kept as is
268 *)
269 | elt -> annotmap, elt
270 in
271 List.fold_left_map_stable code_elt annotmap code
272 in
273
274 (* 2/2 : produces warnings *)
275 let () =
276 let iter (toplevel_ident, expr) =
277 let iter tra = function
278 | Q.Directive (_, `module_, _, _) ->
279 (* This is for avoiding a warning in case of a module explosion *)
280 ()
281 | Q.Ident (label, ident) ->
282 (* deprecated *)
283 Return.set_checkpoint (
284 fun break ->
285 let { infos ; package } =
286 try
287 IdentTable.find deprecated ident
288 with Not_found -> Return.return break ()
289 in
290 let pos = Annot.pos label in
291 let context = QmlError.Context.pos pos in
292 QmlError.warning ~wclass:wdeprecated context (
293 "This is a @{<bright>deprecated@} construction, as precised in:@\n"^^
294 "Package:%s,@\n"^^
295 "%a@\n"^^
296 "@[<2>@{<bright>Hint@}:@\n"^^
297 "%a@]"
298 )
299 (fst package)
300 FilePos.pp infos.pos
301 pp_deprecated_argument infos.argument
302 );
303 (* todo *)
304 Return.set_checkpoint (
305 fun break ->
306 let { infos ; package } =
307 try
308 IdentTable.find todo ident
309 with Not_found -> Return.return break ()
310 in
311 let pos = Annot.pos label in
312 let context = QmlError.Context.pos pos in
313 QmlError.warning ~wclass:wtodo context (
314 "This construction is @{<bright>not implemented@}, as precised in:@\n"^^
315 "Package:%s,@\n"^^
316 "%a@\n"^^
317 "This will fail at runtime."
318 )
319 (fst package)
320 FilePos.pp infos
321 )
322
323 | e -> tra e
324 in
325 (*
326 Contamination rule:
327 a deprecated function is authorized to use a deprecated construction
328 *)
329 if not (IdentTable.mem deprecated toplevel_ident)
330 then
331 QmlAstWalk.Expr.traverse_iter iter expr
332 in
333 List.iter (QmlAstWalk.Top.iter_name_expr iter) code
334 in
335
336 (* separation : store *)
337 let () =
338 let env =
339 let map table =
340 IdentTable.fold IdentMap.add table IdentMap.empty
341 in
342 let deprecated = map this_deprecated in
343 let todo = map this_todo in
344 {
345 deprecated ;
346 todo ;
347 }
348 in
349 R.save env
350 in
351
352 annotmap, code
Something went wrong with that request. Please try again.