jon.recoil.org
this repo has no description
1(* A bunch of association lists. Let's hashtbl them up later *)
2open Odoc_model
3open Odoc_model.Names
4open Odoc_model.Paths
5open Odoc_utils
6
7type lookup_unit_result = Forward_reference | Found of Lang.Compilation_unit.t
8
9type path_query = [ `Path of Reference.Hierarchy.t | `Name of string ]
10
11type lookup_error = [ `Not_found ]
12
13type resolver = {
14 open_units : string list;
15 lookup_unit : path_query -> (lookup_unit_result, lookup_error) result;
16 lookup_page : path_query -> (Lang.Page.t, lookup_error) result;
17 lookup_asset : path_query -> (Lang.Asset.t, lookup_error) result;
18 lookup_impl : string -> Lang.Implementation.t option;
19}
20
21type root =
22 | Resolved of (Root.t * Identifier.Module.t * Component.Module.t)
23 | Forward
24
25let unique_id =
26 let i = ref 0 in
27 fun () ->
28 incr i;
29 !i
30
31type lookup_type =
32 | Module of Paths.Identifier.Path.Module.t
33 | ModuleType of Paths.Identifier.Path.ModuleType.t
34 | RootModule of ModuleName.t * [ `Forward | `Resolved of Digest.t ] option
35 | ModuleByName of string * Paths.Identifier.Path.Module.t
36 | FragmentRoot of int
37
38let pp_lookup_type fmt =
39 let fmtrm fmt = function
40 | Some `Forward -> Format.fprintf fmt "Some (Forward)"
41 | Some (`Resolved digest) -> Format.fprintf fmt "Some (Resolved %s)" digest
42 | None -> Format.fprintf fmt "None"
43 in
44 let c = Component.Fmt.default in
45 function
46 | Module r ->
47 Format.fprintf fmt "Module %a"
48 (Component.Fmt.model_identifier c)
49 (r :> Identifier.t)
50 | ModuleType r ->
51 Format.fprintf fmt "ModuleType %a"
52 (Component.Fmt.model_identifier c)
53 (r :> Identifier.t)
54 | RootModule (n, res) ->
55 Format.fprintf fmt "RootModule %a %a" ModuleName.fmt n fmtrm res
56 | ModuleByName (n, r) ->
57 Format.fprintf fmt "ModuleByName %s, %a" n
58 (Component.Fmt.model_identifier c)
59 (r :> Identifier.t)
60 | FragmentRoot i -> Format.fprintf fmt "FragmentRoot %d" i
61
62let pp_lookup_type_list fmt ls =
63 let rec inner fmt = function
64 | [] -> Format.fprintf fmt ""
65 | [ x ] -> Format.fprintf fmt "%a" pp_lookup_type x
66 | x :: ys -> Format.fprintf fmt "%a; %a" pp_lookup_type x inner ys
67 in
68 Format.fprintf fmt "[%a]" inner ls
69
70module LookupTypeSet = Set.Make (struct
71 type t = lookup_type
72
73 let compare = compare
74end)
75
76type recorder = { mutable lookups : LookupTypeSet.t }
77
78module Maps = Paths.Identifier.Maps
79module StringMap = Map.Make (String)
80
81(** Used only to handle shadowing, see {!Elements}. *)
82type kind =
83 | Kind_Module
84 | Kind_ModuleType
85 | Kind_Type
86 | Kind_Value
87 | Kind_Label
88 | Kind_Class
89 | Kind_ClassType
90 | Kind_Constructor
91 | Kind_Exception
92 | Kind_Extension
93 | Kind_Field
94 | Kind_UnboxedField
95
96module ElementsByName : sig
97 type t
98
99 val empty : t
100
101 val add : kind -> string -> [< Component.Element.any ] -> t -> t
102
103 val find_by_name :
104 (Component.Element.any -> 'b option) -> string -> t -> 'b list
105end = struct
106 type elem = { kind : kind; elem : Component.Element.any }
107
108 type t = elem list StringMap.t
109
110 let empty = StringMap.empty
111
112 let add kind name elem t =
113 let elem = (elem :> Component.Element.any) in
114 let tl =
115 try
116 let tl = StringMap.find name t in
117 let not_shadow e = e.kind <> kind in
118 if not (List.for_all not_shadow tl) then List.filter not_shadow tl
119 else tl
120 with Not_found -> []
121 in
122 StringMap.add name ({ kind; elem } :: tl) t
123
124 let find_by_name f name t =
125 let filter e acc = match f e.elem with Some r -> r :: acc | None -> acc in
126 try List.fold_right filter (StringMap.find name t) [] with Not_found -> []
127end
128
129module ElementsById : sig
130 type t
131
132 val empty : t
133
134 val add :
135 [< Identifier.t_pv ] Paths.Identifier.id ->
136 [< Component.Element.any ] ->
137 t ->
138 t
139
140 val find_by_id :
141 [< Identifier.t_pv ] Paths.Identifier.id ->
142 t ->
143 Component.Element.any option
144end = struct
145 module IdMap = Identifier.Maps.Any
146
147 type t = Component.Element.any IdMap.t
148
149 let empty = IdMap.empty
150
151 let add identifier element t =
152 IdMap.add (identifier :> Identifier.t) (element :> Component.Element.any) t
153
154 let find_by_id identifier t =
155 try Some (IdMap.find (identifier :> Identifier.t) t)
156 with Not_found -> None
157end
158
159type 'a amb_err = [ `Ambiguous of 'a * 'a list ]
160
161type t = {
162 linking : bool;
163 (* True if this is a linking environment - if not, we only put in modules,
164 module types, types, classes and class types *)
165 id : int;
166 elts : ElementsByName.t;
167 (** Elements mapped by their name. Queried with {!find_by_name}. *)
168 ids : ElementsById.t;
169 (** Elements mapped by their identifier. Queried with {!find_by_id}. *)
170 ambiguous_labels : Component.Element.label amb_err Identifier.Maps.Label.t;
171 ambiguous_unboxed_labels :
172 Component.Element.label amb_err Identifier.Maps.Label.t;
173 [@warning "-unused-field"]
174 resolver : resolver option;
175 recorder : recorder option;
176 warnings_tags : string list;
177 fragmentroot : (int * Component.Signature.t) option;
178}
179
180let should_suppress_warnings env opt =
181 match opt with None -> false | Some x -> not (List.mem x env.warnings_tags)
182(* Suppress warnings unless the tag is in the list *)
183
184let set_warnings_tags env tags = { env with warnings_tags = tags }
185
186let is_linking env = env.linking
187
188let set_resolver t resolver = { t with resolver = Some resolver }
189
190let has_resolver t = match t.resolver with None -> false | _ -> true
191
192let id t = t.id
193
194let with_recorded_lookups env f =
195 let recorder = { lookups = LookupTypeSet.empty } in
196 let env' = { env with recorder = Some recorder } in
197 let restore () =
198 match env.recorder with
199 | Some r -> r.lookups <- LookupTypeSet.union recorder.lookups r.lookups
200 | None -> ()
201 in
202 try
203 let result = f env' in
204 restore ();
205 (recorder.lookups, result)
206 with e ->
207 restore ();
208 raise e
209
210let empty =
211 {
212 linking = true;
213 id = 0;
214 elts = ElementsByName.empty;
215 ids = ElementsById.empty;
216 resolver = None;
217 recorder = None;
218 ambiguous_labels = Identifier.Maps.Label.empty;
219 ambiguous_unboxed_labels = Identifier.Maps.Label.empty;
220 warnings_tags = [];
221 fragmentroot = None;
222 }
223
224let add_fragment_root sg env =
225 let id = unique_id () in
226 { env with fragmentroot = Some (id, sg); id }
227
228(** Implements most [add_*] functions. *)
229let add_to_elts kind identifier component env =
230 if not env.linking then
231 assert (
232 List.mem kind
233 [ Kind_Module; Kind_ModuleType; Kind_Type; Kind_Class; Kind_ClassType ]);
234 let _ =
235 let other = ElementsById.find_by_id identifier env.ids in
236 match other with
237 | Some _ ->
238 (* Format.eprintf "Overriding duplicate env entry: %s\n%!" (Identifier.name identifier); *)
239 ()
240 | None -> ()
241 in
242 let name = Identifier.name identifier in
243 {
244 env with
245 id = unique_id ();
246 elts = ElementsByName.add kind name component env.elts;
247 ids = ElementsById.add identifier component env.ids;
248 }
249
250let add_label identifier heading env ~unboxed =
251 assert env.linking;
252 (* TODO: implement proper behavior for unboxed labels *)
253 assert (not unboxed);
254 let comp = `Label (identifier, heading) in
255 let name = Identifier.name identifier in
256 let ambiguous_labels =
257 match ElementsById.find_by_id identifier env.ids with
258 | Some (#Component.Element.label as l) ->
259 let err =
260 try
261 match
262 Identifier.Maps.Label.find identifier env.ambiguous_labels
263 with
264 | `Ambiguous (x, others) -> `Ambiguous (x, comp :: others)
265 with Not_found -> `Ambiguous (l, [ comp ])
266 in
267
268 Identifier.Maps.Label.add identifier err env.ambiguous_labels
269 | Some _ -> assert false
270 | None -> env.ambiguous_labels
271 in
272 {
273 env with
274 id = unique_id ();
275 elts =
276 ElementsByName.add Kind_Label name
277 (comp :> Component.Element.any)
278 env.elts;
279 ambiguous_labels;
280 ids = ElementsById.add identifier comp env.ids;
281 }
282
283let add_docs (docs : Comment.docs) env =
284 assert env.linking;
285 List.fold_left
286 (fun env -> function
287 | { Location_.value = `Heading (attrs, id, text); location } ->
288 let label = Ident.Of_Identifier.label id in
289 add_label id
290 { Component.Label.attrs; label; text; location }
291 env ~unboxed:false
292 | _ -> env)
293 env docs.elements
294
295let add_comment (com : Comment.docs_or_stop) env =
296 match com with `Docs doc -> add_docs doc env | `Stop -> env
297
298let add_cdocs p (docs : Component.CComment.docs) env =
299 List.fold_left
300 (fun env element ->
301 match element.Location_.value with
302 | `Heading h ->
303 let (`LLabel (name, _)) = h.Component.Label.label in
304 let label =
305 Paths.Identifier.Mk.label (Paths.Identifier.label_parent p, name)
306 in
307 add_label label h env ~unboxed:false
308 | _ -> env)
309 env docs.elements
310
311let add_module identifier m docs env =
312 let env' = add_to_elts Kind_Module identifier (`Module (identifier, m)) env in
313 if env.linking then add_cdocs identifier docs env' else env'
314
315let add_type (identifier : Identifier.Type.t) t env =
316 let open Component in
317 let open_typedecl cs =
318 let add_cons env (cons : TypeDecl.Constructor.t) =
319 let ident =
320 Paths.Identifier.Mk.constructor
321 ( (identifier :> Identifier.DataType.t),
322 ConstructorName.make_std cons.name )
323 in
324 add_to_elts Kind_Constructor ident (`Constructor (ident, cons)) env
325 and add_field env (field : TypeDecl.Field.t) =
326 let ident =
327 Paths.Identifier.Mk.field
328 ( (identifier :> Paths.Identifier.FieldParent.t),
329 FieldName.make_std field.name )
330 in
331 add_to_elts Kind_Field ident (`Field (ident, field)) env
332 and add_unboxed_field env (field : TypeDecl.UnboxedField.t) =
333 let ident =
334 Paths.Identifier.Mk.unboxed_field
335 ( (identifier :> Paths.Identifier.UnboxedFieldParent.t),
336 UnboxedFieldName.make_std field.name )
337 in
338 add_to_elts Kind_UnboxedField ident (`UnboxedField (ident, field)) env
339 in
340 let open TypeDecl in
341 match t.representation with
342 | Some (Variant cons) ->
343 ( List.fold_left add_cons cs cons,
344 List.map (fun t -> t.Constructor.doc) cons )
345 | Some (Record fields) ->
346 ( List.fold_left add_field cs fields,
347 List.map (fun t -> t.Field.doc) fields )
348 | Some (Record_unboxed_product fields) ->
349 ( List.fold_left add_unboxed_field cs fields,
350 List.map (fun t -> t.UnboxedField.doc) fields )
351 | Some Extensible | None -> (cs, [])
352 in
353 let env, docs = if env.linking then open_typedecl env else (env, []) in
354 let env = add_to_elts Kind_Type identifier (`Type (identifier, t)) env in
355 if env.linking then
356 add_cdocs identifier t.doc env
357 |> List.fold_right (add_cdocs identifier) docs
358 else env
359
360let add_module_type identifier (t : Component.ModuleType.t) env =
361 let env' =
362 add_to_elts Kind_ModuleType identifier (`ModuleType (identifier, t)) env
363 in
364 if env'.linking then add_cdocs identifier t.doc env' else env'
365
366let add_value identifier (t : Component.Value.t) env =
367 add_to_elts Kind_Value identifier (`Value (identifier, t)) env
368 |> add_cdocs identifier t.doc
369
370let add_class identifier (t : Component.Class.t) env =
371 let env' = add_to_elts Kind_Class identifier (`Class (identifier, t)) env in
372 if env'.linking then add_cdocs identifier t.doc env' else env'
373
374let add_class_type identifier (t : Component.ClassType.t) env =
375 let env' =
376 add_to_elts Kind_ClassType identifier (`ClassType (identifier, t)) env
377 in
378 if env'.linking then add_cdocs identifier t.doc env' else env'
379
380let add_method _identifier _t env =
381 (* TODO *)
382 env
383
384let add_exception identifier (e : Component.Exception.t) env =
385 add_to_elts Kind_Exception identifier (`Exception (identifier, e)) env
386 |> add_cdocs identifier e.doc
387
388let add_extension_constructor identifier
389 (ec : Component.Extension.Constructor.t) te env =
390 add_to_elts Kind_Extension identifier (`Extension (identifier, ec, te)) env
391 |> add_cdocs identifier ec.doc
392
393let module_of_unit : Lang.Compilation_unit.t -> Component.Module.t =
394 fun unit ->
395 let id = (unit.id :> Paths.Identifier.Module.t) in
396 match unit.content with
397 | Module s ->
398 let m =
399 Lang.Module.
400 {
401 id;
402 source_loc = None;
403 source_loc_jane = unit.source_loc_jane;
404 doc = { elements = []; warnings_tag = None };
405 type_ = ModuleType (Signature s);
406 canonical = unit.canonical;
407 hidden = unit.hidden;
408 }
409 in
410 let ty = Component.Of_Lang.(module_ (empty ()) m) in
411 ty
412 | Pack _p ->
413 let m =
414 Lang.Module.
415 {
416 id;
417 source_loc = None;
418 source_loc_jane = unit.source_loc_jane;
419 doc = { elements = []; warnings_tag = None };
420 type_ =
421 ModuleType
422 (Signature
423 {
424 items = [];
425 compiled = true;
426 removed = [];
427 doc = { elements = []; warnings_tag = None };
428 });
429 canonical = unit.canonical;
430 hidden = unit.hidden;
431 }
432 in
433 let ty = Component.Of_Lang.(module_ (empty ()) m) in
434 ty
435
436let lookup_root_module name env =
437 let result =
438 match env.resolver with
439 | None -> None
440 | Some r -> (
441 match r.lookup_unit (`Name (ModuleName.to_string name)) with
442 | Ok Forward_reference -> Some Forward
443 | Error `Not_found -> None
444 | Ok (Found u) ->
445 let ({ Odoc_model.Paths.Identifier.iv = `Root _; _ } as id) =
446 u.id
447 in
448 let m = module_of_unit u in
449 Some (Resolved (u.root, id, m)))
450 in
451 (match (env.recorder, result) with
452 | Some r, Some Forward ->
453 r.lookups <-
454 LookupTypeSet.add (RootModule (name, Some `Forward)) r.lookups
455 | Some r, Some (Resolved (root, _, _)) ->
456 r.lookups <-
457 LookupTypeSet.add
458 (RootModule (name, Some (`Resolved root.digest)))
459 r.lookups
460 | Some r, None ->
461 r.lookups <- LookupTypeSet.add (RootModule (name, None)) r.lookups
462 | None, _ -> ());
463 result
464
465let lookup_page query env =
466 match env.resolver with
467 | None -> Error `Not_found
468 | Some r -> r.lookup_page query
469
470let lookup_asset query env =
471 match env.resolver with
472 | None -> Error `Not_found
473 | Some r -> r.lookup_asset query
474
475let lookup_unit query env =
476 match env.resolver with
477 | None -> Error `Not_found
478 | Some r -> r.lookup_unit query
479
480let lookup_impl name env =
481 match env.resolver with None -> None | Some r -> r.lookup_impl name
482
483let lookup_page_by_name n env = lookup_page (`Name n) env
484let lookup_page_by_path p env = lookup_page (`Path p) env
485
486let lookup_asset_by_name p env = lookup_asset (`Name p) env
487let lookup_asset_by_path p env = lookup_asset (`Path p) env
488
489let lookup_unit_by_path p env =
490 match lookup_unit (`Path p) env with
491 | Ok (Found u) ->
492 let m = Component.Delayed.put_val (module_of_unit u) in
493 Ok (`Module ((u.id :> Identifier.Path.Module.t), m))
494 | Ok Forward_reference -> Error `Not_found (* TODO: Remove this case *)
495 | Error _ as e -> e
496
497type 'a scope = {
498 filter : Component.Element.any -> ([< Component.Element.any ] as 'a) option;
499 check : (t -> ([< Component.Element.any ] as 'a) -> 'a amb_err option) option;
500 root : string -> t -> 'a option;
501}
502
503type 'a maybe_ambiguous = ('a, [ 'a amb_err | `Not_found ]) result
504
505let make_scope ?(root = fun _ _ -> None) ?check
506 (filter : _ -> ([< Component.Element.any ] as 'a) option) : 'a scope =
507 { filter; check; root }
508
509let lookup_by_name scope name env =
510 let record_lookup_results env results =
511 match env.recorder with
512 | Some r ->
513 List.iter
514 (function
515 | `Module (id, _) ->
516 r.lookups <-
517 LookupTypeSet.add (ModuleByName (name, id)) r.lookups
518 | _ -> ())
519 (results :> Component.Element.any list)
520 | None -> ()
521 in
522 match
523 (ElementsByName.find_by_name scope.filter name env.elts, scope.check)
524 with
525 | ([ x ] as results), Some c -> (
526 record_lookup_results env results;
527 match c env x with Some (`Ambiguous _ as e) -> Error e | None -> Ok x)
528 | ([ x ] as results), None ->
529 record_lookup_results env results;
530 Ok x
531 | (x :: tl as results), _ ->
532 record_lookup_results env results;
533 Error (`Ambiguous (x, tl))
534 | [], _ -> (
535 match scope.root name env with Some x -> Ok x | None -> Error `Not_found)
536
537let lookup_by_id (scope : 'a scope) id env : 'a option =
538 let record_lookup_result result =
539 match env.recorder with
540 | Some r -> (
541 match (result :> Component.Element.any) with
542 | `Module (id, _) ->
543 r.lookups <- LookupTypeSet.add (Module id) r.lookups
544 | `ModuleType (id, _) ->
545 r.lookups <- LookupTypeSet.add (ModuleType id) r.lookups
546 | _ -> ())
547 | None -> ()
548 in
549 match ElementsById.find_by_id id env.ids with
550 | Some x ->
551 record_lookup_result x;
552 scope.filter x
553 | None -> (
554 (* Format.eprintf "Can't find %a\n%!" Component.Fmt.model_identifier (id :> Identifier.t); *)
555 match (id :> Identifier.t) with
556 | { iv = `Root (_, name); _ } ->
557 scope.root (ModuleName.to_string name) env
558 | _ -> None)
559
560let lookup_root_module_fallback name t =
561 match lookup_root_module (ModuleName.make_std name) t with
562 | Some (Resolved (_, id, m)) ->
563 Some
564 (`Module ((id :> Identifier.Path.Module.t), Component.Delayed.put_val m))
565 | Some Forward | None -> None
566
567let lookup_page_or_root_module_fallback name t =
568 match lookup_root_module_fallback name t with
569 | Some _ as x -> x
570 | None -> (
571 match lookup_page_by_name name t with
572 | Ok page -> Some (`Page (page.Lang.Page.name, page))
573 | Error `Not_found -> None)
574
575let s_signature : Component.Element.signature scope =
576 make_scope ~root:lookup_root_module_fallback (function
577 | #Component.Element.signature as r -> Some r
578 | _ -> None)
579
580let s_module : Component.Element.module_ scope =
581 make_scope ~root:lookup_root_module_fallback (function
582 | #Component.Element.module_ as r -> Some r
583 | _ -> None)
584
585let s_any : Component.Element.any scope =
586 make_scope ~root:lookup_page_or_root_module_fallback
587 ~check:(fun env -> function
588 | `Label (id, _) -> (
589 try
590 Some
591 (Identifier.Maps.Label.find id env.ambiguous_labels
592 :> Component.Element.any amb_err)
593 with Not_found -> None)
594 | _ -> None)
595 (function
596 (* Reference to [A] could refer to [extension-A] or [extension-decl-A].
597 The legacy behavior refers to the constructor [extension-A]. *)
598 | #Component.Element.extension_decl -> None
599 | r -> Some r)
600
601let s_module_type : Component.Element.module_type scope =
602 make_scope (function
603 | #Component.Element.module_type as r -> Some r
604 | _ -> None)
605
606let s_type : Component.Element.type_ scope =
607 make_scope (function #Component.Element.type_ as r -> Some r | _ -> None)
608
609let s_datatype : Component.Element.datatype scope =
610 make_scope (function #Component.Element.datatype as r -> Some r | _ -> None)
611
612let s_class : Component.Element.class_ scope =
613 make_scope (function #Component.Element.class_ as r -> Some r | _ -> None)
614
615let s_class_type : Component.Element.class_type scope =
616 make_scope (function
617 | #Component.Element.class_type as r -> Some r
618 | _ -> None)
619
620let s_value : Component.Element.value scope =
621 make_scope (function #Component.Element.value as r -> Some r | _ -> None)
622
623let s_label : Component.Element.label scope =
624 make_scope
625 ~check:(fun env -> function
626 | `Label (id, _) -> (
627 try Some (Identifier.Maps.Label.find id env.ambiguous_labels)
628 with Not_found -> None))
629 (function #Component.Element.label as r -> Some r | _ -> None)
630
631let s_constructor : Component.Element.constructor scope =
632 make_scope (function
633 | #Component.Element.constructor as r -> Some r
634 | _ -> None)
635
636let s_exception : Component.Element.exception_ scope =
637 make_scope (function
638 | #Component.Element.exception_ as r -> Some r
639 | _ -> None)
640
641let s_extension : Component.Element.extension scope =
642 make_scope (function
643 | #Component.Element.extension as r -> Some r
644 | _ -> None)
645
646let s_field : Component.Element.field scope =
647 make_scope (function #Component.Element.field as r -> Some r | _ -> None)
648
649let s_unboxed_field : Component.Element.unboxed_field scope =
650 make_scope (function
651 | #Component.Element.unboxed_field as r -> Some r
652 | _ -> None)
653
654let s_label_parent : Component.Element.label_parent scope =
655 make_scope ~root:lookup_page_or_root_module_fallback (function
656 | #Component.Element.label_parent as r -> Some r
657 | _ -> None)
658
659let s_fragment_type_parent : Component.Element.fragment_type_parent scope =
660 make_scope ~root:lookup_root_module_fallback (function
661 | #Component.Element.fragment_type_parent as r -> Some r
662 | _ -> None)
663
664let len = ref 0
665
666let n = ref 0
667
668let lookup_fragment_root env =
669 let maybe_record_result res =
670 match env.recorder with
671 | Some r -> r.lookups <- LookupTypeSet.add res r.lookups
672 | None -> ()
673 in
674 match env.fragmentroot with
675 | Some (i, _) as result ->
676 maybe_record_result (FragmentRoot i);
677 result
678 | None -> None
679
680let mk_functor_parameter module_type =
681 let type_ = Component.Module.ModuleType module_type in
682 Component.Module.
683 {
684 source_loc = None;
685 source_loc_jane = None;
686 doc = { elements = []; warnings_tag = None };
687 type_;
688 canonical = None;
689 hidden = false;
690 }
691
692let add_functor_parameter : Lang.FunctorParameter.t -> t -> t =
693 fun p t ->
694 match p with
695 | Unit -> t
696 | Named n ->
697 let id = (n.id :> Paths.Identifier.Path.Module.t) in
698 let m =
699 let open Component.Of_Lang in
700 mk_functor_parameter (module_type_expr (empty ()) n.expr)
701 in
702 add_module id
703 (Component.Delayed.put_val m)
704 { elements = []; warnings_tag = None }
705 t
706
707let add_functor_args' :
708 Paths.Identifier.Signature.t -> Component.ModuleType.expr -> t -> t =
709 let open Component in
710 fun id expr env ->
711 let rec find_args parent mty =
712 match mty with
713 | ModuleType.Functor (Named arg, res) ->
714 ( arg.Component.FunctorParameter.id,
715 Paths.Identifier.Mk.parameter
716 (parent, Ident.Name.typed_module arg.Component.FunctorParameter.id),
717 mk_functor_parameter arg.expr )
718 :: find_args (Paths.Identifier.Mk.result parent) res
719 | ModuleType.Functor (Unit, res) ->
720 find_args (Paths.Identifier.Mk.result parent) res
721 | _ -> []
722 in
723 (* We substituted back the parameters as identifiers to maintain the
724 invariant that components in the environment are 'self-contained' - that
725 is, they only contain local idents for things that are declared within
726 themselves *)
727 let fold_fn (env, subst) (ident, identifier, m) =
728 let ident, identifier =
729 ((ident, identifier) :> Ident.module_ * Identifier.Path.Module.t)
730 in
731 let doc = m.Component.Module.doc in
732 let m = Component.Delayed.put_val (Subst.module_ subst m) in
733 let rp = `Gpath (`Identifier identifier) in
734 let p = `Resolved rp in
735 let env' = add_module identifier m doc env in
736 (env', Subst.add_module ident p rp subst)
737 in
738 let env', _subst =
739 List.fold_left fold_fn (env, Subst.identity) (find_args id expr)
740 in
741 env'
742
743let add_module_functor_args m id env =
744 match m.Component.Module.type_ with
745 | Alias _ -> env
746 | ModuleType expr ->
747 add_functor_args' (id :> Paths.Identifier.Signature.t) expr env
748
749let add_module_type_functor_args mt id env =
750 match mt.Component.ModuleType.expr with
751 | None -> env
752 | Some expr -> add_functor_args' (id :> Paths.Identifier.Signature.t) expr env
753
754let open_class_signature : Lang.ClassSignature.t -> t -> t =
755 let open Component in
756 let open Of_Lang in
757 fun s env ->
758 List.fold_left
759 (fun env orig ->
760 match orig with
761 | Lang.ClassSignature.Method m ->
762 let ty = method_ (empty ()) m in
763 add_method m.Lang.Method.id ty env
764 | _ -> env)
765 env s.items
766
767let rec open_signature : Lang.Signature.t -> t -> t =
768 let open Component in
769 let open Of_Lang in
770 let module L = Lang in
771 fun s e ->
772 let ident_map = empty () in
773 List.fold_left
774 (fun env orig ->
775 match ((orig : L.Signature.item), env.linking) with
776 | Type (_, t), _ ->
777 let ty = type_decl ident_map t in
778 add_type t.L.TypeDecl.id ty env
779 | Module (_, t), _ ->
780 let ty = Component.Delayed.put (fun () -> module_ ident_map t) in
781 add_module
782 (t.L.Module.id :> Identifier.Path.Module.t)
783 ty
784 (docs ident_map t.L.Module.doc)
785 env
786 | ModuleType t, _ ->
787 let ty = module_type ident_map t in
788 add_module_type t.L.ModuleType.id ty env
789 | ModuleTypeSubstitution _, _
790 | L.Signature.TypeSubstitution _, _
791 | L.Signature.ModuleSubstitution _, _ ->
792 env
793 | L.Signature.Class (_, c), _ ->
794 let ty = class_ ident_map c in
795 add_class c.id ty env
796 | L.Signature.ClassType (_, c), _ ->
797 let ty = class_type ident_map c in
798 add_class_type c.id ty env
799 | L.Signature.Include i, _ -> open_signature i.expansion.content env
800 | L.Signature.Open o, false -> open_signature o.expansion env
801 (* The following are only added when linking *)
802 | L.Signature.Open o, true ->
803 add_comment (`Docs o.doc) (open_signature o.expansion env)
804 | Comment c, true -> add_comment c env
805 | TypExt te, true ->
806 let doc = docs ident_map te.doc in
807 let te' = extension ident_map te in
808 List.fold_left
809 (fun env tec ->
810 let ty = extension_constructor ident_map tec in
811 add_extension_constructor tec.L.Extension.Constructor.id ty te'
812 env)
813 env te.L.Extension.constructors
814 |> add_cdocs te.L.Extension.parent doc
815 | Exception e, true ->
816 let ty = exception_ ident_map e in
817 add_exception e.L.Exception.id ty env
818 | L.Signature.Value v, true ->
819 let ty = value ident_map v in
820 add_value v.L.Value.id ty env
821 (* Skip when compiling *)
822 | Exception _, false -> env
823 | TypExt _, false -> env
824 | Comment _, false -> env
825 | L.Signature.Value _, false -> env)
826 e s.items
827
828let open_type_substitution : Odoc_model.Lang.TypeDecl.t -> t -> t =
829 fun t env ->
830 let open Component in
831 let open Of_Lang in
832 let ty = type_decl (empty ()) t in
833 add_type t.Lang.TypeDecl.id ty env
834
835let open_module_substitution : Odoc_model.Lang.ModuleSubstitution.t -> t -> t =
836 fun m env ->
837 let open Component in
838 let open Of_Lang in
839 let _id = Ident.Of_Identifier.module_ m.id in
840 let doc = docs (empty ()) m.doc in
841 let ty =
842 Component.Delayed.put (fun () ->
843 Of_Lang.(
844 module_of_module_substitution
845 (* { empty with modules = [ (m.id, id) ] } *)
846 (empty ())
847 m))
848 in
849 add_module (m.id :> Identifier.Path.Module.t) ty doc env
850
851let open_module_type_substitution : Lang.ModuleTypeSubstitution.t -> t -> t =
852 fun t env ->
853 let open Component in
854 let open Of_Lang in
855 let ty =
856 module_type (empty ())
857 {
858 id = t.id;
859 source_loc = None;
860 source_loc_jane = None;
861 doc = t.doc;
862 expr = Some t.manifest;
863 canonical = None;
864 }
865 in
866 add_module_type t.Lang.ModuleTypeSubstitution.id ty env
867
868let open_units resolver env =
869 List.fold_left
870 (fun env m ->
871 match resolver.lookup_unit (`Name m) with
872 | Ok (Found unit) -> (
873 match unit.content with
874 | Module sg -> open_signature sg env
875 | _ -> env)
876 | _ -> env)
877 env resolver.open_units
878
879let inherit_resolver env =
880 match env.resolver with
881 | Some r ->
882 let e = set_resolver empty r in
883 open_units r e
884 | None -> empty
885
886let env_of_unit t ~linking resolver =
887 let open Lang.Compilation_unit in
888 let initial_env =
889 let m = module_of_unit t in
890 let dm = Component.Delayed.put (fun () -> m) in
891 let env = { empty with linking } in
892 env |> add_module (t.id :> Identifier.Path.Module.t) dm m.doc
893 in
894 set_resolver initial_env resolver |> open_units resolver
895
896let open_page page env = add_docs page.Lang.Page.content env
897
898let env_of_page page resolver =
899 let initial_env = open_page page empty in
900 set_resolver initial_env resolver |> open_units resolver
901
902let env_of_impl _impl resolver =
903 set_resolver empty resolver |> open_units resolver
904
905let env_for_reference resolver =
906 set_resolver empty resolver |> open_units resolver
907
908let env_for_testing ~linking = { empty with linking }
909
910let verify_lookups env lookups =
911 let bad_lookup = function
912 | Module id ->
913 let actually_found =
914 match lookup_by_id s_module id env with
915 | Some _ -> true
916 | None -> false
917 in
918 true <> actually_found
919 | RootModule (name, res) -> (
920 let actual_result =
921 match env.resolver with
922 | None -> None
923 | Some r -> (
924 match r.lookup_unit (`Name (ModuleName.to_string name)) with
925 | Ok Forward_reference -> Some `Forward
926 | Ok (Found u) -> Some (`Resolved u.root.digest)
927 | Error `Not_found -> None)
928 in
929 match (res, actual_result) with
930 | None, None -> false
931 | Some `Forward, Some `Forward -> false
932 | Some (`Resolved digest1), Some (`Resolved digest2) ->
933 digest1 <> digest2
934 | _ -> true)
935 | ModuleType id ->
936 let actually_found =
937 match lookup_by_id s_module_type id env with
938 | Some _ -> true
939 | None -> false
940 in
941 true <> actually_found
942 | ModuleByName (name, result) -> (
943 match lookup_by_name s_module name env with
944 | Ok (`Module (id', _)) -> result <> id'
945 | Error `Not_found -> false
946 | Error (`Ambiguous (hd, tl)) ->
947 not
948 (List.exists (fun (`Module (id', _)) -> result = id') (hd :: tl)))
949 | FragmentRoot _i -> true
950 (* begin
951 try
952 let (i', _) = Env.lookup_fragment_root env in
953 i' <> i
954 with _ ->
955 true
956 end*)
957 in
958 let result = not (LookupTypeSet.exists bad_lookup lookups) in
959 (* If we're recording lookups, make sure it looks like we
960 looked all this stuff up *)
961 (match (result, env.recorder) with
962 | true, Some r -> r.lookups <- LookupTypeSet.union r.lookups lookups
963 | _ -> ());
964 result