1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1999 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 open Asttypes
17 open Location
18 open Longident
19 open Parsetree
20 module String = Misc.Stdlib.String
21
22 let pp_deps = ref []
23
24 (* Module resolution map *)
25 (* Node (set of imports for this path, map for submodules) *)
26 type map_tree = Node of String.Set.t * bound_map
27 and bound_map = map_tree String.Map.t
28 let bound = Node (String.Set.empty, String.Map.empty)
29
30 (*let get_free (Node (s, _m)) = s*)
31 let get_map (Node (_s, m)) = m
32 let make_leaf s = Node (String.Set.singleton s, String.Map.empty)
33 let make_node m = Node (String.Set.empty, m)
34 let rec weaken_map s (Node(s0,m0)) =
35 Node (String.Set.union s s0, String.Map.map (weaken_map s) m0)
36 let rec collect_free (Node (s, m)) =
37 String.Map.fold (fun _ n -> String.Set.union (collect_free n)) m s
38
39 (* Returns the imports required to access the structure at path p *)
40 (* Only raises Not_found if the head of p is not in the toplevel map *)
41 let rec lookup_free p m =
42 match p with
43 [] -> raise Not_found
44 | s::p ->
45 let Node (f, m') = String.Map.find s m in
46 try lookup_free p m' with Not_found -> f
47
48 (* Returns the node corresponding to the structure at path p *)
49 let rec lookup_map lid m =
50 match lid with
51 Lident s -> String.Map.find s m
52 | Ldot (l, s) -> String.Map.find s (get_map (lookup_map l m))
53 | Lapply _ -> raise Not_found
54
55 (* Collect free module identifiers in the a.s.t. *)
56
57 let free_structure_names = ref String.Set.empty
58
59 let add_names s =
60 free_structure_names := String.Set.union s !free_structure_names
61
62 let rec add_path bv ?(p=[]) = function
63 | Lident s ->
64 let free =
65 try lookup_free (s::p) bv with Not_found -> String.Set.singleton s
66 in
67 (*String.Set.iter (fun s -> Printf.eprintf "%s " s) free;
68 prerr_endline "";*)
69 add_names free
70 | Ldot(l, s) -> add_path bv ~p:(s::p) l
71 | Lapply(l1, l2) -> add_path bv l1; add_path bv l2
72
73 let open_module bv lid =
74 match lookup_map lid bv with
75 | Node (s, m) ->
76 add_names s;
77 String.Map.fold String.Map.add m bv
78 | exception Not_found ->
79 add_path bv lid; bv
80
81 let add_parent bv lid =
82 match lid.txt with
83 Ldot(l, _s) -> add_path bv l
84 | _ -> ()
85
86 let add = add_parent
87
88 let add_module_path bv lid = add_path bv lid.txt
89
90 let handle_extension ext =
91 match (fst ext).txt with
92 | "error" | "ocaml.error" ->
93 raise (Location.Error
94 (Builtin_attributes.error_of_extension ext))
95 | _ ->
96 ()
97
98 let rec add_type bv ty =
99 match ty.ptyp_desc with
100 Ptyp_any -> ()
101 | Ptyp_var _ -> ()
102 | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
103 | Ptyp_tuple tl -> List.iter (add_type bv) tl
104 | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
105 | Ptyp_object (fl, _) ->
106 List.iter
107 (fun {pof_desc; _} -> match pof_desc with
108 | Otag (_, t) -> add_type bv t
109 | Oinherit t -> add_type bv t) fl
110 | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
111 | Ptyp_alias(t, _) -> add_type bv t
112 | Ptyp_variant(fl, _, _) ->
113 List.iter
114 (fun {prf_desc; _} -> match prf_desc with
115 | Rtag(_, _, stl) -> List.iter (add_type bv) stl
116 | Rinherit sty -> add_type bv sty)
117 fl
118 | Ptyp_poly(_, t) -> add_type bv t
119 | Ptyp_package pt -> add_package_type bv pt
120 | Ptyp_extension e -> handle_extension e
121
122 and add_package_type bv (lid, l) =
123 add bv lid;
124 List.iter (add_type bv) (List.map (fun (_, e) -> e) l)
125
126 let add_opt add_fn bv = function
127 None -> ()
128 | Some x -> add_fn bv x
129
130 let add_constructor_arguments bv = function
131 | Pcstr_tuple l -> List.iter (add_type bv) l
132 | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
133
134 let add_constructor_decl bv pcd =
135 add_constructor_arguments bv pcd.pcd_args;
136 Option.iter (add_type bv) pcd.pcd_res
137
138 let add_type_declaration bv td =
139 List.iter
140 (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
141 td.ptype_cstrs;
142 add_opt add_type bv td.ptype_manifest;
143 let add_tkind = function
144 Ptype_abstract -> ()
145 | Ptype_variant cstrs ->
146 List.iter (add_constructor_decl bv) cstrs
147 | Ptype_record lbls ->
148 List.iter (fun pld -> add_type bv pld.pld_type) lbls
149 | Ptype_open -> () in
150 add_tkind td.ptype_kind
151
152 let add_extension_constructor bv ext =
153 match ext.pext_kind with
154 Pext_decl(args, rty) ->
155 add_constructor_arguments bv args;
156 Option.iter (add_type bv) rty
157 | Pext_rebind lid -> add bv lid
158
159 let add_type_extension bv te =
160 add bv te.ptyext_path;
161 List.iter (add_extension_constructor bv) te.ptyext_constructors
162
163 let add_type_exception bv te =
164 add_extension_constructor bv te.ptyexn_constructor
165
166 let pattern_bv = ref String.Map.empty
167
168 let rec add_pattern bv pat =
169 match pat.ppat_desc with
170 Ppat_any -> ()
171 | Ppat_var _ -> ()
172 | Ppat_alias(p, _) -> add_pattern bv p
173 | Ppat_interval _
174 | Ppat_constant _ -> ()
175 | Ppat_tuple pl -> List.iter (add_pattern bv) pl
176 | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op
177 | Ppat_record(pl, _) ->
178 List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
179 | Ppat_array pl -> List.iter (add_pattern bv) pl
180 | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
181 | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
182 | Ppat_variant(_, op) -> add_opt add_pattern bv op
183 | Ppat_type li -> add bv li
184 | Ppat_lazy p -> add_pattern bv p
185 | Ppat_unpack id ->
186 Option.iter
187 (fun name -> pattern_bv := String.Map.add name bound !pattern_bv) id.txt
188 | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
189 | Ppat_exception p -> add_pattern bv p
190 | Ppat_extension e -> handle_extension e
191
192 let add_pattern bv pat =
193 pattern_bv := bv;
194 add_pattern bv pat;
195 !pattern_bv
196
197 let rec add_expr bv exp =
198 match exp.pexp_desc with
199 Pexp_ident l -> add bv l
200 | Pexp_constant _ -> ()
201 | Pexp_let(rf, pel, e) ->
202 let bv = add_bindings rf bv pel in add_expr bv e
203 | Pexp_fun (_, opte, p, e) ->
204 add_opt add_expr bv opte; add_expr (add_pattern bv p) e
205 | Pexp_function pel ->
206 add_cases bv pel
207 | Pexp_apply(e, el) ->
208 add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
209 | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
210 | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
211 | Pexp_tuple el -> List.iter (add_expr bv) el
212 | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte
213 | Pexp_variant(_, opte) -> add_opt add_expr bv opte
214 | Pexp_record(lblel, opte) ->
215 List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel;
216 add_opt add_expr bv opte
217 | Pexp_field(e, fld) -> add_expr bv e; add bv fld
218 | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2
219 | Pexp_array el -> List.iter (add_expr bv) el
220 | Pexp_ifthenelse(e1, e2, opte3) ->
221 add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3
222 | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2
223 | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
224 | Pexp_for( _, e1, e2, _, e3) ->
225 add_expr bv e1; add_expr bv e2; add_expr bv e3
226 | Pexp_coerce(e1, oty2, ty3) ->
227 add_expr bv e1;
228 add_opt add_type bv oty2;
229 add_type bv ty3
230 | Pexp_constraint(e1, ty2) ->
231 add_expr bv e1;
232 add_type bv ty2
233 | Pexp_send(e, _m) -> add_expr bv e
234 | Pexp_new li -> add bv li
235 | Pexp_setinstvar(_v, e) -> add_expr bv e
236 | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
237 | Pexp_letmodule(id, m, e) ->
238 let b = add_module_binding bv m in
239 let bv =
240 match id.txt with
241 | None -> bv
242 | Some id -> String.Map.add id b bv
243 in
244 add_expr bv e
245 | Pexp_letexception(_, e) -> add_expr bv e
246 | Pexp_assert (e) -> add_expr bv e
247 | Pexp_lazy (e) -> add_expr bv e
248 | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
249 | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } ->
250 let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
251 | Pexp_newtype (_, e) -> add_expr bv e
252 | Pexp_pack m -> add_module_expr bv m
253 | Pexp_open (o, e) ->
254 let bv = open_declaration bv o in
255 add_expr bv e
256 | Pexp_letop {let_; ands; body} ->
257 let bv' = add_binding_op bv bv let_ in
258 let bv' = List.fold_left (add_binding_op bv) bv' ands in
259 add_expr bv' body
260 | Pexp_extension (({ txt = ("ocaml.extension_constructor"|
261 "extension_constructor"); _ },
262 PStr [item]) as e) ->
263 begin match item.pstr_desc with
264 | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c
265 | _ -> handle_extension e
266 end
267 | Pexp_extension e -> handle_extension e
268 | Pexp_unreachable -> ()
269
270 and add_cases bv cases =
271 List.iter (add_case bv) cases
272
273 and add_case bv {pc_lhs; pc_guard; pc_rhs} =
274 let bv = add_pattern bv pc_lhs in
275 add_opt add_expr bv pc_guard;
276 add_expr bv pc_rhs
277
278 and add_bindings recf bv pel =
279 let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
280 let bv = if recf = Recursive then bv' else bv in
281 List.iter (fun x -> add_expr bv x.pvb_expr) pel;
282 bv'
283
284 and add_binding_op bv bv' pbop =
285 add_expr bv pbop.pbop_exp;
286 add_pattern bv' pbop.pbop_pat
287
288 and add_modtype bv mty =
289 match mty.pmty_desc with
290 Pmty_ident l -> add bv l
291 | Pmty_alias l -> add_module_path bv l
292 | Pmty_signature s -> add_signature bv s
293 | Pmty_functor(param, mty2) ->
294 let bv =
295 match param with
296 | Unit -> bv
297 | Named (id, mty1) ->
298 add_modtype bv mty1;
299 match id.txt with
300 | None -> bv
301 | Some name -> String.Map.add name bound bv
302 in
303 add_modtype bv mty2
304 | Pmty_with(mty, cstrl) ->
305 add_modtype bv mty;
306 List.iter
307 (function
308 | Pwith_type (_, td) -> add_type_declaration bv td
309 | Pwith_module (_, lid) -> add_module_path bv lid
310 | Pwith_typesubst (_, td) -> add_type_declaration bv td
311 | Pwith_modsubst (_, lid) -> add_module_path bv lid
312 )
313 cstrl
314 | Pmty_typeof m -> add_module_expr bv m
315 | Pmty_extension e -> handle_extension e
316
317 and add_module_alias bv l =
318 (* If we are in delayed dependencies mode, we delay the dependencies
319 induced by "Lident s" *)
320 (if !Clflags.transparent_modules then add_parent else add_module_path) bv l;
321 try
322 lookup_map l.txt bv
323 with Not_found ->
324 match l.txt with
325 Lident s -> make_leaf s
326 | _ -> add_module_path bv l; bound (* cannot delay *)
327
328 and add_modtype_binding bv mty =
329 match mty.pmty_desc with
330 Pmty_alias l ->
331 add_module_alias bv l
332 | Pmty_signature s ->
333 make_node (add_signature_binding bv s)
334 | Pmty_typeof modl ->
335 add_module_binding bv modl
336 | _ ->
337 add_modtype bv mty; bound
338
339 and add_signature bv sg =
340 ignore (add_signature_binding bv sg)
341
342 and add_signature_binding bv sg =
343 snd (List.fold_left add_sig_item (bv, String.Map.empty) sg)
344
345 and add_sig_item (bv, m) item =
346 match item.psig_desc with
347 Psig_value vd ->
348 add_type bv vd.pval_type; (bv, m)
349 | Psig_type (_, dcls)
350 | Psig_typesubst dcls->
351 List.iter (add_type_declaration bv) dcls; (bv, m)
352 | Psig_typext te ->
353 add_type_extension bv te; (bv, m)
354 | Psig_exception te ->
355 add_type_exception bv te; (bv, m)
356 | Psig_module pmd ->
357 let m' = add_modtype_binding bv pmd.pmd_type in
358 let add map =
359 match pmd.pmd_name.txt with
360 | None -> map
361 | Some name -> String.Map.add name m' map
362 in
363 (add bv, add m)
364 | Psig_modsubst pms ->
365 let m' = add_module_alias bv pms.pms_manifest in
366 let add = String.Map.add pms.pms_name.txt m' in
367 (add bv, add m)
368 | Psig_recmodule decls ->
369 let add =
370 List.fold_right (fun pmd map ->
371 match pmd.pmd_name.txt with
372 | None -> map
373 | Some name -> String.Map.add name bound map
374 ) decls
375 in
376 let bv' = add bv and m' = add m in
377 List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
378 (bv', m')
379 | Psig_modtype x ->
380 begin match x.pmtd_type with
381 None -> ()
382 | Some mty -> add_modtype bv mty
383 end;
384 (bv, m)
385 | Psig_open od ->
386 (open_description bv od, m)
387 | Psig_include incl ->
388 let Node (s, m') = add_modtype_binding bv incl.pincl_mod in
389 add_names s;
390 let add = String.Map.fold String.Map.add m' in
391 (add bv, add m)
392 | Psig_class cdl ->
393 List.iter (add_class_description bv) cdl; (bv, m)
394 | Psig_class_type cdtl ->
395 List.iter (add_class_type_declaration bv) cdtl; (bv, m)
396 | Psig_attribute _ -> (bv, m)
397 | Psig_extension (e, _) ->
398 handle_extension e;
399 (bv, m)
400
401 and open_description bv od =
402 let Node(s, m) = add_module_alias bv od.popen_expr in
403 add_names s;
404 String.Map.fold String.Map.add m bv
405
406 and open_declaration bv od =
407 let Node (s, m) = add_module_binding bv od.popen_expr in
408 add_names s;
409 String.Map.fold String.Map.add m bv
410
411 and add_module_binding bv modl =
412 match modl.pmod_desc with
413 Pmod_ident l -> add_module_alias bv l
414 | Pmod_structure s ->
415 make_node (snd @@ add_structure_binding bv s)
416 | _ -> add_module_expr bv modl; bound
417
418 and add_module_expr bv modl =
419 match modl.pmod_desc with
420 Pmod_ident l -> add_module_path bv l
421 | Pmod_structure s -> ignore (add_structure bv s)
422 | Pmod_functor(param, modl) ->
423 let bv =
424 match param with
425 | Unit -> bv
426 | Named (id, mty) ->
427 add_modtype bv mty;
428 match id.txt with
429 | None -> bv
430 | Some name -> String.Map.add name bound bv
431 in
432 add_module_expr bv modl
433 | Pmod_apply(mod1, mod2) ->
434 add_module_expr bv mod1; add_module_expr bv mod2
435 | Pmod_constraint(modl, mty) ->
436 add_module_expr bv modl; add_modtype bv mty
437 | Pmod_unpack(e) ->
438 add_expr bv e
439 | Pmod_extension e ->
440 handle_extension e
441
442 and add_class_type bv cty =
443 match cty.pcty_desc with
444 Pcty_constr(l, tyl) ->
445 add bv l; List.iter (add_type bv) tyl
446 | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
447 add_type bv ty;
448 List.iter (add_class_type_field bv) fieldl
449 | Pcty_arrow(_, ty1, cty2) ->
450 add_type bv ty1; add_class_type bv cty2
451 | Pcty_extension e -> handle_extension e
452 | Pcty_open (o, e) ->
453 let bv = open_description bv o in
454 add_class_type bv e
455
456 and add_class_type_field bv pctf =
457 match pctf.pctf_desc with
458 Pctf_inherit cty -> add_class_type bv cty
459 | Pctf_val(_, _, _, ty) -> add_type bv ty
460 | Pctf_method(_, _, _, ty) -> add_type bv ty
461 | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
462 | Pctf_attribute _ -> ()
463 | Pctf_extension e -> handle_extension e
464
465 and add_class_description bv infos =
466 add_class_type bv infos.pci_expr
467
468 and add_class_type_declaration bv infos = add_class_description bv infos
469
470 and add_structure bv item_list =
471 let (bv, m) = add_structure_binding bv item_list in
472 add_names (collect_free (make_node m));
473 bv
474
475 and add_structure_binding bv item_list =
476 List.fold_left add_struct_item (bv, String.Map.empty) item_list
477
478 and add_struct_item (bv, m) item : _ String.Map.t * _ String.Map.t =
479 match item.pstr_desc with
480 Pstr_eval (e, _attrs) ->
481 add_expr bv e; (bv, m)
482 | Pstr_value(rf, pel) ->
483 let bv = add_bindings rf bv pel in (bv, m)
484 | Pstr_primitive vd ->
485 add_type bv vd.pval_type; (bv, m)
486 | Pstr_type (_, dcls) ->
487 List.iter (add_type_declaration bv) dcls; (bv, m)
488 | Pstr_typext te ->
489 add_type_extension bv te;
490 (bv, m)
491 | Pstr_exception te ->
492 add_type_exception bv te;
493 (bv, m)
494 | Pstr_module x ->
495 let b = add_module_binding bv x.pmb_expr in
496 let add map =
497 match x.pmb_name.txt with
498 | None -> map
499 | Some name -> String.Map.add name b map
500 in
501 (add bv, add m)
502 | Pstr_recmodule bindings ->
503 let add =
504 List.fold_right (fun x map ->
505 match x.pmb_name.txt with
506 | None -> map
507 | Some name -> String.Map.add name bound map
508 ) bindings
509 in
510 let bv' = add bv and m = add m in
511 List.iter
512 (fun x -> add_module_expr bv' x.pmb_expr)
513 bindings;
514 (bv', m)
515 | Pstr_modtype x ->
516 begin match x.pmtd_type with
517 None -> ()
518 | Some mty -> add_modtype bv mty
519 end;
520 (bv, m)
521 | Pstr_open od ->
522 (open_declaration bv od, m)
523 | Pstr_class cdl ->
524 List.iter (add_class_declaration bv) cdl; (bv, m)
525 | Pstr_class_type cdtl ->
526 List.iter (add_class_type_declaration bv) cdtl; (bv, m)
527 | Pstr_include incl ->
528 let Node (s, m') as n = add_module_binding bv incl.pincl_mod in
529 if !Clflags.transparent_modules then
530 add_names s
531 else
532 (* If we are not in the delayed dependency mode, we need to
533 collect all delayed dependencies imported by the include statement *)
534 add_names (collect_free n);
535 let add = String.Map.fold String.Map.add m' in
536 (add bv, add m)
537 | Pstr_attribute _ -> (bv, m)
538 | Pstr_extension (e, _) ->
539 handle_extension e;
540 (bv, m)
541
542 and add_use_file bv top_phrs =
543 ignore (List.fold_left add_top_phrase bv top_phrs)
544
545 and add_implementation bv l =
546 ignore (add_structure_binding bv l)
547
548 and add_implementation_binding bv l =
549 snd (add_structure_binding bv l)
550
551 and add_top_phrase bv = function
552 | Ptop_def str -> add_structure bv str
553 | Ptop_dir _ -> bv
554
555 and add_class_expr bv ce =
556 match ce.pcl_desc with
557 Pcl_constr(l, tyl) ->
558 add bv l; List.iter (add_type bv) tyl
559 | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } ->
560 let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
561 | Pcl_fun(_, opte, pat, ce) ->
562 add_opt add_expr bv opte;
563 let bv = add_pattern bv pat in add_class_expr bv ce
564 | Pcl_apply(ce, exprl) ->
565 add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
566 | Pcl_let(rf, pel, ce) ->
567 let bv = add_bindings rf bv pel in add_class_expr bv ce
568 | Pcl_constraint(ce, ct) ->
569 add_class_expr bv ce; add_class_type bv ct
570 | Pcl_extension e -> handle_extension e
571 | Pcl_open (o, e) ->
572 let bv = open_description bv o in
573 add_class_expr bv e
574
575 and add_class_field bv pcf =
576 match pcf.pcf_desc with
577 Pcf_inherit(_, ce, _) -> add_class_expr bv ce
578 | Pcf_val(_, _, Cfk_concrete (_, e))
579 | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e
580 | Pcf_val(_, _, Cfk_virtual ty)
581 | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
582 | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
583 | Pcf_initializer e -> add_expr bv e
584 | Pcf_attribute _ -> ()
585 | Pcf_extension e -> handle_extension e
586
587 and add_class_declaration bv decl =
588 add_class_expr bv decl.pci_expr
589