Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 831 lines (747 sloc) 28.145 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 (* cf mli *)
19
20 (* depends *)
21 module List = BaseList
22
23 (* aliases *)
24 module Db = QmlAst.Db
25
26 (* shorthands *)
27 module Q = QmlAst
28
29 let add_void_acc f = fun () v->(), f v
30 let rm_void_acc f = fun v-> snd (f () v)
31 let make_fold fold_map f acc elt = fst (fold_map (fun acc v-> f acc v, v) acc elt)
32 let make_map fold_map f elt = rm_void_acc (fold_map (add_void_acc f)) elt
33 let make_iter fold_map f elt = fst (fold_map (fun () v-> (f v:unit), v) () elt)
34
35
36 module Row =
37 struct
38
39 let rec aux_flag tau = Some tau
40
41 let fold_left fct acc r =
42 let Q.TyRow (fs, _) = r in
43 List.fold_left (fun acc (f, t) -> fct acc f t) acc fs
44
45 let fold_left_map fct acc r =
46 let Q.TyRow (fs, v) = r in
47 let acc, ffs = List.fold_left_map_stable
48 (fun acc ((f, t) as c) ->
49 let acc, ft = fct acc t in
50 acc,
51 if t == ft then c else
52 (f, ft)
53 ) acc fs in
54 acc,
55 if fs == ffs then r else
56 Q.TyRow (ffs, v)
57
58 let fold_right fct r acc =
59 let Q.TyRow (fs, _) = r in
60 List.fold_right (fun (f, t) acc -> fct f t acc) fs acc
61
62 let elements (Q.TyRow (fs, _)) = fs
63
64 let length (Q.TyRow (fs, _)) = List.length fs
65
66 let compare (f, _) (f', _) = String.compare f f'
67
68 let ordered_elements row = List.sort compare (elements row) (** eventually use a heap with a fold_left *)
69
70 let ordered_fold fct acc row =
71 let fct acc (f, t) = fct acc f t in
72 List.fold_left fct acc (ordered_elements row)
73
74 let pos_of_field row =
75 let len = ref 0 in
76 let li = fold_left (fun acc f o -> incr(len); (f, o)::acc) [] row in
77 let len = !len and li = List.rev li in
78 let fields = Array.make len ("", QmlAst.typeNull) in
79 List.iteri (fun fo i -> fields.(i) <- fo) li;
80 let map = List.fold_left_i (fun map (f, o) i -> StringMap.add f (i, o) map) StringMap.empty li in
81 fields, map
82
83 let has_field f (Q.TyRow (fs, _)) = List.mem_assoc f fs
84 let get_field f (Q.TyRow (fs, _)) = List.assoc_opt f fs
85 end
86
87 module Col =
88 struct
89 let fold_left_map fct acc col =
90 let Q.TyCol (fsl, cv) = col in
91 let acc, ffsl =
92 List.fold_left_map_stable
93 (List.fold_left_map_stable
94 (fun acc ((f, t) as c) ->
95 let acc, ft = fct acc t in
96 acc,
97 if t == ft then c else
98 (f, ft)
99 )
100 )
101 acc fsl in
102 acc,
103 if fsl == ffsl then col else
104 Q.TyCol (ffsl, cv)
105
106 let fold_records f acc col =
107 let Q.TyCol (fldslist, _colvar) = col in
108 List.fold_left (fun acc flds -> f acc (Q.TypeRecord (Q.TyRow (flds, None)))) acc fldslist
109 end
110
111 (** over interface, cf mli *)
112 module Ty_sums =
113 struct
114 let elements l = l
115 let fold f l a = List.fold_left (fun t a -> f a t) a l
116 end
117
118 module Type =
119 struct
120 (*
121 module Subs : TraverseInterface.S with type 'a t = ty constraint 'a = 'b * 'c * 'd = struct
122 type 'a t = ty constraint 'a = 'b * 'c * 'd
123
124 let subs_cons ty =
125 let fun0 e = function [] -> e | _ -> assert false in
126 let fun1 f = function [x] -> f x | _ -> assert false in
127 let fun2 f = function [x; y] -> f x y | _ -> assert false in
128 let rec list_combine_rem l1 l2 = match l1, l2 with
129 | x1::r1,x2::r2 -> let r,rem = list_combine_rem r1 r2 in
130 (x1, x2)::r, rem
131 | [],l -> [],l
132 | _, [] -> assert false in
133 match ty with
134 | (TypeConst _ | TypeVar _ | TypeAbstract) -> fun0 ty, []
135 | TypeArrow (lt, t) ->
136 ((fun tlt ->
137 match tlt with
138 | [] -> assert false
139 | t :: lt -> TypeArrow (lt, t)),
140 t :: lt)
141 | TypeRecord (TyRow (row, rv)) ->
142 let fields, tys = List.split row in
143 (fun tys ->
144 let row, rest = list_combine_rem fields tys in
145 assert (rest = []);
146 TypeRecord (TyRow (row, rv))), tys
147 | TypeSum (TyCol (col, cv)) ->
148 (* something special is happening here (this may or may not be what you want) *)
149 let recs = List.map (fun row -> TypeRecord (TyRow (row, None))) col in
150 (fun recs ->
151 let col = List.map (function
152 | TypeRecord (TyRow (row, None)) -> row
153 | _ -> assert false) recs in
154 TypeSum (TyCol (col, cv))), recs
155 | TypeSumSugar tys ->
156 (fun tys -> TypeSumSugar tys), tys
157 | TypeName (tys, ti) ->
158 (fun tys -> TypeName (tys, ti)), tys
159 | TypeForall (vars, rvars, cvars, t) ->
160 fun1 (fun t -> TypeForall (vars, rvars, cvars, t)), [t]
161 end
162 *)
163 module S2 : TraverseInterface.S2 with type 'a t = Q.ty constraint 'a = 'b * 'c * 'd =
164 struct
165 type 'a t = Q.ty constraint 'a = 'b * 'c * 'd
166
167 let foldmap_field_stable tra acc ((x, y) as c) =
168 let acc, y' = tra acc y in
169 acc,
170 if y == y' then c else (x, y')
171
172 let foldmap tra acc t =
173 match t with
174 | Q.TypeConst _
175 | Q.TypeVar _ -> acc, t
176 | Q.TypeArrow (tyl, ty) ->
177 let acc, ftyl = List.fold_left_map_stable tra acc tyl in
178 let acc, fty = tra acc ty in
179 acc,
180 if tyl == ftyl && ty = fty then t else
181 Q.TypeArrow (ftyl, fty)
182 | Q.TypeRecord (Q.TyRow (fields, rowvar)) ->
183 let acc, ffields = List.fold_left_map_stable (foldmap_field_stable tra) acc fields in
184 acc,
185 if fields == ffields then t else
186 Q.TypeRecord (Q.TyRow (ffields, rowvar))
187 | Q.TypeSum (Q.TyCol (l_fields, colvar)) ->
188 let acc, fl_fields = List.fold_left_map_stable (List.fold_left_map_stable (foldmap_field_stable tra)) acc l_fields in
189 acc,
190 if l_fields == fl_fields then t else
191 Q.TypeSum (Q.TyCol (fl_fields, colvar))
192 | Q.TypeSumSugar tyl ->
193 let acc, ftyl = List.fold_left_map_stable tra acc tyl in
194 acc,
195 if tyl == ftyl then t else
196 Q.TypeSumSugar ftyl
197 | Q.TypeName (tyl, typeident) ->
198 let acc, ftyl = List.fold_left_map_stable tra acc tyl in
199 acc,
200 if tyl == ftyl then t else
201 Q.TypeName (ftyl, typeident)
202 | Q.TypeAbstract -> acc, t
203 | Q.TypeForall (typevars, rowvars, colvars, ty) ->
204 let acc, fty = tra acc ty in
205 acc,
206 if ty == fty then t else
207 Q.TypeForall (typevars, rowvars, colvars, fty)
208
209 let iter_field tra (_, ty) = tra ty
210
211 let iter tra t =
212 match t with
213 | Q.TypeConst _
214 | Q.TypeVar _ -> ()
215 | Q.TypeArrow (tyl, ty) ->
216 List.iter tra tyl;
217 tra ty
218 | Q.TypeRecord (Q.TyRow (fields, _rowvar)) ->
219 List.iter (iter_field tra) fields
220 | Q.TypeSum (Q.TyCol (l_fields, _colvar)) ->
221 List.iter (List.iter (iter_field tra)) l_fields
222 | Q.TypeSumSugar tyl ->
223 List.iter tra tyl
224 | Q.TypeName (tyl, _typeident) ->
225 List.iter tra tyl
226 | Q.TypeAbstract -> ()
227 | Q.TypeForall (_typevars, _rowvars, _colvars, ty) ->
228 tra ty
229
230 let map_field_stable tra ((x, y) as c) =
231 let y' = tra y in
232 if y == y' then c else (x, y')
233
234 let map tra t =
235 match t with
236 | Q.TypeConst _
237 | Q.TypeVar _ -> t
238 | Q.TypeArrow (tyl, ty) ->
239 let mtyl = List.map_stable tra tyl in
240 let mty = tra ty in
241 if tyl == mtyl && ty = mty then t else
242 Q.TypeArrow (mtyl, mty)
243 | Q.TypeRecord (Q.TyRow (fields, rowvar)) ->
244 let mfields = List.map_stable (map_field_stable tra) fields in
245 if fields == mfields then t else
246 Q.TypeRecord (Q.TyRow (mfields, rowvar))
247 | Q.TypeSum (Q.TyCol (l_fields, colvar)) ->
248 let ml_fields = List.map_stable (List.map_stable (map_field_stable tra)) l_fields in
249 if l_fields == ml_fields then t else
250 Q.TypeSum (Q.TyCol (ml_fields, colvar))
251 | Q.TypeSumSugar tyl ->
252 let mtyl = List.map_stable tra tyl in
253 if tyl == mtyl then t else
254 Q.TypeSumSugar mtyl
255 | Q.TypeName (tyl, typeident) ->
256 let mtyl = List.map_stable tra tyl in
257 if tyl == mtyl then t else
258 Q.TypeName (mtyl, typeident)
259 | Q.TypeAbstract -> t
260 | Q.TypeForall (typevars, rowvars, colvars, ty) ->
261 let mty = tra ty in
262 if ty == mty then t else
263 Q.TypeForall (typevars, rowvars, colvars, mty)
264
265 let fold_field tra acc (_, ty) = tra acc ty
266
267 let fold tra acc t =
268 match t with
269 | Q.TypeConst _
270 | Q.TypeVar _ -> acc
271 | Q.TypeArrow (tyl, ty) ->
272 let acc = List.fold_left tra acc tyl in
273 let acc = tra acc ty in
274 acc
275 | Q.TypeRecord (Q.TyRow (fields, _rowvar)) ->
276 let acc = List.fold_left (fold_field tra) acc fields in
277 acc
278 | Q.TypeSum (Q.TyCol (l_fields, _colvar)) ->
279 let acc = List.fold_left (List.fold_left (fold_field tra)) acc l_fields in
280 acc
281 | Q.TypeSumSugar tyl ->
282 let acc = List.fold_left tra acc tyl in
283 acc
284 | Q.TypeName (tyl, _typeident) ->
285 let acc = List.fold_left tra acc tyl in
286 acc
287 | Q.TypeAbstract -> acc
288 | Q.TypeForall (_typevars, _rowvars, _colvars, ty) ->
289 let acc = tra acc ty in
290 acc
291 end
292
293 (* TODO: bench with this one *)
294 include Traverse.Make2 (S2)
295
296 (* For now, Keeping old implementation *)
297 (* include Traverse.Make (Subs) *)
298 end
299
300
301 module Top =
302 struct
303 (*let iter_expr f = function
304 | Database _
305 | NewDbValue (Db_Q.TypeDecl _)
306 | NewType _ -> ()
307 | NewDbValue (Db_Constraint _) -> assert false
308 | NewVal bnd | NewValRec bnd -> List.iter (fun (_,e) -> f e) bnd
309 | NewDbValue (Db_Default (p, dflt)) -> f dflt
310
311 let map_expr map elt = match elt with
312 | Database _
313 | NewDbValue (Db_TypeDecl _)
314 | NewType _ -> elt
315 | NewDbValue (Db_Constraint _) -> assert false
316 | NewDbValue (Db_Default (p, dflt)) -> NewDbValue (Db_Default (p, map dflt))
317 | NewVal se -> NewVal (List.map (fun (s, e) -> (s, map e)) se)
318 | NewValRec se -> NewValRec (List.map (fun (s, e) -> (s, map e)) se)
319
320 let fold_expr f acc elt = match elt with
321 | Database _
322 | NewDbValue (Db_TypeDecl _)
323 | NewType _ -> acc
324 | NewDbValue (Db_Constraint _) -> assert false
325 | NewVal bnd | NewValRec bnd -> List.fold_left (fun acc (id,e) -> f acc e) acc bnd
326 | NewDbValue (Db_Default (p, dflt)) -> f acc dflt*)
327
328 let fold_map_name_expr f acc elt =
329 match elt with
330 | Q.Database _
331 | Q.NewDbValue (_, Db.Db_TypeDecl _)
332 | Q.NewDbValue (_, Db.Db_Alias _)
333 | Q.NewType _ -> acc, elt
334 | Q.NewDbValue (label, Db.Db_Constraint (p, cstr)) ->
335 (match cstr with
336 | Db.C_Ordering e ->
337 let acc, (_, fe) = f acc (Ident.source "dbconstr", e) in
338 acc,
339 if e == fe then elt else
340 Q.NewDbValue (label, Db.Db_Constraint (p, Db.C_Ordering fe))
341 | Db.C_Validation e ->
342 let acc, (_, fe) = f acc (Ident.source "dbconstr", e) in
343 acc,
344 if e == fe then elt else
345 Q.NewDbValue (label, Db.Db_Constraint (p, Db.C_Validation fe))
346 | Db.C_Inclusion _ | Db.C_Inverse _ | Db.C_Private ->
347 acc, elt)
348 | Q.NewDbValue (label, Db.Db_Default (p, dflt)) ->
349 let acc, (_, fdflt) = f acc (Ident.source "dbdefault", dflt) in
350 acc,
351 if dflt == fdflt then elt else
352 Q.NewDbValue (label, Db.Db_Default (p, fdflt))
353 | Q.NewDbValue (label, Db.Db_Virtual (p, e)) ->
354 let acc, (_, fe) = f acc (Ident.source "dbdefault", e) in
355 acc,
356 if e == fe then elt else
357 Q.NewDbValue (label, Db.Db_Virtual (p, fe))
358 | Q.NewVal (label, se) ->
359 let acc, fse = List.fold_left_map_stable f acc se in
360 acc,
361 if se == fse then elt else
362 Q.NewVal (label, fse)
363 | Q.NewValRec (label, se) ->
364 let acc, fse = List.fold_left_map_stable f acc se in
365 acc,
366 if se == fse then elt else
367 Q.NewValRec (label, fse)
368
369 let fold_map_expr foldmap acc elt =
370 let f acc ((s, e) as c) =
371 let acc, fe = foldmap acc e in
372 acc,
373 if e == fe then c else
374 (s, fe)
375 in
376 fold_map_name_expr f acc elt
377
378 let map_name_expr map elt =
379 let f () bnd = (), map bnd in
380 snd (fold_map_name_expr f () elt)
381
382 let iter_name_expr f = make_iter fold_map_name_expr f
383
384 let fold_name_expr f = make_fold fold_map_name_expr f
385
386 let fold_expr f = make_fold fold_map_expr f
387 let map_expr f = make_map fold_map_expr f
388 let iter_expr f = make_iter fold_map_expr f
389
390 let fold_names f acc = function
391 | Q.NewVal (_,iel)
392 | Q.NewValRec (_,iel) -> List.fold_left (fun acc (ident,_) -> f acc ident) acc iel
393 | Q.Database (_,ident,_,_) -> f acc ident
394 | Q.NewDbValue _
395 | Q.NewType _ -> acc
396 end
397
398 module CodeExpr =
399 struct
400 let iter f c =
401 List.iter (fun ce -> Top.iter_expr f ce) c
402
403 let map f c =
404 List.map_stable (fun ce -> Top.map_expr f ce) c
405
406 let fold f acc c =
407 List.fold_left (fun acc ce -> Top.fold_expr f acc ce) acc c
408
409 let fold_name_expr f acc c =
410 List.fold_left (fun acc ce -> Top.fold_name_expr f acc ce) acc c
411
412 let fold_names f acc c =
413 List.fold_left (Top.fold_names f) acc c
414
415 let fold_map_name_expr f acc c =
416 List.fold_left_map_stable (fun acc ce -> Top.fold_map_name_expr f acc ce) acc c
417
418 let map_name_expr f c =
419 List.map (fun ce -> Top.map_name_expr f ce) c
420
421 let fold_map f acc c =
422 List.fold_left_map_stable (fun acc ce -> Top.fold_map_expr f acc ce) acc c
423
424 let iter_with_code_elt f c =
425 List.iter (fun ce -> Top.iter_expr (fun e -> f ce e) ce) c
426
427 let exists f c =
428 try iter (fun e -> if f e then raise Exit) c; false
429 with Exit -> true
430 end
431
432 module Code =
433 struct
434 let filter_binding f code =
435 List.filter_map
436 (function
437 | Q.NewVal (label, iel) -> (
438 match List.filter f iel with
439 | [] -> None
440 | l -> Some (Q.NewVal (label, l))
441 )
442 | Q.NewValRec (label, iel) -> (
443 match List.filter f iel with
444 | [] -> None
445 | l -> Some (Q.NewValRec (label, l))
446 )
447 | c -> Some c) code
448 let iter_binding f code =
449 List.iter
450 (function
451 | Q.NewValRec (_,iel)
452 | Q.NewVal (_,iel) ->
453 List.iter f iel
454 | _ -> ()) code
455 end
456
457 module Pattern =
458 struct
00818f9 [refactor] removing most typing directives sooner
Valentin Gatien-Baron authored
459 module S2 =
460 struct
461 type 'a t = QmlAst.pat constraint 'a = _ * _ * _
462 let foldmap tra acc input_p =
463 match input_p with
464 | Q.PatConst _ | Q.PatVar _ | Q.PatAny _ -> acc, input_p
465 | Q.PatRecord (label, fields, rowvar) ->
466 let acc, fields' =
467 List.fold_left_map_stable
468 (fun acc ((f,p) as c) ->
469 let acc, p' = tra acc p in
470 if p == p' then acc, c else acc, (f,p')
471 ) acc fields in
472 if fields == fields' then
473 acc, input_p
474 else
475 acc, Q.PatRecord (label, fields', rowvar)
476 | Q.PatCoerce (label, pat, t) ->
477 let acc, pat' = tra acc pat in
478 if pat == pat' then
479 acc, input_p
480 else
481 acc, Q.PatCoerce (label, pat', t)
482 | Q.PatAs (label, pat, id) ->
483 let acc, pat' = tra acc pat in
484 if pat == pat' then
485 acc, input_p
486 else
487 acc, Q.PatAs (label, pat', id)
488
489 let fold tra acc e = Traverse.Unoptimized.fold foldmap tra acc e
490 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
491 let map tra e = Traverse.Unoptimized.map foldmap tra e
492 end
fccc685 Initial open-source release
MLstate authored
493
00818f9 [refactor] removing most typing directives sooner
Valentin Gatien-Baron authored
494 include Traverse.Make2(S2)
fccc685 Initial open-source release
MLstate authored
495
496 let get_fields pat =
497 let rec top pat0 =
498 match pat0 with
499 | Q.PatRecord (_, fields, rowvar) -> Some (fields, rowvar = `open_)
500 | Q.PatCoerce (_, p, _) -> top p
501 | _ -> None
502 in top pat
503 end
504
505 module Expr =
506 struct
507 module S2 =
508 struct
509 type 'a t = QmlAst.expr constraint 'a = _ * _ * _
c197c0f Quentin Bourgerie [enhance] compiler: (big) Added more update and query node + added typin...
BourgerieQuentin authored
510
fccc685 Initial open-source release
MLstate authored
511 let foldmap tra acc input_e =
512 match input_e with
513 | Q.Directive (label, `hybrid_value, [e_client;e_server], z) ->
514 (* When we traverse this directive we traverse only the client value.
515 * Because this directive can be only on client code... *)
516 let acc, e_client' = tra acc e_client in
517 acc,
518 if e_client == e_client' then input_e else
519 Q.Directive (label, `hybrid_value, [e_client';e_server], z)
520 | Q.Directive (_, `hybrid_value, [_e_server], _) ->
521 acc, input_e
522 | Q.Directive (_, `hybrid_value, _, _) -> assert false
523 | Q.Const _
524 | Q.Ident _
525 | Q.Bypass _
526 -> acc, input_e
527 | Q.Directive (label, variant, exprs, tys) ->
528 let acc, exprs' = List.fold_left_map_stable tra acc exprs in
529 acc,
530 if exprs == exprs' then input_e else
531 Q.Directive (label, variant, exprs', tys)
532 | Q.LetIn (label, bnd, e) ->
533 let acc, bnd' =
534 List.fold_left_map_stable
535 (fun acc ((i, e) as p) ->
536 let acc, e' = tra acc e in
537 acc,
538 if e == e' then p else (i, e')
539 ) acc bnd in
540 let acc, e' = tra acc e in
541 acc,
542 if bnd == bnd' && e == e' then input_e else
543 Q.LetIn (label, bnd', e')
544 | Q.LetRecIn (label, bnd, e) ->
545 let acc, bnd' =
546 List.fold_left_map_stable
547 (fun acc ((i, e) as p) ->
548 let acc, e' = tra acc e in
549 acc,
550 if e == e' then p else (i, e')
551 ) acc bnd in
552 let acc, e' = tra acc e in
553 acc,
554 if bnd == bnd' && e == e' then input_e else
555 Q.LetRecIn (label, bnd', e')
556 | Q.Lambda (label, params, e) ->
557 let acc, e' = tra acc e in
558 acc,
559 if e == e' then input_e else
560 Q.Lambda (label, params, e')
561 | Q.Apply (label, e1, args) ->
562 let acc, e1' = tra acc e1 in
563 let acc, args' = List.fold_left_map_stable tra acc args in
564 acc,
565 if e1 == e1' && args == args' then input_e else
566 Q.Apply (label, e1', args')
567 | Q.Match (label, e, clist) ->
568 let acc, e' = tra acc e in
569 let acc, clist' =
570 List.fold_left_map_stable
571 (fun acc ((p,e) as rule_) ->
572 let acc, e' = tra acc e in
573 acc,
574 if e == e' then rule_ else (p, e')
575 ) acc clist in
576 acc,
577 if e == e' && clist == clist' then input_e else
578 Q.Match (label, e',clist')
579 | Q.Record (label, rl) ->
580 let acc, rl' =
581 List.fold_left_map_stable
582 (fun acc ((s,e) as bnd) ->
583 let acc, e' = tra acc e in
584 acc,
585 if e == e' then bnd else (s, e')
586 ) acc rl in
587 acc,
588 if rl == rl' then input_e else
589 Q.Record (label, rl')
590 | Q.Dot (label, e, field) ->
591 let acc, e' = tra acc e in
592 acc,
593 if e == e' then input_e else
594 Q.Dot (label, e', field)
595 | Q.ExtendRecord (label, field, e1, e2) ->
596 let acc, e1' = tra acc e1 in
597 let acc, e2' = tra acc e2 in
598 acc,
599 if e1 == e1' && e2 == e2' then input_e else
600 Q.ExtendRecord (label, field, e1', e2')
601 | Q.Coerce (label, e, ty) ->
602 let acc, e' = tra acc e in
603 acc,
604 if e == e' then input_e else
605 Q.Coerce (label, e', ty)
606 | Q.Path (label, p, kind) ->
607 let acc, p' =
608 List.fold_left_map_stable
609 (fun acc e1 ->
610 match e1 with
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
611 | Q.Db.ExprKey e2 ->
fccc685 Initial open-source release
MLstate authored
612 let acc, e2' = tra acc e2 in
613 acc,
614 if e2 == e2' then e1 else
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
615 Q.Db.ExprKey e2'
fccc685 Initial open-source release
MLstate authored
616 | _ -> acc, e1) acc p in
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
617 let acc, kind' =
618 match kind with
619 | Q.Db.Update u ->
620 let rec update acc u =
621 match u with
c197c0f Quentin Bourgerie [enhance] compiler: (big) Added more update and query node + added typin...
BourgerieQuentin authored
622 | QmlAst.Db.UPop | QmlAst.Db.UShift
623 | QmlAst.Db.UIncr _ -> acc, u
624 | QmlAst.Db.UAppend e ->
625 let acc, e' = tra acc e in
626 acc,
627 if e == e' then u else QmlAst.Db.UAppend e'
628 | QmlAst.Db.UPrepend e ->
629 let acc, e' = tra acc e in
630 acc,
631 if e == e' then u else QmlAst.Db.UPrepend e'
632 | QmlAst.Db.UAppendAll e ->
633 let acc, e' = tra acc e in
634 acc,
635 if e == e' then u else QmlAst.Db.UAppendAll e'
636 | QmlAst.Db.UPrependAll e ->
637 let acc, e' = tra acc e in
638 acc,
639 if e == e' then u else QmlAst.Db.UPrependAll e'
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
640 | QmlAst.Db.UExpr e ->
641 let acc, e' = tra acc e in
642 acc,
6ada700 Quentin Bourgerie [enhance] compiler: added query ast + add node to update ast
BourgerieQuentin authored
643 if e == e' then u else QmlAst.Db.UExpr e'
c197c0f Quentin Bourgerie [enhance] compiler: (big) Added more update and query node + added typin...
BourgerieQuentin authored
644 | QmlAst.Db.UFlds fields ->
6ada700 Quentin Bourgerie [enhance] compiler: added query ast + add node to update ast
BourgerieQuentin authored
645 let acc, fields' =
646 List.fold_left_map_stable
647 (fun acc ((f,u) as bnd) ->
648 let acc, u' = update acc u in
649 acc,
650 if u == u' then bnd else (f, u')
651 ) acc fields in
652 acc,
c197c0f Quentin Bourgerie [enhance] compiler: (big) Added more update and query node + added typin...
BourgerieQuentin authored
653 if fields == fields' then u else QmlAst.Db.UFlds fields'
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
654 in
655 let acc, u' = update acc u in
656 acc,
657 if u == u' then kind
658 else QmlAst.Db.Update u'
659 | e -> acc, e in
fccc685 Initial open-source release
MLstate authored
660 acc,
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
661 if p == p' && kind == kind' then input_e else
662 Q.Path (label, p', kind')
fccc685 Initial open-source release
MLstate authored
663
664 let fold tra acc e =
665 match e with
666 | Q.Const _
667 | Q.Ident _
668 | Q.Bypass _ -> acc
669
670 | Q.Coerce (_, e, _)
671 | Q.Dot (_, e, _)
672 | Q.Lambda (_, _, e) -> tra acc e
673
674 | Q.ExtendRecord (_, _,e1, e2) -> tra (tra acc e1) e2
675
676 | Q.Apply (_, f, args) ->
677 let acc = tra acc f in
678 List.fold_left tra acc args
679
680 | Q.LetIn (_, bnd, e)
681 | Q.LetRecIn (_, bnd, e) ->
682 let acc =
683 List.fold_left
684 (fun acc (_,e) -> tra acc e) acc bnd in
685 tra acc e
686 | Q.Match (_, e, clist) ->
687 let acc = tra acc e in
688 List.fold_left
689 (fun acc (_,e) -> tra acc e)
690 acc clist
691 | Q.Record (_, rl) ->
692 List.fold_left
693 (fun acc (_,e) -> tra acc e) acc rl
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
694 | Q.Path (_, p, kind) ->
695 let acc =
696 List.fold_left
697 (fun acc -> function
698 | Q.Db.ExprKey e2 -> tra acc e2
699 | _ -> acc) acc p
700 in
701 let acc = match kind with
702 | Q.Db.Update u ->
703 let rec update acc u =
704 match u with
c197c0f Quentin Bourgerie [enhance] compiler: (big) Added more update and query node + added typin...
BourgerieQuentin authored
705 | QmlAst.Db.UPop | QmlAst.Db.UShift | QmlAst.Db.UIncr _ -> acc
706 | QmlAst.Db.UAppend e
707 | QmlAst.Db.UPrepend e
708 | QmlAst.Db.UAppendAll e
709 | QmlAst.Db.UPrependAll e
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
710 | QmlAst.Db.UExpr e -> tra acc e
c197c0f Quentin Bourgerie [enhance] compiler: (big) Added more update and query node + added typin...
BourgerieQuentin authored
711 | QmlAst.Db.UFlds fields ->
6ada700 Quentin Bourgerie [enhance] compiler: added query ast + add node to update ast
BourgerieQuentin authored
712 List.fold_left
713 (fun acc (_,u) -> update acc u)
714 acc fields
28521d4 Quentin Bourgerie [enhance] compiler: (big) Added Update Ast, Added plain node, Added more...
BourgerieQuentin authored
715 in update acc u
716 | _ -> acc
717 in acc
fccc685 Initial open-source release
MLstate authored
718 | Q.Directive (_, _, exprs, _) -> List.fold_left tra acc exprs
719
720 let iter tra e = Traverse.Unoptimized.iter foldmap tra e
721 let map tra e = Traverse.Unoptimized.map foldmap tra e
722 end
723 include Traverse.Make2(S2)
724
725 let fold_with_env add_env env folder acc expr =
726 let isrec = function
727 | Q.LetIn _ -> false
728 | Q.LetRecIn _ -> true
729 | _ -> assert false in
730 let add_bnd env (n,expr) = add_env env n (Some expr) in
731 let add_lambda env n = List.fold_left (fun env n -> add_env env n None) env n in
732 let add_pat pat env =
733 Pattern.fold_down (* TODO: OPTIMIZE IT *)
734 (fun env pat->
735 match pat with
736 | Q.PatVar (_, v) | Q.PatAs (_,_,v) -> add_env env v None
737 | _ -> env
738 ) env pat in
739 let rec process_expr tra env acc expr =
740 let acc = folder env acc expr in
741 let orig_e0 = expr in
742 match orig_e0 with
743 | Q.Lambda (_, ids, expr) ->
744 process_expr tra (add_lambda env ids) acc expr
745 | Q.LetIn (_, bnd, expr)
746 | Q.LetRecIn (_, bnd, expr) ->
747 let env_bnd = List.fold_left add_bnd env bnd in
748 let env_let = if isrec orig_e0 then env_bnd else env in
749 let acc = List.fold_left (fun acc (_,expr) -> process_expr tra env_let acc expr) acc bnd in
750 process_expr tra env_bnd acc expr
751 | Q.Match (_, expr, clist) ->
752 let acc = process_expr tra env acc expr in
753 List.fold_left (fun acc rule_ -> process_pattern_expr tra env acc rule_) acc clist
754 | _ -> tra env acc expr
755 and process_pattern_expr tra env acc (pat,expr) =
756 let env_bnd = add_pat pat env in
757 process_expr tra env_bnd acc expr in
758 traverse_fold_context_down process_expr env acc expr
759
760 let fold_with_exprmap ?(env=IdentMap.empty) f a e =
761 fold_with_env (fun map id optval -> IdentMap.add id optval map) env f a e
762
763 end
764
765 module ExprPatt = struct
766 let iter_down f_expr f_pat =
767 Expr.iter_down
768 (fun e ->
769 f_expr e;
770 match e with
771 | Q.Match (_, _, clst) -> List.iter (fun (p, _e) -> Pattern.iter_down f_pat p) clst
772 | _ -> ())
773 let iter = iter_down
774
775 let extend_pat f_expr f_pat acc e =
776 let acc, e = f_expr acc e in
777 match e with
778 | Q.Match (label, x, clst) ->
779 let acc, clst = List.fold_left_map
780 (fun acc (p, e) ->
781 let acc, p = Pattern.foldmap_down f_pat acc p
782 in acc, (p, e)) acc clst in
783 acc, Q.Match (label, x, clst)
784 | e0 -> acc, e0
785
786 let foldmap_down f_expr f_pat = Expr.foldmap_down (extend_pat f_expr f_pat)
787 let foldmap = foldmap_down
788
789 let map_down f_expr f_pat = make_map Expr.foldmap_down (rm_void_acc (extend_pat (add_void_acc f_expr) (add_void_acc f_pat)))
790 let map = map_down
791
792 let fold_down f_expr f_pat a e =
793 let f_expr a e = (f_expr a e, e)
794 and f_pat a p = (f_pat a p, p) in
795 fst (foldmap_down f_expr f_pat a e)
796 let fold = fold_down
797 end
798
799 (** todo : return an expr0 option instead of saying just yes or no will upgrade error messages *)
800 module UseDb =
801 struct
802 let expr expr =
803 let use_db = function
804 | Q.Path _ ->
805 true
806 (* FIXME: what about library calls that need the DB ? *)
807 | _ ->
808 false
809 in
810 Expr.exists_down use_db expr
811
812 let code_elt ?(ignore_declaration=false) = function
813 | Q.Database _
814 | Q.NewDbValue _ -> not ignore_declaration
815 | Q.NewType _ -> false
816 | Q.NewVal (_, v)
817 | Q.NewValRec (_, v) -> List.exists (fun (_, e) -> expr e) v
818
819 let code ?(ignore_declaration=false) code =
820 List.exists (code_elt ~ignore_declaration) code
821 end
822
823 module Misc =
824 struct
825 let rec remove_coerce = function
826 | Q.Coerce (_, x, _) -> remove_coerce x
827 | x -> x
828
829 let code_size code = CodeExpr.fold (fun acc e -> Expr.fold (fun acc _ -> acc + 1) acc e) 0 code
830 end
Something went wrong with that request. Please try again.