Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 971 lines (888 sloc) 35.961 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 FIXME: talk about the dependencies
20 MAKE SEPARATE PARTS MORE DISTINCTS, PROVIDE A REAL SIGNATURE
21
22 This module contains functions that regroup recursive values in groups, eg:
23 - in the source code:
24 [f1() = f3()
25 f2() = f1()
26 f3() = f1()]
27 - after parsing:
28 [NewVal [(f1,f3())];
29 NewVal [(f2,f1())];
30 NewVal [(f3,f1())]]
31 - after dependency analysis
32 [NewVal [(f1,f3()); (f3,f1())];
33 NewVal [(f2,f1())]]
34
35 It also contains functions that rewrite modules:
36 - in the source code:
37 [{{ x() = y(); y() = x() }}]
38 - after renaming:
39 [{ x = @local(x', {} -> y'({}));
40 y = @local(y', {} -> x'({})) }]
41 - after rewrite:
42 [ rec x' = {} -> y'({})
43 and y' = {} -> x'({})
44 { x = x'; y = y'} ]
45 If your module contains submodules, then their fields will go out too:
46 - source code:
47 [{{ x = {{ x2 = 1 }} }}]
48 - after rewrite:
49 [ x2' = 1;
50 x' = { x2 = x2' }
51 { x = x' } ]
52 This is useless here, but useful when you have recursive modules that
53 call each other's submodules
54 *)
55
56 (* HACK : please, clean-up in opa lang *)
57 module Parser_utils = OpaParserUtils
58
59 (* depends *)
60 module List = BaseList
61 module String = BaseString
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new quer...
BourgerieQuentin authored
62 module DbAst = QmlAst.Db
fccc685 Initial open-source release
MLstate authored
63
64 (* TODO remove *)
65 open SurfaceAst
66
67 (* shorthands *)
68 module SAH = SurfaceAstHelper
69 module C = SurfaceAstCons.ExprIdentCons
70 module D = SurfaceAstDecons
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new quer...
BourgerieQuentin authored
71
fccc685 Initial open-source release
MLstate authored
72 let copy_label = Parser_utils.copy_label
73
74 let (|>) = InfixOperator.(|>)
75 let ( @> ) f g x = x |> f |> g
76
77
78 (* debug *)
79 let pp_code_elt f (code_elt_node,annot) =
80 Format.fprintf f "%d -> %a@\n"
81 annot.QmlLoc.notes
82 OpaPrint.ident#code_elt_node code_elt_node
83 let pp_code f l =
84 List.iter (pp_code_elt f) l;
85 Format.pp_print_flush f ()
86 let pp_set f s =
87 IntSet.iter (fun i -> Format.fprintf f "%d " i) s;
88 Format.fprintf f "@\n%!"
89
90
91 (*
92 (* For incremental, to detect quickly if a value has changed *)
93 type hash = unit
94 *)
95
96 (* for now just use fields by fields
97 latter group (multi-pattern) of group (record pattern) of fields *)
98
99 (* [ match l with
100 | {nil} ->
101 | {hd tl} -> ... ]
102 gives [[[nil],[hd,tl]], i guess *)
103
104 type fields_group = string list list
105 type fields = fields_group
106 module FieldsOrd = struct type t = fields let compare = compare end
107 module FieldsMap = BaseMap.Make(FieldsOrd)
108
109 (**
110 In [/a/b/c], db_root would be [a]
111 *)
112 type db_root = string
113
114 type 'a gen_dep_context =
115 { vals : (Ident.t * Ident.t ty option) list
116 ; types : Ident.t list
117 ; fields_groups : fields_group list
118 ; db_roots : db_root list
119 ; database : bool
120 ; other: 'a }
121 let empty_gen_dep_context other =
122 { vals = []
123 ; types = []
124 ; fields_groups = []
125 ; db_roots = []
126 ; database = false
127 ; other = other }
128
129 (* FIXME: real merge? *)
130 let merge_vals l1 l2 = l1 @ l2
131 let merge_types l1 l2 = l1 @ l2
132 let merge_fields_groups l1 l2 = l1 @ l2
133 let merge_db_roots l1 l2 = l1 @ l2
134 let merge_database b1 b2 = b1 || b2
135
136 let merge_context merge_other context1 context2 =
137 { vals = merge_vals context1.vals context2.vals
138 ; types = merge_types context1.types context2.types
139 ; fields_groups = merge_fields_groups context1.fields_groups context2.fields_groups
140 ; db_roots = merge_db_roots context1.db_roots context2.db_roots
141 ; database = merge_database context1.database context2.database
142 ; other = merge_other context1.other context2.other }
143 let merge_contexts merge_other empty_context contexts =
144 List.fold_left (merge_context merge_other) empty_context contexts
145
146 (* FIXME: collision, or duplicates? *)
147 (* should be consistent with merge *)
148 let add_root s context = {context with db_roots = s :: context.db_roots}
149 let add_group g context = {context with fields_groups = g :: context.fields_groups}
150 let add_type t context = {context with types = t :: context.types}
151 let add_types ts context = {context with types = ts @ context.types}
152 let add_val v context = {context with vals = (v,None) :: context.vals}
153 let add_vals vs context = {context with vals = List.map (fun v -> v,None) vs @ context.vals}
154 let add_database context = {context with database = true}
155
156 (* will contain what is used by a declaration,
157 a declaration may contain many values *)
158 type directive_dep = [ `magic_tostring | `magic_to_xhtml ]
159 type dep = directive_dep list
160 type dep_context = dep gen_dep_context
161 let empty_dep_context = empty_gen_dep_context []
162 let merge_dep_other = (@)
163 let merge_dep_context = merge_context merge_dep_other
164 let merge_dep_contexts = merge_contexts merge_dep_other empty_dep_context
165
166 let db_root_of_path l =
167 match l with
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new quer...
BourgerieQuentin authored
168 | (DbAst.Decl_fld s) :: _ -> s
fccc685 Initial open-source release
MLstate authored
169 | _ -> assert false
170
171 let directive_dependencies filter acc v =
172 let dir_to_str_fun v =
173 match v with
174 | `magic_to_string -> Opacapi.magicToString
175 | `magic_to_xml -> Opacapi.magicToXml
176 | `fun_action -> Opacapi.FunActionServer.serialize_argument in
177 match v with
178 | ( `magic_to_string
179 | `magic_to_xml
180 | `fun_action) as v ->
181 let str = dir_to_str_fun v in
debb5ea [cleanup] Base: remove error
Raja authored
182 let id = try OpaMapToIdent.val_noerr str with Not_found -> failwith (Printf.sprintf "Please define %s." str) in
fccc685 Initial open-source release
MLstate authored
183 begin match filter with
184 | None -> add_val id acc
185 | Some f when f id -> add_val id acc
186 | _ -> acc
187 end
188 | _ -> acc
189
190 let get_pat_dep_context acc p =
191 OpaWalk.Pattern.fold
192 (fun acc -> function
193 | (PatCoerce (_,ty),_) ->
194 let typenames = OpaWalk.Type.get_typenames_with_acc acc.types ty in
195 {acc with types = typenames}
196 | _ -> acc) acc p
197
198 (**
199 [get_expr_dep_context] gives the toplevel direct dependencies of an
200 expression
201 The environment contains the identifiers in scope (both types and values)
202 but not the toplevel ones
203 *)
204 let get_expr_dep_context ?filter e =
205 SurfaceAstTraversal.Expr.traverse_fold_with_set
206 (fun env acc (e, _label) ->
207 let acc =
208 match e with
209 (* nothing special for bindings except that the environment
210 * grows but this is already taken care of the fold_with_env
211 * function *)
212 | LetIn _
213 | Apply _
214 | Const _
215 | Bypass _ -> acc
216
217 | Lambda (spl,_) ->
218 (match filter with
219 | None ->
220 List.fold_left (fun acc (_,p) -> get_pat_dep_context acc p) acc spl
221 | Some _ -> acc)
222 | Match (_e,pel) ->
223 (match filter with
224 | None ->
225 List.fold_left (fun acc (p,_) -> get_pat_dep_context acc p) acc pel
226 | Some _ -> acc)
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new quer...
BourgerieQuentin authored
227 | DBPath (dbelt, _) ->
fccc685 Initial open-source release
MLstate authored
228 let acc = Option.if_none filter (add_database acc) acc in
229 (* taking the first elt of the path *)
230 ( match (fst (List.hd (fst dbelt))) with
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new quer...
BourgerieQuentin authored
231 | DbAst.FldKey s -> Option.if_none filter (add_root s acc) acc
232 | DbAst.NewKey
233 | DbAst.ExprKey _ | DbAst.Query _ ->
fccc685 Initial open-source release
MLstate authored
234 (* not possible, see the parser *)
235 assert false
236 )
237 | Record l ->
238 Option.if_none filter (add_group [SAH.Record.field_names l] acc) acc
239 | ExtendRecord (l, _e) ->
240 Option.if_none filter (add_group [SAH.Record.field_names l] acc) acc
241 | Dot (_,s) ->
242 Option.if_none filter (add_group [[s]] acc) acc
243 | Ident i ->
244 if not (IdentSet.mem i env) then
245 match filter with
246 | None -> add_val i acc
247 | Some f when f i -> add_val i acc
248 | _ -> acc
249 else
250 acc
251 | Directive (variant, _, tyl) -> (
252 let acc = directive_dependencies filter acc variant in
253 match filter with
254 | None ->
255 let typenames = List.fold_left OpaWalk.Type.get_typenames_with_acc acc.types tyl in
256 {acc with types = typenames}
257 | Some _ -> acc
258 ) in
259 env, acc
260 ) empty_dep_context e
261
262
263 (**
264 [get_local_expr_dep_context] is used when you don't want all the
265 dependencies of an expression but only dependencies on the identifiers
266 present in the set [names]
267 it allows you to reorder/split a set of mutually recursive bindings
268 *)
269 let get_local_expr_dep_context names expr =
270 let filter i = List.exists (fun j -> Ident.equal i j) names in
271 get_expr_dep_context ~filter expr
272
273 (**
274 [get_code_elt_dep_context] gives you the toplevel dependencies of a code_elt
275 *)
276 let get_code_elt_dep_context (code_elt_node, _label) =
277 match code_elt_node with
278 | Database _ ->
279 empty_dep_context
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new quer...
BourgerieQuentin authored
280 | NewDbDef (DbAst.Db_TypeDecl ([_], ty)) ->
fccc685 Initial open-source release
MLstate authored
281 (* db /map does not depend on /map, it defines it
282 * on the other hand, db /map[_] = 2 does depend
283 *)
284 { empty_dep_context with
285 types = OpaWalk.Type.get_typenames ty }
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new quer...
BourgerieQuentin authored
286 | NewDbDef (DbAst.Db_TypeDecl (sl, ty)) ->
fccc685 Initial open-source release
MLstate authored
287 { empty_dep_context with
288 db_roots = [db_root_of_path sl];
289 types = OpaWalk.Type.get_typenames ty }
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new quer...
BourgerieQuentin authored
290 | NewDbDef (DbAst.Db_Default (p, _)
291 | DbAst.Db_Constraint (p, _)
292 | DbAst.Db_Alias (_, p)
293 | DbAst.Db_Virtual (p, _) as db_def) ->
294 fst(DbAst.foldmap_expr
fccc685 Initial open-source release
MLstate authored
295 (fun dep_context e -> merge_dep_context (get_expr_dep_context e) dep_context, e)
296 {empty_dep_context with db_roots = [db_root_of_path p]}
297 db_def)
298 | NewType tds ->
299 let contexts =
300 List.map
301 (fun (ty_def, _) ->
302 { empty_dep_context with
303 types =
304 OpaWalk.Type.get_typenames ty_def.SurfaceAst.ty_def_body })
305 tds in
306 merge_dep_contexts contexts
307 | NewVal (pel,_) ->
308 let contexts = List.map (snd @> get_expr_dep_context) pel in
309 merge_dep_contexts contexts
310 | Package _ -> assert false
311
312 (* contains what a declaration has to offer *)
313 type api = unit
314 type api_context = api gen_dep_context
315 let empty_api_context = empty_gen_dep_context ()
316 let merge_api_other _ _ = ()
317 let merge_api_context = merge_context merge_api_other
318 let merge_api_contexts = merge_contexts merge_api_other empty_api_context
319
320 (**
321 [get_code_elt_api_context] gives you what is provided by a code_elt
322 *)
323 let get_code_elt_api_context ((code_elt_node, _label) as code_elt) =
324 match code_elt_node with
325 | Database (ident,_,_) ->
326 {empty_api_context with vals = [(ident,None)]}
91ab51e @BourgerieQuentin [enhance] compiler: (big) improve path parser + opalang handles new quer...
BourgerieQuentin authored
327 | NewDbDef (DbAst.Db_TypeDecl (p, _)) ->
fccc685 Initial open-source release
MLstate authored
328 (* all the [db /map/...] define the root '/map'
329 * or else in [ db /map/a : string
330 * db /map/b : string ], '/map' is never defined
331 *)
332 {empty_api_context with db_roots = [db_root_of_path p]; database = true}
333 | NewDbDef _ ->
334 {empty_api_context with database = true}
335 | NewType tds ->
336 let typenames =
337 List.map
338 (fun ({ SurfaceAst.ty_def_name = Typeident i ; _ }, _) -> i) tds in
339 {empty_api_context with types = typenames}
340 | NewVal _ ->
341 let idents =
342 OpaWalk.CodeEltTopPattern.fold_nonrec
343 (fun acc p -> OpaWalk.Pattern.get_vars ~acc p)
344 []
345 code_elt in
346 {empty_api_context with vals = List.map (fun p -> (p,None)) idents}
347 | Package _ -> assert false
348
349 (**
350 These maps map identifiers to an int that identifies the declaration
351 that defines them
352 the int is chosen to be the number in the annot of the code_elt
353
354 Used to compute deps from api_context
355 *)
356 type context_linker_cache =
357 int IdentMap.t (* identifiers *)
358 * int IdentMap.t (* type identifiers *)
359 * int list StringMap.t (* for db_roots
360 * a list is needed because a db root may be defined by several declarations *)
361 * int FieldsMap.t
362 * int list (* the list of identifiers that provide the database *)
363
364 let empty_context_linker_cache : context_linker_cache =
365 (IdentMap.empty, IdentMap.empty, StringMap.empty, FieldsMap.empty, [])
366
367 let get_context_linker_cache_input lcode =
368 List.map
369 (function ((_,annot) as code_elt) ->
370 annot.QmlLoc.notes, get_code_elt_api_context code_elt
371 ) lcode
372
373 let get_get_deps_input lcode =
374 List.map
375 (function ((_,annot) as code_elt) ->
376 annot.QmlLoc.notes, get_code_elt_dep_context code_elt
377 ) lcode
378
379 let context_linker_cache iapis : context_linker_cache =
380 List.fold_left
381 (fun (idents,types,db_roots,fields,database) (i,api) ->
382 List.fold_left (fun idents (ident,_) -> IdentMap.safe_add ident i idents) idents api.vals,
383 List.fold_left (fun types ident -> IdentMap.safe_add ident i types) types api.types,
384 List.fold_left (fun db_roots db_root ->
385 let prev = Option.default [] (StringMap.find_opt db_root db_roots) in
386 StringMap.add db_root (i :: prev) db_roots
387 ) db_roots api.db_roots,
388 List.fold_left (fun fields g -> FieldsMap.safe_add g i fields) fields api.fields_groups,
389 (if api.database then i :: database else database)
390 ) empty_context_linker_cache iapis
391
392 let identmap_find i m =
393 match IdentMap.find_opt i m with
394 | None ->
395 OManager.i_error "SurfaceAstDependencies.identmap_find: %s\n%!" (Ident.to_string i)
396 | Some v -> v
397
398 let get_deps ((vals,types,db_roots,_fields,database):context_linker_cache) ideps =
399 List.map
400 (fun (i,dep_context) ->
401 let set = IntSet.empty in
402 let set =
403 List.fold_left
404 (fun set (ident, _tyo) ->
405 match IdentMap.find_opt ident vals with
406 | None -> set
407 | Some v -> IntSet.add v set
408 ) set dep_context.vals in
409 let set =
410 List.fold_left
411 (fun set type_ ->
412 match IdentMap.find_opt type_ types with
413 | None -> set
414 | Some v -> IntSet.add v set
415 ) set dep_context.types in
416 let set =
417 List.fold_left
418 (fun set db_root ->
419 match StringMap.find_opt db_root db_roots with
420 | None ->
421 (* an expression is using an undefined db root
422 * this is a mistake, but someone else will take care of it *)
423 set
424 | Some v -> IntSet.add_list v set
425 ) set dep_context.db_roots in
426 let set =
427 if dep_context.database then
428 IntSet.add_list database set
429 else
430 set in
431
432 (*
433 * Here nobody defines so these dependencies are not likely to be resolved
434 * fields
435 * when NewType
436 *)
437 (* FIXME when the comment below is taken care of somewhere else
438 let set =
439 List.fold_left
440 (fun set field ->
441 IntSet.add (FieldsMap.find field fields) set
442 ) set dep_context.fields in*)
443 (i, set)
444 ) ideps
445
446
447 (**
448 create the map that map the number of a declaration to the declaration
449 itself
450 *)
451 let map_back lcode =
452 List.fold_left
453 (fun map ((_,annot) as code_elt) ->
454 IntMap.add annot.QmlLoc.notes code_elt map
455 ) IntMap.empty lcode
456
457 (**
458 When given a list of code_elt, gives back the list where all newval
459 are regrouped into one newval and put it last in the list
460 *)
461 (* trying to not screw up completely the positions with the 'pos' *)
462 let rec special_flatten isrec (pos,vals,types,others) l =
463 match l with
464 | [] ->
465 let vals =
466 match vals with
467 | [] -> []
468 | [_] when not isrec -> [(NewVal (vals,false), Parser_utils.annot pos)]
469 | _ -> [(NewVal (vals,true), Parser_utils.annot pos)] in
470 let types =
471 match types with
472 | [] -> []
473 | _ -> [(NewType types, Parser_utils.annot pos)] in
474 others @ types @ vals
475 | ((c,{QmlLoc.pos=pos2; _}) as h) :: t ->
476 match c with
477 | Package _ -> assert false
478 | Database _
479 | NewDbDef _ -> special_flatten isrec (pos, vals, types, h :: others) t
480 | NewType tds ->
481 let pos = FilePos.merge_pos pos pos2 in
482 special_flatten isrec (pos, vals, tds @ types, others) t
483 | NewVal (l,_) ->
484 let pos = FilePos.merge_pos pos pos2 in
485 special_flatten isrec (pos, l @ vals, types, others) t
486 let special_flatten (isrec,l) =
487 special_flatten isrec (FilePos.nopos "SurfaceAstDependencies.special_flatten", [], [], []) l
488
489
490 let debug _s _f _x =
491 #<If:SA_DEPENDENCIES>
492 Format.printf "----- %s ------@\n%a%!" _s _f _x
493 #<End>
494
495 let flatten_newval_newtype code =
496 let aux = function
497 | (NewType typedefs, label) ->
498 List.map (fun td -> (NewType [td], Parser_utils.copy_label label)) typedefs
499 | (NewVal (pel,rec_),label) ->
500 (* actually the rec_ flag doesn't matter *)
501 List.map (fun bnd -> (NewVal ([bnd], rec_), Parser_utils.copy_label label)) pel
502 | c -> [c] in
503 List.concat_map aux code
504
505 (**
506 This function reorders the toplevel
507
508 Take the function that computes the transivite closure of the dependency
509 relation as an argument because doing otherwise would (for now) create
510 circular dependencies between libraries
511
512 *)
513 let reorder_toplevel ?roots create_groups lcode =
514 debug "reorder" pp_code lcode;
515 let lcode = flatten_newval_newtype lcode in
516 let iapis = get_context_linker_cache_input lcode in
517 let ideps = get_get_deps_input lcode in
518 let (vals,_,_,_,_) as context_linker_cache = context_linker_cache iapis in
519 let deps = get_deps context_linker_cache ideps in
520 debug "deps" (fun f l -> List.iter (fun (i,s) -> Format.fprintf f "%d -> %a" i pp_set s) l) deps;
521 let roots =
522 (* if we have roots that are not defined, we simply ignore them *)
523 Option.map (List.filter_map (fun i -> IdentMap.find_opt i vals)) roots in
524 let ((groups : (int * bool * IntSet.t) list),_) = create_groups ?roots deps in
525 debug "groups" (fun f l -> List.iter (fun (i,isrec,s) -> Format.fprintf f "%d(%B) -> %a" i isrec pp_set s) l) groups;
526 let map_back = map_back lcode in
527 let declss =
528 List.map
529 (fun (_repr,isrec,group) ->
530 isrec,IntSet.fold (fun i acc -> IntMap.find i map_back :: acc) group []
531 ) groups in
532 let lcode = List.concat_map special_flatten declss in
533 debug "end" pp_code lcode;
534 lcode
535
536 let safe_union s1 s2 =
537 let s = IdentSet.union s1 s2 in
538 assert (IdentSet.cardinal s1 + IdentSet.cardinal s2 = IdentSet.cardinal s);
539 s
540
541 let get_all_deps get_var_set bindings =
542 let names, exprs = List.split bindings in
543 let possible_deps =
544 names
545 |> List.map get_var_set
546 |> List.flatten in (* UNICITY: safe union *)
547 assert (List.length possible_deps = List.length (List.uniq_unsorted possible_deps));
548 List.map (get_local_expr_dep_context possible_deps) exprs
549
550 let regroup map_expr intset =
551 assert (IntSet.cardinal intset <> 0);
552 intset
553 |> IntSet.elements
554 |> List.map (fun i -> IntMap.find i map_expr)
555
556 (**
557 reorder a list of bindings the same way reorder_toplevel does
558 the bindings have the type ('a * expr) list, where 'a will be
559 either ident or pattern
560 use the functions below, that are already specialized for idents
561 and patterns
562 *)
563 let reorder_expr :
564 ('a -> Ident.t list)
565 -> _ -> ('a * (_,_) expr) list -> (('a * (_,_) expr) list * bool) list =
566 fun get_var_set create_group_list bindings ->
567 (* FIXME: too complicated for simple cases ? *)
568 let deps = get_all_deps get_var_set bindings in
569 let apis =
570 List.map
571 (fun (p,_) ->
572 let vars = get_var_set p in
573 add_vals vars empty_api_context
574 ) bindings in
575 let ideps = List.mapi (fun i x -> (i,x)) deps in
576 let iapis = List.mapi (fun i x -> (i,x)) apis in
577 let context_linker_cache = context_linker_cache iapis in
578 let deps = get_deps context_linker_cache ideps in
579 let groups, _final = create_group_list deps in
580 let bindings_with_int = List.mapi (fun i (name,e) -> (i,(name,e))) bindings in
581 let map_expr = IntMap.from_list bindings_with_int in
582 groups
583 |> List.map (fun (_id,isrec,group) -> regroup map_expr group,isrec)
584
585 (**
586 takes the Reordering.create_group_list, a list of (pattern * expr)
587 and gives a list of list of (pattern * expr), representing groups of
588 mutually dependent bindings
589 *)
590 let reorder_for_pat_bindings x =
591 reorder_expr OpaWalk.Pattern.get_vars x
592 (**
593 same as above, with (ident * expr) list
594 *)
595 let reorder_for_ident_bindings x y =
596 reorder_expr (fun x -> [x]) x y
597
598
599 (**
600 Module are encoded as Record l where l is a list of @local directives
601 by the renaming pass
602 The `local constructor contains the name that is used by other fields
603 to refer to the present one.
604
605 For example, the ast of [{{ x = 2 y = x }}] is:
606 Record ([("x", (Directive (`local x', [(Const (Int 2), _)], _),_));
607 ("y", (Directive (`local y', [(Ident x', _)], _), _))])
608
609 This functions gives you the list of (field * identifier * position * expression)
610 With the previous example, it would be:
611 [("x", x', _, (Const (Int 2), _));
612 ("y", y', _, (Ident x', _))]
613 *)
614
615 let extract_field_ident_expr_from_module e =
616 let reannotate = OpaToQml.propagate_slicer_annotation e in
617 let e, acc, coercer =
618 D.FoldContext.letin
619 ~through:[D.Context.Basic.slicer_directive;
620 D.Context.Basic.opacapi;
621 D.Context.Basic.coerce;
622 D.Context.Basic.doctype] e in
623 let acc = List.map (fun (i,e) -> (i, reannotate e)) acc in
624 match e with
625 | (Directive (`module_, [(Record l,label_record)], b),c) ->
626 let l =
627 List.map
628 (fun (s,e') ->
629 match e' with
630 | (Directive (`local ident, [e''], _),label) ->
631 s, ident, label, reannotate e''
632 | _ ->
633 Format.printf "@[<v2>Error:@ @[%a@],@ @[%a@],@ %s@]@."
634 OpaPrint.ident#expr e'
635 OpaPrint.ident#expr e
636 (SAH.Annot.to_string' e');
637 assert false
638 ) l
639 in
640 (* putting the @module directive under the coercions *)
641 l, label_record, acc, (fun e -> coercer (Directive (`module_, [e], b),c))
642 | _ ->
643 Printf.printf
644 "Not a record through letins at %s\n%!" (SAH.Annot.to_string' e);
645 assert false
646
647 (**
648 gives a mapping from field to the ident bound to its content
649 (see comment above for more details)
650 *)
651 let is_private e = D.Look.private_ ~through:[D.Remove.Basic.doctype; D.Remove.Basic.opacapi; D.Remove.Basic.slicer_directive] e
652 type access =
653 | Possible (* normal module field *)
654 | Forbidden (* field tagged as private *)
655 let module_assoc e =
656 let l, _, _, _ = extract_field_ident_expr_from_module e in
657 List.map
658 (fun (s,ident,_,e) ->
659 (s, ((if is_private e then Forbidden else Possible), ident))
660 ) l
661
662 let is_module e =
663 D.Look.module_local
664 ~through:[D.Remove.Basic.slicer_directive
665 ;D.Remove.Basic.coerce
666 ;D.Remove.Basic.letin
667 ;D.Remove.Basic.doctype
668 ;D.Remove.Basic.opacapi
8edc001 [feature] adding: an @async directive on bindings to perform asynchronou...
Valentin Gatien-Baron authored
669 ;D.Remove.Basic.async
fccc685 Initial open-source release
MLstate authored
670 ] e
671
672 (**
673 makes a mapping from identiers to an association list of (field * ident)
674 from the identifiers in the list given whose value is a module
675 (only does so for direct modules, not modules that are fields of other modules)
676 *)
677 let module_names ident_expr_list =
678 let assoc =
679 List.filter_map
680 (fun (i,e) ->
681 if is_module e then
682 let assoc = module_assoc e in
683 Some (i,assoc)
684 else
685 None
686 ) ident_expr_list
687 in
688 IdentMap.from_list assoc
689
690 (**
691 simplifies a path [ident.field1.field2] with [ident1.field2]
692 if the map in argument contains a mapping from ident to l, and l (an
693 association list) contains a mapping from [field1] to [ident1]
694 This simplification is done recursively if possible
695 *)
696 let rec resolve_path :
697 _ ->
698 ((string * (access * Ident.t)) list IdentMap.t)
699 -> Ident.t -> (string * QmlLoc.annot) list
700 -> Ident.t * (string * QmlLoc.annot) list =
701 fun label map first_ident full_path ->
702 let rec aux i path =
703 match IdentMap.find_opt i map with
704 | None -> i, path
705 | Some assoc ->
706 match path with
707 | [] -> i, path
708 | (field,_) :: path_tail ->
709 match List.assoc_opt field assoc with
710 | None ->
711 OManager.serror
712 "@[<2>%s@\nThe field %s doesn't exist in the path %s.%s.@]@\n"
713 (SAH.Annot.to_string label)
714 field
715 (Ident.original_name first_ident)
716 (String.concat_map "." fst full_path);
717 i, path
718 | Some (access, ident) ->
719 (match access with
720 | Possible -> ()
721 | Forbidden ->
722 OManager.serror
723 "@[<2>%s@\nThe path %s.%s is invalid because the field %s is private.@]@\n"
724 (SAH.Annot.to_string label)
725 (Ident.original_name first_ident)
726 (String.concat_map "." fst full_path)
727 field
728 );
729 aux ident path_tail in
730 aux first_ident full_path
731
732 let rewrite_path_basic map e =
733 let e', path = D.FoldThrough.dot e in
734 match e' with
735 | (Ident i, label) ->
736 let i, path = resolve_path (snd e) map i path in
737 SurfaceAstCons.Fold.dot (Ident i, label) path
738 | _ -> e
739
740 (**
741 Simplifies a path as described before everywhere in an expression
742 *)
743 let rewrite_path map e =
744 OpaWalk.Expr.map_up (fun e -> rewrite_path_basic map e) e
745
746 let rec remove_access_directive e =
747 match e with
748 | (Directive ((`doctype _ | #distribution_directive as variant), [e], b), c) ->
749 (Directive (variant, [remove_access_directive e], b), c)
750 | (Directive (#access_directive, [e], _),_) ->
751 e
752 | _ -> e
753 (*if D.Look.access_directive ~through:[D.Remove.Basic.doctype] e then
754 let e, rebuild =
755 D.Context.filter
756 ~through:[D.Context.Basic.doctype]
757 ~throw:[D.Remove.Basic.access_directive] in
758 rebuild e
759 else
760 e*)
761
762 (**
763 This function extract the definitions of module fields from the module
764 {{ x = 2 }} -> let x = 2 in { x = x }
765 The definitions of fields of submodules are not touched
766
767 You can compute the fixpoint on this function: it will terminate because
768 a module can only flattened once:
769 module are recognised because they have @local directives, but this
770 function removes them. So the number of record containing @local directives
771 strictly decreases (and this function only works on records with @local
772 directives)
773
774 *)
775 let flatten_fields (i,e) =
776 if is_module e then
777 let l, label, letin_bindings, coercer =
778 extract_field_ident_expr_from_module e in
779 let record =
780 List.filter_map
781 (fun (field,ident,label,e) ->
782 if is_private e then None
783 else Some (field, (Ident ident, label)))
784 l in
785 let record_expr = coercer (Record record, label) in
786 let bindings =
787 List.map
788 (fun (_,ident,_,e) ->
789 let e = remove_access_directive e in
790 (ident,e)) l in
791 (i, record_expr) :: letin_bindings @ bindings
792 else
793 [(i,e)]
794
795 (* this function flatten all the modules directly present in the expressions on the given bindings
796 * it calls itself until a fixpoint is reached
797 * (the fixpoint being detected when the number of bindings doesn't increase)
798 *)
799 let rec flatten_module ident_expr_list =
800 let map = module_names ident_expr_list in
801 ident_expr_list
802 |> List.map (fun (i,e) -> (i, rewrite_path map e))
803 |> List.concat_map flatten_fields
804 |> (fun l -> if List.length l = List.length ident_expr_list then l else flatten_module l)
805
806 let rec flatten_module_in_expr_basic create_group_list = function
807 | (Directive (#access_directive as v, [e], _),label) ->
808 OManager.serror "@[<2>%s@\nInvalid directive @@%a.@]@\n" (SAH.Annot.to_string label) OpaPrint.ident#variant v;
809 flatten_module_in_expr_basic create_group_list e
810 | (LetIn (_,iel,e), label) ->
811 let iel = flatten_module iel in
812 let biell = reorder_for_ident_bindings create_group_list iel in
813 List.fold_right
814 (fun (iel,rec_) e ->
815 (LetIn (rec_,iel,e), copy_label label)) biell e
816 | (_, label) as e ->
817 if is_module e then
818 let i = Ident.next "flatten_module" in
819 (* FIXME: factorize me with the code above *)
820 let iel = flatten_module [(i,e)] in
821 let iell = reorder_for_ident_bindings create_group_list iel in
822 match List.extract_last iell with
823 (* FIXME: HACK: very fragile but needed by InlineModules *)
824 | iell, ([(i',e)],false) when Ident.equal i i' ->
825 (* Continuation to pass to
826 [SurfaceAstCons.with_builtin_position] in order to build the
827 directive expression. We can't simply call
828 [SurfaceAstCons.ExprIdentCons.E.letgen] because it makes
829 usage of a stack of location that is currently empty because
830 we are not in the parser. To avoid raising an "empty stack"
831 we must wrap our expression construction in a call to
832 [SurfaceAstCons.with_builtin_position]. *)
833 let mk_directived_definition () =
834 List.fold_right
835 (fun (iel, rec_) e ->
836 (* Embedd the let-definition into the directive telling
837 that it is in fact a module field's body that has
838 been expatriated from its module. *)
839 let dir =
840 Directive
841 (`module_field_lifting,
842 [ SurfaceAstCons.ExprIdentCons.E.letgen
843 ~rec_: rec_ iel e ],
844 []) in
845 (dir, copy_label label))
846 iell e in
847 SurfaceAstCons.with_builtin_position mk_directived_definition
848 | _ ->
849 (* See comment above to learn about the manual construction of
850 the directive expression. *)
851 let mk_directived_definition () =
852 List.fold_right
853 (fun (iel, rec_) e ->
854 (* Like above, embedd the let-definition in directive. *)
855 let dir =
856 Directive
857 (`module_field_lifting,
858 [ SurfaceAstCons.ExprIdentCons.E.letgen
859 ~rec_: rec_ iel e ],
860 []) in
861 (dir, copy_label label))
862 iell (Ident i, copy_label label) in
863 SurfaceAstCons.with_builtin_position mk_directived_definition
864 else
865 e
866
867 (**
868 Rewrite local modules
869 *)
870 let flatten_module_in_expr create_group_list lcode =
871 (* mapping down because we want to rewrite the modules in letin before
872 * the modules that appear in other places *)
873 SurfaceAstTraversal.ExprTraverse.Heterogeneous.lift_map_down
874 (function
875 | #basic_directive as v -> v
876 | #dependency_directive -> Format.printf "%a@." OpaPrint.readable_ident#code lcode; assert false)
877 (flatten_module_in_expr_basic create_group_list)
878 lcode
879
880 (* used to create placeholders, they are not supposed to be used *)
881 let fresh_ident () = Ident.next "rewrite_module"
882
883 (**
884 Rewrite toplevel modules
885 *)
886 let flatten_toplevel_module create_group_list lcode =
887 List.concat_map
888 (fun ((code_elt_node,label) as c) ->
889 match code_elt_node with
890 | NewVal (pel,_) ->
891 (* replacing pattern that are not identifiers by fresh
892 * identifiers that won't be used to transform the lhs of pattern
893 * by lhs of identifiers *)
894 let map,iel =
895 List.fold_left_map
896 (fun map -> function
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to dis...
OpaOnWindowsNow authored
897 | ((PatVar {ident=i;_},_) as pat), e ->
898 (* directives are not lost => in map *)
fccc685 Initial open-source release
MLstate authored
899 IdentMap.add i pat map, (i, remove_access_directive e)
900 | pat, e ->
901 let i = fresh_ident () in
902 IdentMap.add i pat map, (i, remove_access_directive e)
903 ) IdentMap.empty pel in
904 (* the actual flattening *)
905 let iel = flatten_module iel in
906 (* reputting the original patterns instead of the fake
907 * identifiers *)
908 let pel = List.map
909 (fun (i,e) ->
910 match IdentMap.find_opt i map with
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to dis...
OpaOnWindowsNow authored
911 | None -> ((PatVar {ident=i;directives=[]}, copy_label label), e)
fccc685 Initial open-source release
MLstate authored
912 | Some p -> (p,e)
913 ) iel in
914 (* reordering the result *)
915 let pelbl = reorder_for_pat_bindings create_group_list pel in
916 List.map (fun (pel,b) -> (NewVal (pel,b), copy_label label)) pelbl
917 | _ -> [c]
918 ) lcode
919
920 (* some utils to print the dependency graph of the standard library *)
921 module G = GraphUtils.String.G
922 module Viz = GraphUtils.DefaultGraphviz(G)(struct let vertex_name x = x end)
923
924 (* What is this hack, matching directly the string "builtin" ?? *)
925 (* TODO: correct this, there is a function is_empty in FilePos *)
926 let dump_file_deps lcode =
927 let iapis = get_context_linker_cache_input lcode in
928 let ideps = get_get_deps_input lcode in
929 let context_linker_cache = context_linker_cache iapis in
930 let deps = get_deps context_linker_cache ideps in
931 let map_back = map_back lcode in (* FIXME: insert all this inside the real function isntead of duplicating *)
932 let filename_of int =
933 let s = Filename.basename (FilePos.get_file (snd (IntMap.find int map_back)).QmlLoc.pos) in
934 try Filename.chop_extension s with Invalid_argument _ -> s in
935 let g = G.create () in
936 let is_not_builtin a = not (String.is_prefix "builtin" a) in
937 List.iter (fun (i,_) ->
938 let a = filename_of i in
939 if is_not_builtin a then
940 G.add_vertex g a) deps;
941 List.iter
942 (fun (i,set) ->
943 let a = filename_of i in
944 if is_not_builtin a then
945 IntSet.iter
946 (fun j ->
947 let b = filename_of j in
948 if is_not_builtin b && a <> b then
949 G.add_edge g b a) set) deps;
950 let package_name, _ = ObjectFiles.get_current_package () in
951 let filename = Printf.sprintf "opadep_%s.dot" package_name in
952 let filename =
953 match ObjectFiles.get_compilation_directory () with
954 | None -> filename
955 | Some dir -> File.concat dir filename
956 in
957 OManager.unquiet "opadep: outputting @{<bright>%s@}" filename ;
958 Viz.to_file filename g
959
960 let reorder_toplevel ?roots create_groups lcode =
961 let () = if ObjectFiles.Arg.is_opadep () then dump_file_deps lcode in
962 reorder_toplevel ?roots create_groups lcode
963
964 let rewrite_modules create_groups lcode =
965 let lcode =
966 lcode
967 |> flatten_toplevel_module create_groups
968 |> flatten_module_in_expr create_groups in
969 OManager.flush_errors (); (* remove this line when s2 is removed *)
970 lcode
Something went wrong with that request. Please try again.