jon.recoil.org
this repo has no description
1(* Second round of resolution tackles references and forward paths *)
2open Odoc_model
3open Lang
4module Id = Paths.Identifier
5
6module Opt = struct
7 let map f = function Some x -> Some (f x) | None -> None
8end
9
10(* omg. Our current warning system is spread on different system. Hence this
11 atrocity. *)
12let maybe_suppress env warnings_tag =
13 if Env.should_suppress_warnings env warnings_tag then fun f ->
14 Lookup_failures.catch_failures ~filename:"" (fun () ->
15 Error.catch_warnings f |> fun x ->
16 Error.unpack_warnings x |> fst |> Error.unpack_warnings |> fst)
17 |> Error.unpack_warnings |> fst
18 else fun f -> f () |> Error.raise_warnings
19
20let source_loc env id loc =
21 let id = (id :> Id.NonSrc.t) in
22 match loc with Some _ as loc -> loc | None -> Shape_tools.lookup_def env id
23
24(** Equivalent to {!Comment.synopsis}. *)
25let synopsis_from_comment (docs : Component.CComment.docs) =
26 match docs.elements with
27 | ({ value = #Comment.nestable_block_element; _ } as e) :: _ ->
28 (* Only the first element is considered. *)
29 Comment.synopsis [ e ]
30 | _ -> None
31
32let synopsis_of_module env (m : Component.Module.t) =
33 let open Odoc_utils.ResultMonad in
34 match synopsis_from_comment m.doc with
35 | Some _ as s -> s
36 | None -> (
37 let rec handle_expansion : Tools.expansion -> _ = function
38 | Functor (_, expr) -> (
39 match Tools.expansion_of_module_type_expr env expr with
40 | Ok e -> handle_expansion e
41 | Error _ as e -> e)
42 | Signature sg -> Ok sg
43 in
44 (* If there is no doc, look at the expansion. *)
45 match
46 Tools.expansion_of_module env m >>= fun exp -> handle_expansion exp
47 with
48 | Ok sg -> synopsis_from_comment (Component.extract_signature_doc sg)
49 | Error _ -> None)
50
51let ambiguous_label_warning label_name labels =
52 let pp_label_loc fmt (`Label (_, x)) =
53 Location_.pp_span_start fmt x.Component.Label.location
54 in
55 Lookup_failures.report_warning
56 "@[<2>Label '%s' is ambiguous. The other occurences are:@ %a@]" label_name
57 (Format.pp_print_list ~pp_sep:Format.pp_force_newline pp_label_loc)
58 labels
59
60(** Raise a warning when a label explicitly set by the user collides. This
61 warning triggers even if one of the colliding labels have been automatically
62 generated. *)
63let check_ambiguous_label ~loc env
64 ( attrs,
65 ({ Odoc_model.Paths.Identifier.iv = `Label (_, label_name); _ } as id),
66 _ ) =
67 if attrs.Comment.heading_label_explicit then
68 (* Looking for an identical identifier but a different location. *)
69 let conflicting (`Label (id', comp)) =
70 Id.equal id id'
71 && not (Location_.span_equal comp.Component.Label.location loc)
72 in
73 let label_name = Names.LabelName.to_string label_name in
74 match Env.lookup_by_name Env.s_label label_name env with
75 | Ok lbl when conflicting lbl -> ambiguous_label_warning label_name [ lbl ]
76 | Error (`Ambiguous (hd, tl)) -> (
77 match List.filter conflicting (hd :: tl) with
78 | [] -> ()
79 | xs -> ambiguous_label_warning label_name xs)
80 | Ok _ | Error `Not_found -> ()
81
82let expansion_needed self target =
83 let self = (self :> Paths.Path.Resolved.t) in
84 let hidden_alias = Paths.Path.Resolved.is_hidden self
85 and self_canonical =
86 let i = Paths.Path.Resolved.identifier self in
87 i = Some (target :> Paths.Identifier.t)
88 in
89
90 self_canonical || hidden_alias
91
92exception Loop
93
94let rec is_forward : Paths.Path.Module.t -> bool = function
95 | `Resolved _ -> false
96 | `Root _ -> false
97 | `Forward _ -> true
98 | `Identifier _ -> false
99 | `Dot (p, _) -> is_forward p
100 | `Apply (p1, p2) -> is_forward p1 || is_forward p2
101 | `Substituted s -> is_forward s
102
103let rec should_reresolve : Paths.Path.Resolved.t -> bool =
104 fun p ->
105 let open Paths.Path.Resolved in
106 match p with
107 | `CoreType _ -> false
108 | `Identifier _ -> false
109 | `Subst (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> t)
110 | `Hidden p -> should_reresolve (p :> t)
111 | `Canonical (x, y) ->
112 should_reresolve (x :> t) || should_resolve (y :> Paths.Path.t)
113 | `CanonicalModuleType (x, y) ->
114 should_reresolve (x :> t) || should_resolve (y :> Paths.Path.t)
115 | `CanonicalType (x, y) ->
116 should_reresolve (x :> t) || should_resolve (y :> Paths.Path.t)
117 | `Apply (x, y) ->
118 should_reresolve (x :> t) || should_reresolve (y :> Paths.Path.Resolved.t)
119 | `SubstT (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> t)
120 | `Alias (y, x) ->
121 should_resolve (x :> Paths.Path.t) || should_reresolve (y :> t)
122 | `AliasModuleType (x, y) ->
123 should_reresolve (x :> t) || should_reresolve (y :> t)
124 | `Type (p, _)
125 | `Value (p, _)
126 | `Class (p, _)
127 | `ClassType (p, _)
128 | `ModuleType (p, _)
129 | `Module (p, _) ->
130 should_reresolve (p :> t)
131 | `OpaqueModule m -> should_reresolve (m :> t)
132 | `OpaqueModuleType m -> should_reresolve (m :> t)
133 | `Substituted m -> should_reresolve (m :> t)
134 | `SubstitutedMT m -> should_reresolve (m :> t)
135 | `SubstitutedT m -> should_reresolve (m :> t)
136 | `SubstitutedCT m -> should_reresolve (m :> t)
137
138and should_resolve : Paths.Path.t -> bool =
139 fun p -> match p with `Resolved p -> should_reresolve p | _ -> true
140
141let type_path : Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t =
142 fun env p ->
143 if not (should_resolve (p :> Paths.Path.t)) then p
144 else
145 let cp = Component.Of_Lang.(type_path (empty ()) p) in
146 match cp with
147 | `Resolved p ->
148 let result = Tools.reresolve_type env p in
149 `Resolved Lang_of.(Path.resolved_type (empty ()) result)
150 | _ -> (
151 match Tools.resolve_type_path env cp with
152 | Ok p' ->
153 let result = Tools.reresolve_type env p' in
154 `Resolved Lang_of.(Path.resolved_type (empty ()) result)
155 | Error e ->
156 Errors.report ~what:(`Type_path cp) ~tools_error:e `Lookup;
157 p)
158
159let value_path : Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t =
160 fun env p ->
161 if not (should_resolve (p :> Paths.Path.t)) then p
162 else
163 let cp = Component.Of_Lang.(value_path (empty ()) p) in
164 match cp with
165 | `Resolved p ->
166 let result = Tools.reresolve_value env p in
167 `Resolved Lang_of.(Path.resolved_value (empty ()) result)
168 | _ -> (
169 match Tools.resolve_value_path env cp with
170 | Ok p' ->
171 let result = Tools.reresolve_value env p' in
172 `Resolved Lang_of.(Path.resolved_value (empty ()) result)
173 | Error e ->
174 Errors.report ~what:(`Value_path cp) ~tools_error:e `Lookup;
175 p)
176
177let class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t
178 =
179 fun env p ->
180 if not (should_resolve (p :> Paths.Path.t)) then p
181 else
182 let cp = Component.Of_Lang.(class_type_path (empty ()) p) in
183 match cp with
184 | `Resolved p ->
185 let result = Tools.reresolve_class_type env p in
186 `Resolved Lang_of.(Path.resolved_class_type (empty ()) result)
187 | _ -> (
188 match Tools.resolve_class_type_path env cp with
189 | Ok p' ->
190 let result = Tools.reresolve_class_type env p' in
191 `Resolved Lang_of.(Path.resolved_class_type (empty ()) result)
192 | Error e ->
193 Errors.report ~what:(`Class_type_path cp) ~tools_error:e `Lookup;
194 p)
195
196and module_type_path :
197 Env.t -> Paths.Path.ModuleType.t -> Paths.Path.ModuleType.t =
198 fun env p ->
199 if not (should_resolve (p :> Paths.Path.t)) then p
200 else
201 let cp = Component.Of_Lang.(module_type_path (empty ()) p) in
202 match cp with
203 | `Resolved p ->
204 let result = Tools.reresolve_module_type env p in
205 `Resolved Lang_of.(Path.resolved_module_type (empty ()) result)
206 | _ -> (
207 match Tools.resolve_module_type_path env cp with
208 | Ok p' ->
209 let result = Tools.reresolve_module_type env p' in
210 `Resolved Lang_of.(Path.resolved_module_type (empty ()) result)
211 | Error e ->
212 Errors.report ~what:(`Module_type_path cp) ~tools_error:e `Resolve;
213 p)
214
215and module_path : Env.t -> Paths.Path.Module.t -> Paths.Path.Module.t =
216 fun env p ->
217 if not (should_resolve (p :> Paths.Path.t)) then p
218 else
219 let cp = Component.Of_Lang.(module_path (empty ()) p) in
220 match cp with
221 | `Resolved p ->
222 let after = Tools.reresolve_module env p in
223 `Resolved Lang_of.(Path.resolved_module (empty ()) after)
224 | _ -> (
225 match Tools.resolve_module_path env cp with
226 | Ok p' ->
227 let result = Tools.reresolve_module env p' in
228 `Resolved Lang_of.(Path.resolved_module (empty ()) result)
229 | Error _ when is_forward p -> p
230 | Error e ->
231 Errors.report ~what:(`Module_path cp) ~tools_error:e `Resolve;
232 p)
233
234let rec comment_inline_element :
235 loc:_ ->
236 Env.t ->
237 string option ->
238 Comment.inline_element ->
239 Comment.inline_element =
240 fun ~loc:_ env warnings_tag x ->
241 match x with
242 | `Styled (s, ls) ->
243 `Styled
244 ( s,
245 List.map (with_location (comment_inline_element env warnings_tag)) ls
246 )
247 | `Reference (r, content) as orig -> (
248 match
249 maybe_suppress env warnings_tag (fun () ->
250 Ref_tools.resolve_reference env r)
251 with
252 | Ok (ref_, c) ->
253 let content =
254 (* In case of labels, use the heading text as reference text if
255 it's not specified. *)
256 match (content, c) with
257 | [], Some content ->
258 Comment.link_content_of_inline_elements content
259 | content, _ -> content
260 in
261 `Reference (`Resolved ref_, content)
262 | Error e ->
263 if not (Env.should_suppress_warnings env warnings_tag) then
264 Errors.report ~what:(`Reference r) ~tools_error:(`Reference e)
265 `Resolve;
266 orig)
267 | y -> y
268
269and paragraph env warnings_tag elts =
270 List.map (with_location (comment_inline_element env warnings_tag)) elts
271
272and resolve_external_synopsis env warnings_tag synopsis =
273 let env = Env.inherit_resolver env in
274 paragraph env warnings_tag synopsis
275
276and comment_nestable_block_element env warnings_tag parent ~loc:_
277 (x : Comment.nestable_block_element) =
278 match x with
279 | `Paragraph elts -> `Paragraph (paragraph env warnings_tag elts)
280 | (`Code_block _ | `Math_block _ | `Verbatim _) as x -> x
281 | `List (x, ys) ->
282 `List
283 ( x,
284 List.rev_map
285 (comment_nestable_block_element_list env warnings_tag parent)
286 ys
287 |> List.rev )
288 | `Table { data; align } ->
289 let data =
290 let map f x = List.rev_map f x |> List.rev in
291 map
292 (map (fun (cell, cell_type) ->
293 ( comment_nestable_block_element_list env warnings_tag parent cell,
294 cell_type )))
295 data
296 in
297 `Table { Comment.data; align }
298 | `Modules refs ->
299 let refs =
300 List.rev_map
301 (fun (r : Comment.module_reference) ->
302 match
303 maybe_suppress env warnings_tag (fun () ->
304 Ref_tools.resolve_module_reference env r.module_reference)
305 with
306 | Ok (r, _, m) ->
307 let module_synopsis =
308 Opt.map
309 (resolve_external_synopsis env warnings_tag)
310 (synopsis_of_module env m)
311 in
312 { Comment.module_reference = `Resolved r; module_synopsis }
313 | Error e ->
314 if not (Env.should_suppress_warnings env warnings_tag) then
315 Errors.report
316 ~what:(`Reference (r.module_reference :> Paths.Reference.t))
317 ~tools_error:(`Reference e) `Resolve;
318 r)
319 refs
320 |> List.rev
321 in
322 `Modules refs
323 | `Media (`Reference r, m, content) as orig -> (
324 match
325 maybe_suppress env warnings_tag (fun () ->
326 Ref_tools.resolve_asset_reference env r)
327 with
328 | Ok x -> `Media (`Reference (`Resolved x), m, content)
329 | Error e ->
330 if not (Env.should_suppress_warnings env warnings_tag) then
331 Errors.report
332 ~what:(`Reference (r :> Paths.Reference.t))
333 ~tools_error:(`Reference e) `Resolve;
334 orig)
335 | `Media _ as orig -> orig
336
337and comment_nestable_block_element_list env warnings_tag parent
338 (xs : Comment.nestable_block_element Comment.with_location list) =
339 List.rev_map
340 (with_location (comment_nestable_block_element env warnings_tag parent))
341 xs
342 |> List.rev
343
344and comment_tag env warnings_tag parent ~loc:_ (x : Comment.tag) =
345 match x with
346 | `Custom (name, content) ->
347 let resolved =
348 comment_nestable_block_element_list env warnings_tag parent content
349 in
350 let prefix = Odoc_extension_registry.prefix_of_tag name in
351 let content =
352 match Odoc_extension_registry.find_link_handler ~prefix with
353 | Some handler -> handler name (Obj.repr env) resolved
354 | None -> resolved
355 in
356 `Custom (name, content)
357 | `Deprecated content ->
358 `Deprecated
359 (comment_nestable_block_element_list env warnings_tag parent content)
360 | `Param (name, content) ->
361 `Param
362 ( name,
363 comment_nestable_block_element_list env warnings_tag parent content )
364 | `Raise ((`Reference (r, reference_content) as orig), content) -> (
365 match
366 maybe_suppress env warnings_tag (fun () ->
367 Ref_tools.resolve_reference env r)
368 with
369 | Ok (x, _) ->
370 `Raise
371 ( `Reference (`Resolved x, reference_content),
372 comment_nestable_block_element_list env warnings_tag parent
373 content )
374 | Error e ->
375 if not (Env.should_suppress_warnings env warnings_tag) then
376 Errors.report ~what:(`Reference r) ~tools_error:(`Reference e)
377 `Resolve;
378 `Raise
379 ( orig,
380 comment_nestable_block_element_list env warnings_tag parent
381 content ))
382 | `Raise ((`Code_span _ as orig), content) ->
383 `Raise
384 ( orig,
385 comment_nestable_block_element_list env warnings_tag parent content )
386 | `Return content ->
387 `Return
388 (comment_nestable_block_element_list env warnings_tag parent content)
389 | `See (kind, target, content) ->
390 `See
391 ( kind,
392 target,
393 comment_nestable_block_element_list env warnings_tag parent content )
394 | `Before (version, content) ->
395 `Before
396 ( version,
397 comment_nestable_block_element_list env warnings_tag parent content )
398 | `Author _ | `Since _ | `Alert _ | `Version _ ->
399 x (* only contain primitives *)
400
401and comment_block_element env warnings_tag parent ~loc
402 (x : Comment.block_element) =
403 match x with
404 | #Comment.nestable_block_element as x ->
405 (comment_nestable_block_element env warnings_tag parent ~loc x
406 :> Comment.block_element)
407 | `Heading (attrs, label, elems) ->
408 let cie = comment_inline_element env warnings_tag in
409 let elems =
410 List.rev_map (fun ele -> with_location cie ele) elems |> List.rev
411 in
412 let h = (attrs, label, elems) in
413 check_ambiguous_label ~loc env h;
414 `Heading h
415 | `Tag t -> `Tag (comment_tag env warnings_tag parent ~loc t)
416
417and with_location : type a.
418 (loc:_ -> a -> a) -> a Location_.with_location -> a Location_.with_location
419 =
420 fun fn { value; location = loc } ->
421 let value = Lookup_failures.with_location loc (fun () -> fn ~loc value) in
422 { value; location = loc }
423
424and comment_docs env parent d =
425 {
426 Comment.elements =
427 List.rev_map
428 (with_location
429 (comment_block_element env d.Comment.warnings_tag
430 (parent :> Id.LabelParent.t)))
431 d.Comment.elements
432 |> List.rev;
433 warnings_tag = d.warnings_tag;
434 }
435
436and comment env parent = function
437 | `Stop -> `Stop
438 | `Docs d -> `Docs (comment_docs env parent d)
439
440and open_ env parent = function
441 | { Odoc_model__Lang.Open.doc; _ } as open_ ->
442 { open_ with doc = comment_docs env parent doc }
443
444let warn_on_hidden_representation (id : Id.Type.t)
445 (r : Lang.TypeDecl.Representation.t) =
446 let open Paths.Identifier in
447 let rec internal_typ_exp typ_expr =
448 let open Lang.TypeExpr in
449 let open Paths.Path in
450 match typ_expr with
451 | Constr (p, ts) ->
452 is_hidden (p :> Paths.Path.t)
453 || List.exists (fun t -> internal_typ_exp t) ts
454 | Poly (_, t) | Alias (t, _) -> internal_typ_exp t
455 | Arrow (_, t, t2, _, _) -> internal_typ_exp t || internal_typ_exp t2
456 | Tuple ts -> List.exists (fun (_, t) -> internal_typ_exp t) ts
457 | Class (_, ts) -> List.exists (fun t -> internal_typ_exp t) ts
458 | _ -> false
459 in
460
461 let internal_cstr_arg t =
462 let open Lang.TypeDecl.Constructor in
463 let open Lang.TypeDecl.Field in
464 match t.args with
465 | Tuple type_exprs ->
466 List.exists (fun type_expr -> internal_typ_exp type_expr) type_exprs
467 | Record fields ->
468 List.exists (fun field -> internal_typ_exp field.type_) fields
469 in
470
471 let internal_field t =
472 let open Lang.TypeDecl.Field in
473 internal_typ_exp t.type_
474 in
475
476 let internal_unboxed_field t =
477 let open Lang.TypeDecl.UnboxedField in
478 internal_typ_exp t.type_
479 in
480
481 let fmt_cfg = Component.Fmt.{ default with short_paths = true } in
482 match r with
483 | Variant constructors ->
484 if List.exists internal_cstr_arg constructors then
485 Lookup_failures.report_warning "@[<2>Hidden constructors in type '%a'@]"
486 Component.Fmt.(model_identifier fmt_cfg)
487 (id :> Id.any)
488 | Record fields -> (
489 match List.filter internal_field fields with
490 | [] -> ()
491 | hidden ->
492 let field_names =
493 List.map
494 (fun f -> Paths.Identifier.name f.Lang.TypeDecl.Field.id)
495 hidden
496 in
497 Lookup_failures.report_warning
498 "@[<2>Hidden fields in type '%a': %s@]"
499 Component.Fmt.(model_identifier fmt_cfg)
500 (id :> Id.any) (String.concat ", " field_names))
501 | Record_unboxed_product fields ->
502 if List.exists internal_unboxed_field fields then
503 Lookup_failures.report_warning "@[<2>Hidden unboxed fields in type '%a'@]"
504 Component.Fmt.(model_identifier fmt_cfg)
505 (id :> Id.any)
506 | Extensible -> ()
507
508let rec unit env t =
509 let open Compilation_unit in
510 let content =
511 if t.hidden then t.content
512 else
513 match t.content with
514 | Module sg ->
515 let sg = signature env (t.id :> Id.Signature.t) sg in
516 Module sg
517 | Pack _ as p -> p
518 in
519 let source_loc = source_loc env t.id t.source_loc in
520 { t with content; linked = true; source_loc }
521
522and value_ env parent t =
523 let open Value in
524 {
525 t with
526 source_loc = source_loc env t.id t.source_loc;
527 doc = comment_docs env parent t.doc;
528 type_ = type_expression env parent [] t.type_;
529 }
530
531and exception_ env parent e =
532 let open Exception in
533 let res = Opt.map (type_expression env parent []) e.res in
534 let args = type_decl_constructor_argument env parent e.args in
535 let source_loc = source_loc env e.id e.source_loc in
536 let doc = comment_docs env parent e.doc in
537 { e with source_loc; res; args; doc }
538
539and extension env parent t =
540 let open Extension in
541 let constructor c =
542 let open Constructor in
543 {
544 c with
545 source_loc = source_loc env c.id c.source_loc;
546 args = type_decl_constructor_argument env parent c.args;
547 res = Opt.map (type_expression env parent []) c.res;
548 doc = comment_docs env parent c.doc;
549 }
550 in
551 let type_path = type_path env t.type_path in
552 let constructors = List.map constructor t.constructors in
553 let doc = comment_docs env parent t.doc in
554 { t with type_path; constructors; doc }
555
556and class_type_expr env parent =
557 let open ClassType in
558 function
559 | Constr (path, texps) ->
560 Constr (path, List.map (type_expression env parent []) texps)
561 | Signature s -> Signature (class_signature env parent s)
562
563and class_type env parent c =
564 let open ClassType in
565 let doc = comment_docs env parent c.doc in
566 {
567 c with
568 source_loc = source_loc env c.id c.source_loc;
569 expr = class_type_expr env parent c.expr;
570 doc;
571 }
572
573and class_signature env parent c =
574 let open ClassSignature in
575 let env = Env.open_class_signature c env in
576 let map_item = function
577 | Method m -> Method (method_ env parent m)
578 | InstanceVariable i -> InstanceVariable (instance_variable env parent i)
579 | Constraint cst -> Constraint (constraint_ env parent cst)
580 | Inherit c -> Inherit (inherit_ env parent c)
581 | Comment c -> Comment c
582 in
583 {
584 self = Opt.map (type_expression env parent []) c.self;
585 items = List.map map_item c.items;
586 doc = comment_docs env parent c.doc;
587 }
588
589and method_ env parent m =
590 let open Method in
591 let doc = comment_docs env parent m.doc in
592 { m with type_ = type_expression env parent [] m.type_; doc }
593
594and instance_variable env parent i =
595 let open InstanceVariable in
596 let doc = comment_docs env parent i.doc in
597 { i with type_ = type_expression env parent [] i.type_; doc }
598
599and constraint_ env parent cst =
600 let open ClassSignature.Constraint in
601 let left = type_expression env parent [] cst.left
602 and right = type_expression env parent [] cst.right
603 and doc = comment_docs env parent cst.doc in
604 { left; right; doc }
605
606and inherit_ env parent ih =
607 let open ClassSignature.Inherit in
608 let expr = class_type_expr env parent ih.expr
609 and doc = comment_docs env parent ih.doc in
610 { expr; doc }
611
612and class_ env parent c =
613 let open Class in
614 let rec map_decl = function
615 | ClassType expr -> ClassType (class_type_expr env parent expr)
616 | Arrow (lbl, expr, decl) ->
617 Arrow (lbl, type_expression env parent [] expr, map_decl decl)
618 in
619 let doc = comment_docs env parent c.doc in
620 let source_loc = source_loc env c.id c.source_loc in
621 let type_ = map_decl c.type_ in
622 { c with source_loc; type_; doc }
623
624and module_substitution env parent m =
625 let open ModuleSubstitution in
626 let doc = comment_docs env parent m.doc in
627 { m with manifest = module_path env m.manifest; doc }
628
629and signature : Env.t -> Id.Signature.t -> Signature.t -> _ =
630 fun env id s ->
631 let env = Env.open_signature s env |> Env.add_docs s.doc in
632 let items = signature_items env id s.items
633 and doc = comment_docs env id s.doc in
634 { s with items; doc }
635
636and signature_items :
637 Env.t -> Id.Signature.t -> Signature.item list -> Signature.item list =
638 fun env id s ->
639 let open Signature in
640 let items, _ =
641 List.fold_left
642 (fun (items, env) item ->
643 let std i = (i :: items, env) in
644 match item with
645 | Module (r, m) -> std @@ Module (r, module_ env m)
646 | ModuleSubstitution m ->
647 let env' = Env.open_module_substitution m env in
648 (ModuleSubstitution (module_substitution env id m) :: items, env')
649 | Type (r, t) -> std @@ Type (r, type_decl env id t)
650 | TypeSubstitution t ->
651 let env' = Env.open_type_substitution t env in
652 (TypeSubstitution (type_decl env id t) :: items, env')
653 | ModuleType mt -> std @@ ModuleType (module_type env mt)
654 | ModuleTypeSubstitution mts ->
655 let env' = Env.open_module_type_substitution mts env in
656 ( ModuleTypeSubstitution (module_type_substitution env mts) :: items,
657 env' )
658 | Value v -> std @@ Value (value_ env id v)
659 | Comment c -> std @@ Comment (comment env id c)
660 | TypExt t -> std @@ TypExt (extension env id t)
661 | Exception e -> std @@ Exception (exception_ env id e)
662 | Class (r, c) -> std @@ Class (r, class_ env id c)
663 | ClassType (r, c) -> std @@ ClassType (r, class_type env id c)
664 | Include i -> std @@ Include (include_ env i)
665 | Open o -> std @@ Open (open_ env id o))
666 ([], env) s
667 in
668 List.rev items
669
670and simple_expansion :
671 Env.t ->
672 Id.Signature.t ->
673 ModuleType.simple_expansion ->
674 ModuleType.simple_expansion =
675 fun env id m ->
676 match m with
677 | Signature sg -> Signature (signature env id sg)
678 | Functor (arg, sg) ->
679 let env' = Env.add_functor_parameter arg env in
680 Functor (functor_argument env arg, simple_expansion env' id sg)
681
682and module_ : Env.t -> Module.t -> Module.t =
683 fun env m ->
684 let open Module in
685 let open Odoc_utils.ResultMonad in
686 let sg_id = (m.id :> Id.Signature.t) in
687 if m.hidden then m
688 else
689 let type_ = module_decl env sg_id m.type_ in
690 let type_ =
691 match type_ with
692 | Alias (`Resolved p, _) ->
693 if expansion_needed p m.id then
694 let cp = Component.Of_Lang.(resolved_module_path (empty ()) p) in
695 match
696 Tools.expansion_of_module_path ~strengthen:false env
697 (`Resolved cp)
698 >>= Expand_tools.handle_expansion env (m.id :> Id.Signature.t)
699 with
700 | Ok (_, e) ->
701 let le = Lang_of.(simple_expansion (empty ()) sg_id e) in
702 Alias (`Resolved p, Some (simple_expansion env sg_id le))
703 | Error _ -> type_
704 else type_
705 | Alias _ | ModuleType _ -> type_
706 in
707 let source_loc = source_loc env m.id m.source_loc in
708 let doc = comment_docs env sg_id m.doc in
709 { m with source_loc; doc; type_ }
710
711and module_decl : Env.t -> Id.Signature.t -> Module.decl -> Module.decl =
712 fun env id decl ->
713 let open Module in
714 match decl with
715 | ModuleType expr -> ModuleType (module_type_expr env id expr)
716 | Alias (p, e) ->
717 Alias (module_path env p, Opt.map (simple_expansion env id) e)
718
719and include_decl : Env.t -> Id.Signature.t -> Include.decl -> Include.decl =
720 fun env id decl ->
721 let open Include in
722 let rec is_elidable_with_u : Odoc_model.Lang.ModuleType.U.expr -> bool =
723 function
724 | Path _ -> false
725 | Signature _ -> true
726 | With (_, expr) -> is_elidable_with_u expr
727 | TypeOf _ -> false
728 | Strengthen (expr, _, _) -> is_elidable_with_u expr
729 in
730 match decl with
731 | ModuleType expr when is_elidable_with_u expr -> ModuleType expr
732 | ModuleType expr -> ModuleType (u_module_type_expr env id expr)
733 | Alias p -> Alias (module_path env p)
734
735and module_type : Env.t -> ModuleType.t -> ModuleType.t =
736 fun env m ->
737 let sg_id = (m.id :> Id.Signature.t) in
738 let open ModuleType in
739 let expr' =
740 match m.expr with
741 | None -> None
742 | Some expr -> Some (module_type_expr env sg_id expr)
743 in
744 (* let self_canonical =
745 match m.expr with
746 | Some (Path (`Resolved p)) when Paths.Path.Resolved.ModuleType.canonical_ident p = Some m.id ->
747 true
748 | _ -> false
749 in*)
750 let doc = comment_docs env sg_id m.doc in
751 let source_loc = (source_loc env m.id) m.source_loc in
752 { m with source_loc; expr = expr'; doc }
753
754and module_type_substitution :
755 Env.t -> ModuleTypeSubstitution.t -> ModuleTypeSubstitution.t =
756 fun env m ->
757 let sg_id = (m.id :> Id.Signature.t) in
758 let open ModuleTypeSubstitution in
759 let manifest' = module_type_expr env sg_id m.manifest in
760 let doc = comment_docs env sg_id m.doc in
761 { m with manifest = manifest'; doc }
762
763and include_ : Env.t -> Include.t -> Include.t =
764 fun env i ->
765 let open Include in
766 let decl = include_decl env i.parent i.decl in
767 let doc = comment_docs env i.parent i.doc in
768 let expansion =
769 (* Don't call {!signature} to avoid adding the content of the expansion to
770 the environment, which is already done recursively by
771 {!Env.open_signature}. *)
772 let content =
773 (* Add context around errors from the expansion. *)
774 Lookup_failures.with_context
775 "While resolving the expansion of include at %a" Location_.pp_span_start
776 i.loc (fun () ->
777 let { content; _ } = i.expansion in
778 let items = signature_items env i.parent content.items
779 and doc = comment_docs env i.parent content.doc in
780 { content with items; doc })
781 in
782 { i.expansion with content }
783 in
784 { i with decl; expansion; doc }
785
786and functor_parameter_parameter :
787 Env.t -> FunctorParameter.parameter -> FunctorParameter.parameter =
788 fun env a ->
789 let sg_id = (a.id :> Id.Signature.t) in
790 let expr = module_type_expr env sg_id a.expr in
791 { a with expr }
792
793and functor_argument env a =
794 match a with
795 | FunctorParameter.Unit -> FunctorParameter.Unit
796 | Named arg -> Named (functor_parameter_parameter env arg)
797
798and handle_fragments env id sg subs =
799 let open ModuleType in
800 List.fold_left
801 (fun (sg_res, subs) lsub ->
802 match (sg_res, lsub) with
803 | Ok sg, ModuleEq (frag, decl) ->
804 let frag' =
805 match frag with
806 | `Resolved f ->
807 let cfrag =
808 Component.Of_Lang.(resolved_module_fragment (empty ()) f)
809 in
810 `Resolved
811 (Tools.reresolve_module_fragment env cfrag
812 |> Lang_of.(Path.resolved_module_fragment (empty ())))
813 | _ -> frag
814 in
815 let sg' =
816 Tools.fragmap env
817 Component.Of_Lang.(with_module_type_substitution (empty ()) lsub)
818 sg
819 in
820 (sg', ModuleEq (frag', module_decl env id decl) :: subs)
821 | Ok sg, TypeEq (frag, eqn) ->
822 let frag' =
823 match frag with
824 | `Resolved f ->
825 let cfrag =
826 Component.Of_Lang.(resolved_type_fragment (empty ()) f)
827 in
828 `Resolved
829 (Tools.reresolve_type_fragment env cfrag
830 |> Lang_of.(Path.resolved_type_fragment (empty ())))
831 | _ -> frag
832 in
833 let sg' =
834 Tools.fragmap env
835 Component.Of_Lang.(with_module_type_substitution (empty ()) lsub)
836 sg
837 in
838 (sg', TypeEq (frag', type_decl_equation env id eqn) :: subs)
839 | Ok sg, ModuleTypeEq (frag, eqn) ->
840 let frag' =
841 match frag with
842 | `Resolved f ->
843 let cfrag =
844 Component.Of_Lang.(resolved_module_type_fragment (empty ()) f)
845 in
846 `Resolved
847 (Tools.reresolve_module_type_fragment env cfrag
848 |> Lang_of.(Path.resolved_module_type_fragment (empty ())))
849 | _ -> frag
850 in
851 let sg' =
852 Tools.fragmap env
853 Component.Of_Lang.(with_module_type_substitution (empty ()) lsub)
854 sg
855 in
856 (sg', ModuleTypeEq (frag', module_type_expr env id eqn) :: subs)
857 | Ok sg, ModuleSubst (frag, mpath) ->
858 let frag' =
859 match frag with
860 | `Resolved f ->
861 let cfrag =
862 Component.Of_Lang.(resolved_module_fragment (empty ()) f)
863 in
864 `Resolved
865 (Tools.reresolve_module_fragment env cfrag
866 |> Lang_of.(Path.resolved_module_fragment (empty ())))
867 | _ -> frag
868 in
869 let sg' =
870 Tools.fragmap env
871 Component.Of_Lang.(with_module_type_substitution (empty ()) lsub)
872 sg
873 in
874 (sg', ModuleSubst (frag', module_path env mpath) :: subs)
875 | Ok sg, TypeSubst (frag, eqn) ->
876 let frag' =
877 match frag with
878 | `Resolved f ->
879 let cfrag =
880 Component.Of_Lang.(resolved_type_fragment (empty ()) f)
881 in
882 `Resolved
883 (Tools.reresolve_type_fragment env cfrag
884 |> Lang_of.(Path.resolved_type_fragment (empty ())))
885 | _ -> frag
886 in
887 let sg' =
888 Tools.fragmap env
889 Component.Of_Lang.(with_module_type_substitution (empty ()) lsub)
890 sg
891 in
892 (sg', TypeSubst (frag', type_decl_equation env id eqn) :: subs)
893 | Ok sg, ModuleTypeSubst (frag, eqn) ->
894 let frag' =
895 match frag with
896 | `Resolved f ->
897 let cfrag =
898 Component.Of_Lang.(resolved_module_type_fragment (empty ()) f)
899 in
900 `Resolved
901 (Tools.reresolve_module_type_fragment env cfrag
902 |> Lang_of.(Path.resolved_module_type_fragment (empty ())))
903 | _ -> frag
904 in
905 let sg' =
906 Tools.fragmap env
907 Component.Of_Lang.(with_module_type_substitution (empty ()) lsub)
908 sg
909 in
910 (sg', ModuleTypeSubst (frag', module_type_expr env id eqn) :: subs)
911 | (Error _ as e), lsub -> (e, lsub :: subs))
912 (Ok sg, []) subs
913 |> snd |> List.rev
914
915and u_module_type_expr :
916 Env.t -> Id.Signature.t -> ModuleType.U.expr -> ModuleType.U.expr =
917 fun env id expr ->
918 match expr with
919 | Signature s -> Signature s
920 (* No need to link 'unexpanded' module type expressions that are actually expanded... *)
921 | Path p -> Path (module_type_path env p)
922 | With (subs, expr) as unresolved -> (
923 let cexpr = Component.Of_Lang.(u_module_type_expr (empty ()) expr) in
924 match Tools.signature_of_u_module_type_expr env cexpr with
925 | Ok sg ->
926 With (handle_fragments env id sg subs, u_module_type_expr env id expr)
927 | Error e ->
928 Errors.report ~what:(`Module_type_U cexpr) ~tools_error:e `Resolve;
929 unresolved)
930 | TypeOf (StructInclude p, original_path) ->
931 TypeOf (StructInclude (module_path env p), original_path)
932 | TypeOf (ModPath p, original_path) ->
933 TypeOf (ModPath (module_path env p), original_path)
934 | Strengthen (expr, path, aliasable) ->
935 let expr = u_module_type_expr env id expr in
936 Strengthen (expr, module_path env path, aliasable)
937
938and module_type_expr :
939 Env.t -> Id.Signature.t -> ModuleType.expr -> ModuleType.expr =
940 fun env id expr ->
941 let open ModuleType in
942 let open Odoc_utils.ResultMonad in
943 let do_expn cur (e : Paths.Path.ModuleType.t option) =
944 match (cur, e) with
945 | Some e, _ ->
946 Some (simple_expansion env (id :> Paths.Identifier.Signature.t) e)
947 | None, Some (`Resolved p_path) ->
948 if expansion_needed p_path id then
949 let cp =
950 Component.Of_Lang.(resolved_module_type_path (empty ()) p_path)
951 in
952 match
953 Tools.expansion_of_module_type_expr env
954 (Path { p_path = `Resolved cp; p_expansion = None })
955 >>= Expand_tools.handle_expansion env (id :> Id.Signature.t)
956 with
957 | Ok (_, e) ->
958 let le = Lang_of.(simple_expansion (empty ()) id e) in
959 Some (simple_expansion env id le)
960 | Error _ -> None
961 else None
962 | None, _ -> None
963 in
964 match expr with
965 | Signature s -> Signature (signature env id s)
966 | Path { p_path; p_expansion } ->
967 let p_path = module_type_path env p_path in
968 Path { p_path; p_expansion = do_expn p_expansion (Some p_path) }
969 | With { w_substitutions; w_expansion; w_expr } as unresolved -> (
970 let cexpr = Component.Of_Lang.(u_module_type_expr (empty ()) w_expr) in
971 match Tools.signature_of_u_module_type_expr env cexpr with
972 | Ok sg ->
973 With
974 {
975 w_substitutions = handle_fragments env id sg w_substitutions;
976 w_expansion = do_expn w_expansion None;
977 w_expr = u_module_type_expr env id w_expr;
978 }
979 | Error e ->
980 Errors.report ~what:(`Module_type_U cexpr) ~tools_error:e `Expand;
981 unresolved)
982 | Functor (arg, res) ->
983 let arg' = functor_argument env arg in
984 let env = Env.add_functor_parameter arg env in
985 let res' = module_type_expr env (Paths.Identifier.Mk.result id) res in
986 Functor (arg', res')
987 | TypeOf { t_desc = StructInclude p; t_expansion; t_original_path } ->
988 TypeOf
989 {
990 t_desc = StructInclude (module_path env p);
991 t_expansion = do_expn t_expansion None;
992 t_original_path;
993 }
994 | TypeOf { t_desc = ModPath p; t_expansion; t_original_path } ->
995 TypeOf
996 {
997 t_desc = ModPath (module_path env p);
998 t_expansion = do_expn t_expansion None;
999 t_original_path;
1000 }
1001 | Strengthen { s_expr; s_path; s_aliasable; s_expansion } ->
1002 Strengthen
1003 {
1004 s_expr = u_module_type_expr env id s_expr;
1005 s_path = module_path env s_path;
1006 s_aliasable;
1007 s_expansion = do_expn s_expansion None;
1008 }
1009
1010and type_decl_representation :
1011 Env.t ->
1012 Id.Signature.t ->
1013 TypeDecl.Representation.t ->
1014 TypeDecl.Representation.t =
1015 fun env parent r ->
1016 let open TypeDecl.Representation in
1017 match r with
1018 | Variant cs -> Variant (List.map (type_decl_constructor env parent) cs)
1019 | Record fs -> Record (List.map (type_decl_field env parent) fs)
1020 | Record_unboxed_product fs ->
1021 Record_unboxed_product (List.map (type_decl_unboxed_field env parent) fs)
1022 | Extensible -> Extensible
1023
1024and type_decl : Env.t -> Id.Signature.t -> TypeDecl.t -> TypeDecl.t =
1025 fun env parent t ->
1026 let open TypeDecl in
1027 let equation = type_decl_equation env parent t.equation in
1028 let doc = comment_docs env parent t.doc in
1029 let source_loc = source_loc env t.id t.source_loc in
1030 let hidden_path =
1031 match equation.Equation.manifest with
1032 | Some (Constr (`Resolved path, params))
1033 when Paths.Path.Resolved.(is_hidden (path :> t))
1034 || Paths.Path.Resolved.(identifier (path :> t))
1035 = Some (t.id :> Paths.Identifier.t) ->
1036 Some (path, params)
1037 | _ -> None
1038 in
1039 let representation =
1040 Opt.map
1041 (fun r ->
1042 let r' = type_decl_representation env parent r in
1043 warn_on_hidden_representation t.id r';
1044 r')
1045 t.representation
1046 in
1047 let default = { t with source_loc; equation; doc; representation } in
1048 match hidden_path with
1049 | Some (p, params) -> (
1050 let p' = Component.Of_Lang.(resolved_type_path (empty ()) p) in
1051 match Tools.lookup_type env p' with
1052 | Ok (`FType (_, t')) ->
1053 let equation =
1054 try
1055 Expand_tools.collapse_eqns default.equation
1056 (Lang_of.type_decl_equation (Lang_of.empty ())
1057 (parent :> Id.FieldParent.t)
1058 t'.equation)
1059 params
1060 with _ -> default.equation
1061 in
1062 { default with equation = type_decl_equation env parent equation }
1063 | Ok (`FClass _ | `FClassType _ | `FType_removed _ | `CoreType _)
1064 | Error _ ->
1065 default)
1066 | None -> default
1067
1068and type_decl_equation env parent t =
1069 let open TypeDecl.Equation in
1070 let manifest = Opt.map (type_expression env parent []) t.manifest in
1071 let constraints =
1072 List.map
1073 (fun (tex1, tex2) ->
1074 (type_expression env parent [] tex1, type_expression env parent [] tex2))
1075 t.constraints
1076 in
1077 { t with manifest; constraints }
1078
1079and type_decl_field env parent f =
1080 let open TypeDecl.Field in
1081 let doc = comment_docs env parent f.doc in
1082 { f with type_ = type_expression env parent [] f.type_; doc }
1083
1084and type_decl_unboxed_field env parent f =
1085 let open TypeDecl.UnboxedField in
1086 let doc = comment_docs env parent f.doc in
1087 { f with type_ = type_expression env parent [] f.type_; doc }
1088
1089and type_decl_constructor_argument env parent c =
1090 let open TypeDecl.Constructor in
1091 match c with
1092 | Tuple ts -> Tuple (List.map (type_expression env parent []) ts)
1093 | Record fs -> Record (List.map (type_decl_field env parent) fs)
1094
1095and type_decl_constructor env parent c =
1096 let open TypeDecl.Constructor in
1097 let doc = comment_docs env parent c.doc in
1098 let args = type_decl_constructor_argument env parent c.args in
1099 let res = Opt.map (type_expression env parent []) c.res in
1100 { c with doc; args; res }
1101
1102and type_expression_polyvar env parent visited v =
1103 let open TypeExpr.Polymorphic_variant in
1104 let constructor c =
1105 let open Constructor in
1106 let doc = comment_docs env parent c.doc in
1107 {
1108 c with
1109 arguments = List.map (type_expression env parent visited) c.arguments;
1110 doc;
1111 }
1112 in
1113 let element = function
1114 | Type t ->
1115 Type
1116 (match type_expression env parent visited t with
1117 | Constr _ as x -> x
1118 | _ -> t)
1119 (* These have to remain Constrs *)
1120 | Constructor c -> Constructor (constructor c)
1121 in
1122 { v with elements = List.map element v.elements }
1123
1124and type_expression_object env parent visited o =
1125 let open TypeExpr.Object in
1126 let method_ m =
1127 { m with type_ = type_expression env parent visited m.type_ }
1128 in
1129 let field = function
1130 | Method m -> Method (method_ m)
1131 | Inherit t -> Inherit (type_expression env parent visited t)
1132 in
1133 { o with fields = List.map field o.fields }
1134
1135and type_expression_package env parent visited p =
1136 let open TypeExpr.Package in
1137 let substitution (frag, t) =
1138 let cfrag = Component.Of_Lang.(type_fragment (empty ()) frag) in
1139 let frag' =
1140 match cfrag with
1141 | `Resolved f -> `Resolved (Tools.reresolve_type_fragment env f)
1142 | _ -> cfrag
1143 in
1144 ( Lang_of.(Path.type_fragment (empty ()) frag'),
1145 type_expression env parent visited t )
1146 in
1147 {
1148 path = module_type_path env p.path;
1149 substitutions = List.map substitution p.substitutions;
1150 }
1151
1152and type_expression : Env.t -> Id.Signature.t -> _ -> _ =
1153 fun env parent visited texpr ->
1154 let open TypeExpr in
1155 match texpr with
1156 | Var _ | Any -> texpr
1157 | Alias (t, str) -> Alias (type_expression env parent visited t, str)
1158 | Arrow (lbl, t1, t2, modes, ret_modes) ->
1159 Arrow
1160 ( lbl,
1161 type_expression env parent visited t1,
1162 type_expression env parent visited t2,
1163 modes,
1164 ret_modes )
1165 | Tuple ts ->
1166 Tuple
1167 (List.map
1168 (fun (lbl, ty) -> (lbl, type_expression env parent visited ty))
1169 ts)
1170 | Unboxed_tuple ts ->
1171 Unboxed_tuple (List.map (fun (l, t) -> l, type_expression env parent visited t) ts)
1172 | Constr (path', ts') -> (
1173 let path = type_path env path' in
1174 let ts = List.map (type_expression env parent visited) ts' in
1175 if not (Paths.Path.is_hidden (path :> Paths.Path.t)) then Constr (path, ts)
1176 else
1177 let cp = Component.Of_Lang.(type_path (empty ()) path') in
1178 match Tools.resolve_type env cp with
1179 | Ok (cp', `FType (_, t)) ->
1180 let cp' = Tools.reresolve_type env cp' in
1181 let p = Lang_of.(Path.resolved_type (empty ()) cp') in
1182 if List.mem p visited then raise Loop
1183 else if Cpath.is_resolved_type_hidden cp' then
1184 match t.Component.TypeDecl.equation with
1185 | { manifest = Some expr; params; _ } -> (
1186 try
1187 let map =
1188 List.fold_left2
1189 (fun acc param sub ->
1190 match param.Lang.TypeDecl.desc with
1191 | Lang.TypeDecl.Var (x, _) -> (x, sub) :: acc
1192 | Any -> acc)
1193 [] params ts
1194 in
1195 let t' =
1196 Expand_tools.type_expr map
1197 Lang_of.(
1198 type_expr (empty ()) (parent :> Id.LabelParent.t) expr)
1199 in
1200 type_expression env parent (p :: visited) t'
1201 with
1202 | Loop -> Constr (`Resolved p, ts)
1203 | e ->
1204 Format.eprintf
1205 "Caught unexpected exception when expanding type \
1206 declaration (%s)@."
1207 (Printexc.to_string e);
1208 Constr (`Resolved p, ts))
1209 | _ -> Constr (`Resolved p, ts)
1210 else Constr (`Resolved p, ts)
1211 | Ok (cp', (`FClass _ | `FClassType _ | `CoreType _)) ->
1212 let p = Lang_of.(Path.resolved_type (empty ()) cp') in
1213 Constr (`Resolved p, ts)
1214 | Ok (_cp, `FType_removed (_, x, _eq)) ->
1215 (* Type variables ? *)
1216 Lang_of.(type_expr (empty ()) (parent :> Id.LabelParent.t) x)
1217 | Error _ -> Constr (path', ts))
1218 | Polymorphic_variant v ->
1219 Polymorphic_variant (type_expression_polyvar env parent visited v)
1220 | Object o -> Object (type_expression_object env parent visited o)
1221 | Class (path', ts') -> (
1222 let path = class_type_path env path' in
1223 let ts = List.map (type_expression env parent visited) ts' in
1224 if not (Paths.Path.is_hidden (path :> Paths.Path.t)) then Class (path, ts)
1225 else
1226 let cp = Component.Of_Lang.(class_type_path (empty ()) path') in
1227 match Tools.resolve_class_type env cp with
1228 | Ok (cp', (`FClass _ | `FClassType _)) ->
1229 let cp' = Tools.reresolve_class_type env cp' in
1230 let p = Lang_of.(Path.resolved_class_type (empty ()) cp') in
1231 Class (`Resolved p, ts)
1232 | _ -> Class (path', ts))
1233 | Poly (strs, t) -> Poly (strs, type_expression env parent visited t)
1234 | Quote t -> Quote (type_expression env parent visited t)
1235 | Splice t -> Splice (type_expression env parent visited t)
1236 | Package p -> Package (type_expression_package env parent visited p)
1237
1238let link ~filename x y =
1239 Lookup_failures.catch_failures ~filename (fun () ->
1240 if y.Lang.Compilation_unit.linked then y else unit x y)
1241
1242let page env page =
1243 let () =
1244 List.iter
1245 (fun child ->
1246 match child with
1247 | Page.Page_child page -> (
1248 match Env.lookup_page_by_name page env with
1249 | Ok _ -> ()
1250 | Error `Not_found -> Errors.report ~what:(`Child_page page) `Lookup
1251 )
1252 | Page.Module_child mod_ -> (
1253 match
1254 Env.lookup_root_module
1255 (Odoc_model.Names.ModuleName.make_std mod_)
1256 env
1257 with
1258 | Some _ -> ()
1259 | None -> Errors.report ~what:(`Child_module mod_) `Lookup))
1260 page.Lang.Page.children
1261 in
1262 {
1263 page with
1264 Page.content = comment_docs env page.Page.name page.content;
1265 linked = true;
1266 }
1267
1268let source_info env infos =
1269 let open Source_info in
1270 let jump_to v f_impl f_doc =
1271 let documentation =
1272 match v.documentation with Some p -> Some (f_doc p) | None -> None
1273 in
1274 let implementation =
1275 match v.implementation with
1276 | Some (Unresolved p) -> (
1277 match f_impl p with
1278 | Some x -> Some (Resolved x)
1279 | None -> v.implementation)
1280 | x -> x
1281 in
1282 { documentation; implementation }
1283 in
1284 List.map
1285 (fun (i, pos) ->
1286 let info =
1287 match i with
1288 | Value v ->
1289 Value
1290 (jump_to v (Shape_tools.lookup_value_path env) (value_path env))
1291 | Module v ->
1292 Module
1293 (jump_to v (Shape_tools.lookup_module_path env) (module_path env))
1294 | ModuleType v ->
1295 ModuleType
1296 (jump_to v
1297 (Shape_tools.lookup_module_type_path env)
1298 (module_type_path env))
1299 | Type v ->
1300 Type (jump_to v (Shape_tools.lookup_type_path env) (type_path env))
1301 | i -> i
1302 in
1303 (info, pos))
1304 infos
1305
1306let impl env i =
1307 let open Implementation in
1308 { i with source_info = source_info env i.source_info; linked = true }
1309
1310let resolve_page ~filename env p =
1311 Lookup_failures.catch_failures ~filename (fun () ->
1312 if p.Lang.Page.linked then p else page env p)
1313
1314let resolve_impl ~filename env i =
1315 Lookup_failures.catch_failures ~filename (fun () ->
1316 if i.Lang.Implementation.linked then i else impl env i)