Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 365 lines (320 sloc) 12.398 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
19 (* depends *)
20 module Format = Base.Format
21 module List = Base.List
22
23 (* refactoring in progress *)
24
25 (* alias *)
26 module Q = QmlAst
27
28 (**************************************************************)
29 (* Before adding a function here please READ MLI INSTRUCTIONS *)
30 (**************************************************************)
31
32 type ('env, 'a) checker = ('env -> 'a) -> 'env PassHandler.cond
33
34 (* utils for context *)
35 let context_code_elt_expr code_elt expr =
36 let c1 = QmlError.Context.code_elt code_elt in
37 let c2 = QmlError.Context.expr expr in
38 QmlError.Context.merge2 c1 c2
39
40 let context_annotmap_expr annotmap expr =
41 let c1 = QmlError.Context.annotmap annotmap in
42 let c2 = QmlError.Context.expr expr in
43 QmlError.Context.merge2 c1 c2
44
45 (* a *)
46
47 module Annot =
48 struct
49
50 let cond_annot =
51 let doc = "Annotations checks" in
52 WarningClass.create ~parent:WarningClass.cond ~name:"annot" ~doc ~err:true ~enable:true ()
53 let cond_annot_unicity =
54 WarningClass.create ~parent:cond_annot ~name:"unicity" ~doc:"Unicity of annotations" ~err:false ~enable:true ()
55 let cond_annot_find =
56 WarningClass.create ~parent:cond_annot ~name:"find" ~doc:"Checking on annotmap" ~err:true ~enable:true ()
57
58 let id = PassHandler.define_cond cond_annot
59
60 (* TODO:located error message or this test is unusable !!!*)
61 let annot_find annotmap code =
62 if not (QmlAnnotCheckup.code annotmap code) then
63 OManager.warning ~wclass:cond_annot_find
64 "Annotmap is corrupted@\n"
65 else ()
66
67 let find_id = PassHandler.define_cond cond_annot_find
68
69 let find extract =
70 PassHandler.make_condition find_id
71 (fun env ->
72 let annotmap, code = extract env in
73 annot_find annotmap code)
74
75 let annot_unicity code =
76 let check_expr (annset, ()) e =
77 QmlAstWalk.ExprPatt.fold
78 (fun (annset, ()) e ->
79 let a = Q.QAnnot.expr e in
80 if AnnotSet.mem a annset then (
81 QmlError.scheck_fail find_id
82 (QmlError.Context.expr e)
83 "Annot already seen@\n";
84 (annset, ()))
85 else (AnnotSet.add a annset, ()))
86 (fun (annset, ()) p ->
87 let a = Q.QAnnot.pat p in
88 if AnnotSet.mem a annset then (
89 QmlError.scheck_fail find_id
90 (QmlError.Context.pat p)
91 "Annot already seen@\n";
92 (annset, ()))
93 else (AnnotSet.add a annset, ()))
94 (annset, ()) e
95 in
96 snd (QmlAstWalk.CodeExpr.fold
97 check_expr (AnnotSet.empty, ()) code)
98
99 let unicity_id = PassHandler.define_cond cond_annot_unicity
100
101 let unicity extract =
102 PassHandler.make_condition unicity_id
103 (fun env -> annot_unicity (extract env))
104 end
105
106 (* b *)
107
108 module Bypass =
109 struct
110
111 let cond_bypass =
112 let doc = "Bypasses checks" in
113 WarningClass.create ~parent:WarningClass.cond ~name:"bypass" ~doc ~err:true ~enable:true ()
114 let cond_bypass_applied =
115 WarningClass.create ~parent:cond_bypass ~name:"applied"
116 ~doc:"Total application of bypasses"
117 ~err:true ~enable:true ()
118
119 let id = PassHandler.define_cond cond_bypass
120
121 let applied_id = PassHandler.define_cond cond_bypass_applied
122
123 let bypass_applied bypass_typer code =
124 let is_fully_applied code_elt tra expr =
125 let (!!) x =
126 let context = context_code_elt_expr code_elt expr in
127 QmlError.scheck_fail applied_id context x in
128 let rec aux_expr expr =
129 match expr with
130 | Q.Apply _ ->
131 (match QmlAstUtils.App.to_list expr with
132 | [] | [_] -> assert false
133 | bypass :: app_args ->
134 let rec aux_bypass bypass =
135 match bypass with
136 | Q.Directive (_, `may_cps, [bypass], _) -> aux_bypass bypass
137 | Q.Directive (_, `restricted_bypass _, [ Q.Bypass (_, key) ], _)
138 | Q.Bypass (_, key) ->
139 let ty = bypass_typer key in
140 let bypass_arity =
141 match ty with
142 | Some (QmlAst.TypeArrow (args, ty)) -> QmlTypesUtils.TypeArrow.curryfied_arity args ty
143 | Some _ -> 0 (* should not happen *)
144 | None -> 0
145 in
146 let args_number = List.length app_args in
147 if bypass_arity <> args_number then
148 let skey = BslKey.to_string key in
149 let d = bypass_arity - args_number in
150 if d > 0 then
151 !! (
152 "@[<2>This bypass (%s) is partially applied.@\n"^^
153 "The arity of this bypass is %d@\n"^^
154 "and it is there applied to %d argument(s)@]"
155 )
156 skey bypass_arity args_number
157 else
158 !! (
159 "@[<2>This bypass (%s) is applied to too many arguments.@\n"^^
160 "The arity of this bypass is %d@\n"^^
161 "And it is there applied to %d argument(s).@]"
162 )
163 skey bypass_arity args_number
164 | _ -> ()
165 in aux_bypass bypass
166 )
167 | Q.Directive (_, `may_cps, [bypass], _) -> aux_expr bypass
168 | Q.Directive (_, `restricted_bypass _, [ Q.Bypass (_, key) ], _)
169 | Q.Bypass (_, key) ->
170 let ty = bypass_typer key in
171 let bypass_arity =
172 match ty with
173 | Some (QmlAst.TypeArrow (args, ty)) ->
174 QmlTypesUtils.TypeArrow.curryfied_arity args ty (* should not happen *)
175 | Some _ -> 0
176 | None -> 0
177 in
178 if bypass_arity <> 0 then
179 let skey = BslKey.to_string key in
180 !! "This bypass (%s) takes %d argument(s) but is not applied@\n" skey bypass_arity
181 | _ -> tra expr
182 in
183 aux_expr expr
184 in
185 List.iter (fun code_elt ->
186 QmlAstWalk.Top.iter_expr (QmlAstWalk.Expr.traverse_iter (is_fully_applied code_elt)) code_elt)
187 code
188
189 let applied extract =
190 PassHandler.make_condition applied_id
191 (fun env ->
192 let bypass_typer, code = extract env in
193 bypass_applied bypass_typer code)
194 end
195
196 (* c *)
197
198 module Code =
199 struct
200
201 let cond_code =
202 let doc = "Code checks" in
203 WarningClass.create ~parent:WarningClass.cond ~name:"code" ~doc ~err:true ~enable:true ()
204 let cond_code_contents =
205 let doc = "Code elts present in the code" in
206 WarningClass.create ~parent:cond_code ~name:"contents" ~doc ~err:true ~enable:true ()
207 let cond_code_valrec =
208 let doc = "Validity of recursives values" in
209 WarningClass.create ~parent:cond_code ~name:"valrec" ~doc ~err:true ~enable:true ()
210
211
212 let id = PassHandler.define_cond cond_code
213
214 type contents_code_elt = {
215 c_Database : bool ;
216 c_NewDbValue : bool ;
217 c_NewType : bool ;
218 c_NewVal : bool ;
219 c_NewValRec : bool ;
220 }
221 let contents_all = {
222 c_Database = true ;
223 c_NewDbValue = true ;
224 c_NewType = true ;
225 c_NewVal = true ;
226 c_NewValRec = true ;
227 }
228 let contents_id = PassHandler.define_cond cond_code_contents
229 let contents_check cont (annotmap, code) =
230 let iter = function
231 | Q.Database _ when cont.c_Database -> ()
232 | Q.NewDbValue _ when cont.c_NewDbValue -> ()
233 | Q.NewType _ when cont.c_NewType -> ()
234 | Q.NewVal _ when cont.c_NewVal -> ()
235 | Q.NewValRec _ when cont.c_NewValRec -> ()
236 | code_elt ->
237 let context =
238 let c1 = QmlError.Context.code_elt code_elt in
239 let c2 = QmlError.Context.annotmap annotmap in
240 QmlError.Context.merge2 c1 c2
241 in
242 QmlError.check_fail contents_id context
243 "The code should not more content such code_elt as this point.@\n"
244 in
245 List.iter iter code
246 let contents cont extract =
247 PassHandler.make_condition contents_id
248 (fun env -> contents_check cont (extract env))
249
250 (* Recursives values **************************)
251 let valrec_id = PassHandler.define_cond cond_code_valrec
252
253 type ('a,'b) ignored_directives = [
254 | `doctype of 'a
255 | QmlAst.type_directive
256 | QmlAst.slicer_directive
257 | `lifted_lambda of 'b
258 ]
259
260 let check_valrec ~undot check_fail (annotmap, code) =
261 let error =
262 if check_fail then QmlError.scheck_fail valrec_id
263 else QmlError.serror
264 in
265 let get_name =
266 if check_fail then Ident.to_string
267 else Ident.original_name
268 in
269 let make_message to_string no_lambda rec_def =
270 let a =
271 fst
272 (List.fold_left
273 (fun (s, c) (ident, e0) ->
274 (Printf.sprintf "%s%c %s %s" s c (to_string ident) (Format.to_string QmlPrint.pp#expr e0)), ',')
275 ("The following idents are not lambda ", ':')
276 no_lambda)
277 in
278 fst
279 (List.fold_left
280 (fun (s, c) (ident, _) ->
281 (Printf.sprintf "%s%c %s" s c (to_string ident)), ',')
282 (Printf.sprintf "%s\nOn the following recursive definition" a, ':')
283 rec_def)
284 in
285 let rec check_lambda (name, e0) =
286 match e0 with
287
288 (* Directives: Particular cases *)
289 | Q.Directive (_, `module_, [e], _) ->
290 if undot then
291 (match e with
292 | Q.Record (_, lst) ->
293 (*
294 FIXME: remove (or document seriously) these dirty magic !
295 *)
296 check_list (Obj.magic (fun x -> x))
297 (Some (context_annotmap_expr annotmap e)) (Obj.magic lst)
298 | _ -> assert false)
299 else false
300 | Q.Directive (_, `insert_server_value _, _, _) ->
301 (* an other check can be done later, after client code injection *)
302 true
303
304 (* traversed directives *)
305 | Q.Directive (_, #ignored_directives, [e], _) -> check_lambda (name, e)
306
307 | Q.Coerce (_, e, _) -> check_lambda (name, e)
308 | Q.Directive (_, `recval, _, _)
309 | Q.Lambda _ -> true
310 | _ -> false
311
312 and check_list to_string context l =
313 let no_lambda =
314 List.fold_left
315 (fun no_lambda cpl ->
316 if not (check_lambda cpl) then
317 cpl::no_lambda
318 else no_lambda
319 ) [] l in
320 if not (List.is_empty no_lambda) then (
321 let context =
322 match context with
323 | None ->
324 (* FIXME: this is a hack for building a context *)
325 context_annotmap_expr annotmap (snd (List.hd no_lambda))
326 | Some context -> context
327 in
328
329 error context
330 "Invalid recursive definition@\n%s@\n"
331 (make_message to_string no_lambda l);
332 false
333 ) else true
334 in
335 let check_into (_, e) =
336 let aux e = match e with
337 | Q.LetRecIn (_, ieli, _) ->
338 ignore(
339 check_list get_name
340 (Some (context_annotmap_expr annotmap e)) ieli)
341 | _ -> ()
342 in QmlAstWalk.Expr.iter_down aux e
343 in
344 let check lcode =
345 List.iter
346 ( function
347 | Q.NewVal (_, li) -> List.iter check_into li
348 | Q.NewValRec (_, li) ->
349 ignore (check_list get_name None li)
350 | _ -> ()
351 )
352 lcode
353 in
354 check code
355
356 let valrec extract =
357 PassHandler.make_condition valrec_id
358 (fun env ->
359 (* FIXME - Undot should be given by the caller *)
360 check_valrec ~undot:true true (extract env))
361
362 let valrec_user ~undot extract =
363 PassHandler.make_condition valrec_id (fun env -> check_valrec ~undot false (extract env))
364 end
Something went wrong with that request. Please try again.