jon.recoil.org
this repo has no description
1open Odoc_model.Paths
2open Odoc_model.Names
3open Reference
4open Odoc_utils
5open ResultMonad
6
7type module_lookup_result =
8 Resolved.Module.t * Cpath.Resolved.module_ * Component.Module.t
9
10type module_type_lookup_result =
11 Resolved.ModuleType.t * Cpath.Resolved.module_type * Component.ModuleType.t
12
13type signature_lookup_result =
14 Resolved.Signature.t * Cpath.Resolved.parent * Component.Signature.t
15
16type datatype_lookup_result = Resolved.DataType.t * Component.TypeDecl.t
17
18type class_lookup_result = Resolved.Class.t * Component.Class.t
19
20type class_type_lookup_result = Resolved.ClassType.t * Component.ClassType.t
21
22type page_lookup_result = Resolved.Page.t * Odoc_model.Lang.Page.t
23
24type asset_lookup_result = Resolved.Asset.t
25
26type type_lookup_result =
27 [ `T of datatype_lookup_result
28 | `C of class_lookup_result
29 | `CT of class_type_lookup_result ]
30
31type any_path_lookup_result =
32 [ `P of page_lookup_result | `S of signature_lookup_result ]
33
34type label_parent_lookup_result =
35 [ type_lookup_result
36 | `P of page_lookup_result
37 | `S of signature_lookup_result ]
38
39type fragment_type_parent_lookup_result =
40 [ `S of signature_lookup_result | `T of datatype_lookup_result ]
41
42type 'a ref_result = ('a, Errors.Tools_error.reference_lookup_error) result
43(** The result type for every functions in this module. *)
44
45let kind_of_find_result = function
46 | `S _ -> `S
47 | `T _ -> `T
48 | `C _ -> `C
49 | `CT _ -> `CT
50 | `P _ -> `Page
51
52let wrong_kind_error expected r =
53 Error (`Wrong_kind (expected, kind_of_find_result r))
54
55let signature_lookup_result_of_label_parent : label_parent_lookup_result -> _ =
56 function
57 | `S r -> Ok r
58 | r -> wrong_kind_error [ `S ] r
59
60let class_lookup_result_of_type : type_lookup_result -> _ = function
61 | `C r -> Ok r
62 | r -> wrong_kind_error [ `C ] r
63
64let class_type_lookup_result_of_type : type_lookup_result -> _ = function
65 | `CT r -> Ok r
66 | r -> wrong_kind_error [ `CT ] r
67
68let ref_kind_of_element = function
69 | `Module _ -> "module"
70 | `ModuleType _ -> "module-type"
71 | `Type _ -> "type"
72 | `Value _ -> "val"
73 | `Label _ -> "section"
74 | `Class _ -> "class"
75 | `ClassType _ -> "class-type"
76 | `Constructor _ -> "constructor"
77 | `Exception _ -> "exception"
78 | `Extension _ -> "extension"
79 | `ExtensionDecl _ -> "extension-decl"
80 | `Field _ -> "field"
81 | `UnboxedField _ -> "unboxed-field"
82 | `Page _ -> "page"
83
84let ref_kind_of_find = function
85 | `FModule _ | `FModule_subst _ -> "module"
86 | `FModuleType _ | `FModuleType_subst _ -> "module-type"
87 | `FType _ | `FType_subst _ -> "type"
88 | `FValue _ -> "val"
89 | `FLabel _ -> "section"
90 | `FClass _ -> "class"
91 | `FClassType _ -> "class-type"
92 | `FConstructor _ | `In_type (_, _, `FConstructor _) -> "constructor"
93 | `In_type (_, _, `FPoly _) -> "polymorphic constructor"
94 | `FExn _ -> "exception"
95 | `FExt _ -> "extension"
96 | `FExtDecl _ -> "extension-decl"
97 | `FField _ | `In_type (_, _, `FField _) -> "field"
98 | `FUnboxedField _ | `In_type (_, _, `FUnboxedField _) -> "unboxed-field"
99 | `FMethod _ -> "method"
100 | `FInstance_variable _ -> "instance-variable"
101
102let ambiguous_generic_ref_warning name results =
103 (* Sort the results to make sure the result is reproducible. *)
104 let results = List.sort String.compare results in
105 let pp_sep pp () = Format.fprintf pp ", "
106 and pp_kind pp r = Format.fprintf pp "%s-%s" r name in
107 Lookup_failures.report_warning
108 "Reference to '%s' is ambiguous. Please specify its kind: %a." name
109 (Format.pp_print_list ~pp_sep pp_kind)
110 results
111
112let ambiguous_label_warning name (labels : Component.Element.any list) =
113 (* Sort the results to make sure the result is reproducible. *)
114 let pp_kind pp r =
115 match r with
116 | `Label (_, l) ->
117 Odoc_model.Location_.pp_span_start pp l.Component.Label.location
118 | _ -> ()
119 in
120 Lookup_failures.report_warning
121 "@[<2>Multiple sections named '%s' found. Please alter one to ensure \
122 reference is unambiguous. Locations:@ %a@]"
123 name
124 (Format.pp_print_list ~pp_sep:Format.pp_force_newline pp_kind)
125 labels
126
127let ambiguous_warning name (results : [< Component.Element.any ] list) =
128 let results = (results :> Component.Element.any list) in
129 if List.for_all (function `Label _ -> true | _ -> false) results then
130 ambiguous_label_warning name results
131 else ambiguous_generic_ref_warning name (List.map ref_kind_of_element results)
132
133let env_lookup_by_name ?(kind = `Any) scope name env =
134 match Env.lookup_by_name scope name env with
135 | Ok x -> Ok x
136 | Error (`Ambiguous (hd, tl)) ->
137 ambiguous_warning name (hd :: tl);
138 Ok hd
139 | Error `Not_found -> Error (`Lookup_by_name (kind, name))
140
141let find_ambiguous ?(kind = `Any) find sg name =
142 match find sg name with
143 | [ x ] -> Ok x
144 | x :: _ as results ->
145 ambiguous_generic_ref_warning name (List.map ref_kind_of_find results);
146 Ok x
147 | [] -> Error (`Find_by_name (kind, name))
148
149let find find sg conv name =
150 match find sg name with
151 | Some x -> Ok x
152 | None -> Error (`Find_by_name (`Any, (conv name : string)))
153
154let module_lookup_to_signature_lookup env (ref, cp, m) =
155 let rec handle_expansion : Tools.expansion -> _ = function
156 | Functor (_, expr) -> (
157 match Tools.expansion_of_module_type_expr env expr with
158 | Ok e -> handle_expansion e
159 | Error _ as e -> e)
160 | Signature sg -> Ok ((ref :> Resolved.Signature.t), `Module cp, sg)
161 in
162 Tools.expansion_of_module env m
163 >>= handle_expansion
164 |> map_error (fun e -> `Parent (`Parent_sig e))
165
166let module_type_lookup_to_signature_lookup env (ref, cp, m) =
167 Tools.expansion_of_module_type env m
168 |> map_error (fun e -> `Parent (`Parent_sig e))
169 >>= Tools.assert_not_functor
170 >>= fun sg -> Ok ((ref :> Resolved.Signature.t), `ModuleType cp, sg)
171
172let type_lookup_to_class_signature_lookup =
173 let resolved p' cs = Ok ((p' :> Resolved.ClassSignature.t), cs) in
174 fun env -> function
175 | `T _ as r -> wrong_kind_error [ `C; `CT ] r
176 | `C (p', c) ->
177 Tools.class_signature_of_class env c
178 |> of_option ~error:(`Parent (`Parent_type `OpaqueClass))
179 >>= resolved p'
180 | `CT (p', ct) ->
181 Tools.class_signature_of_class_type env ct
182 |> of_option ~error:(`Parent (`Parent_type `OpaqueClass))
183 >>= resolved p'
184
185module M = struct
186 (** Module *)
187
188 type t = module_lookup_result
189
190 let of_component env m base_path' base_ref' : t =
191 let base_path, base_ref =
192 if m.Component.Module.hidden then (`Hidden base_path', `Hidden base_ref')
193 else (base_path', base_ref')
194 in
195 let p, r =
196 match Tools.get_module_path_modifiers env m with
197 | None -> (base_path, base_ref)
198 | Some (`Aliased cp) ->
199 let cp = Tools.reresolve_module env cp in
200 let p = Lang_of.(Path.resolved_module (empty ()) cp) in
201 (`Alias (cp, `Resolved base_path, None), `Alias (p, base_ref))
202 | Some (`SubstMT cp) ->
203 let cp = Tools.reresolve_module_type env cp in
204 (`Subst (cp, base_path), base_ref)
205 in
206 (r, p, m)
207
208 let in_signature env ((parent, parent_cp, sg) : signature_lookup_result) name
209 =
210 let parent_cp = Tools.reresolve_parent env parent_cp in
211 let sg = Tools.prefix_signature (parent_cp, sg) in
212 find Find.module_in_sig sg ModuleName.to_string name
213 >>= fun (`FModule (name, m)) ->
214 Ok (of_component env m (`Module (parent_cp, name)) (`Module (parent, name)))
215
216 let of_element env (`Module (id, m)) : t =
217 let m = Component.Delayed.get m in
218 let id = (id :> Identifier.Path.Module.t) in
219 of_component env m (`Gpath (`Identifier id)) (`Identifier id)
220
221 let in_env env name =
222 match env_lookup_by_name Env.s_module name env with
223 | Ok e -> Ok (of_element env e)
224 | Error _ ->
225 Error
226 (`Parent
227 (`Parent_module (`Lookup_failure_root (ModuleName.make_std name))))
228end
229
230module Path = struct
231 (* let first_seg (`Root (s, _) | `Slash (_, s)) = s *)
232
233 let mk_lookup_error (tag, path) = Error (`Path_error (`Not_found, tag, path))
234
235 let handle_lookup_error p = function
236 | Ok _ as ok -> ok
237 | Error `Not_found -> mk_lookup_error p
238
239 let page_in_env env p : page_lookup_result ref_result =
240 Env.lookup_page_by_path p env |> handle_lookup_error p >>= fun p ->
241 Ok (`Identifier p.name, p)
242
243 let asset_in_env env p : asset_lookup_result ref_result =
244 Env.lookup_asset_by_path p env |> handle_lookup_error p >>= fun p ->
245 Ok (`Identifier p.name)
246
247 let module_in_env env p : module_lookup_result ref_result =
248 Env.lookup_unit_by_path p env |> handle_lookup_error p >>= fun m ->
249 Ok (M.of_element env m)
250
251 let any_in_env env p : any_path_lookup_result ref_result =
252 (* TODO: Resolve modules *)
253 let page_result = page_in_env env p in
254 let module_result = module_in_env env p in
255 match (page_result, module_result) with
256 | Ok page, Error _ -> Ok (`P page)
257 | Error _, Ok m ->
258 module_lookup_to_signature_lookup env m >>= fun s -> Ok (`S s)
259 | Ok page, Ok _ ->
260 let name = List.last (snd p) in
261 ambiguous_generic_ref_warning name [ "module"; "page" ];
262 Ok (`P page)
263 | Error _, Error _ -> mk_lookup_error p
264end
265
266module MT = struct
267 (** Module type *)
268
269 type t = module_type_lookup_result
270
271 let of_component env mt base_path base_ref : t =
272 match Tools.get_module_type_path_modifiers env mt with
273 | None -> (base_ref, base_path, mt)
274 | Some (`AliasModuleType cp) ->
275 let cp = Tools.reresolve_module_type env cp in
276 let p = Lang_of.(Path.resolved_module_type (empty ()) cp) in
277 (`AliasModuleType (p, base_ref), `AliasModuleType (cp, base_path), mt)
278
279 let in_signature env ((parent', parent_cp, sg) : signature_lookup_result) name
280 =
281 let sg = Tools.prefix_signature (parent_cp, sg) in
282 find Find.module_type_in_sig sg ModuleTypeName.to_string name
283 >>= fun (`FModuleType (name, mt)) ->
284 Ok
285 (of_component env mt
286 (`ModuleType (parent_cp, name))
287 (`ModuleType (parent', name)))
288
289 let of_element env (`ModuleType (id, mt)) : t =
290 of_component env mt (`Gpath (`Identifier id)) (`Identifier id)
291
292 let in_env env name =
293 env_lookup_by_name Env.s_module_type name env >>= fun e ->
294 Ok (of_element env e)
295end
296
297module CL = struct
298 (** Class *)
299
300 type t = class_lookup_result
301
302 let of_element _env (`Class (id, t)) : t = (`Identifier id, t)
303
304 let in_env env name =
305 env_lookup_by_name Env.s_class name env >>= fun e -> Ok (of_element env e)
306
307 let of_component _env c ~parent_ref name = Ok (`Class (parent_ref, name), c)
308end
309
310module CT = struct
311 type t = class_type_lookup_result
312
313 let of_element _env (`ClassType (id, t)) : t =
314 ((`Identifier id :> Resolved.ClassType.t), t)
315
316 let in_env env name =
317 env_lookup_by_name Env.s_class_type name env >>= fun e ->
318 Ok (of_element env e)
319
320 let of_component _env ct ~parent_ref name =
321 Ok (`ClassType (parent_ref, name), ct)
322end
323
324module DT = struct
325 (** Datatype *)
326
327 type t = datatype_lookup_result
328
329 let of_component _env t ~parent_ref name = Ok (`Type (parent_ref, name), t)
330
331 let of_element _env (`Type (id, t)) : t = (`Identifier id, t)
332
333 let in_env env name =
334 env_lookup_by_name Env.s_datatype name env >>= fun e ->
335 Ok (of_element env e)
336
337 let in_signature _env ((parent', parent_cp, sg) : signature_lookup_result)
338 name =
339 let sg = Tools.prefix_signature (parent_cp, sg) in
340 find Find.datatype_in_sig sg TypeName.to_string name >>= function
341 | `FType (name, t) -> Ok (`T (`Type (parent', name), t))
342end
343
344module T = struct
345 (** Type *)
346
347 type t = type_lookup_result
348
349 let of_element env : _ -> t = function
350 | `Type _ as e -> `T (DT.of_element env e)
351 | `Class _ as e -> `C (CL.of_element env e)
352 | `ClassType _ as e -> `CT (CT.of_element env e)
353
354 let in_env env name =
355 env_lookup_by_name Env.s_type name env >>= fun e -> Ok (of_element env e)
356
357 (* Don't handle name collisions between class, class types and type decls *)
358 let in_signature _env ((parent', parent_cp, sg) : signature_lookup_result)
359 name =
360 let sg = Tools.prefix_signature (parent_cp, sg) in
361 find Find.type_in_sig sg TypeName.to_string name >>= function
362 | `FType (name, t) -> Ok (`T (`Type (parent', name), t))
363 | `FClass (name, c) -> Ok (`C (`Class (parent', name), c))
364 | `FClassType (name, ct) -> Ok (`CT (`ClassType (parent', name), ct))
365end
366
367module V = struct
368 (** Value *)
369
370 type t = Resolved.Value.t
371
372 let in_env env name : t ref_result =
373 env_lookup_by_name Env.s_value name env >>= fun (`Value (id, _x)) ->
374 Ok (`Identifier id)
375
376 let of_component _env ~parent_ref name = Ok (`Value (parent_ref, name))
377
378 let in_signature _env ((parent, _, sg) : signature_lookup_result) name =
379 find Find.value_in_sig sg ValueName.to_string name >>= function
380 | `FValue (name, _) -> Ok (`Value (parent, name))
381end
382
383module L = struct
384 (** Label *)
385
386 type t = Resolved.Label.t
387
388 let in_env env name : (t * _) ref_result =
389 env_lookup_by_name Env.s_label name env >>= fun (`Label (id, lbl)) ->
390 Ok (`Identifier id, lbl.text)
391
392 let in_page _env (`P (_, p)) name =
393 let rec find = function
394 | hd :: tl -> (
395 match Odoc_model.Location_.value hd with
396 | `Heading
397 ( _,
398 ({ Odoc_model.Paths.Identifier.iv = `Label (_, name'); _ } as
399 label),
400 content )
401 when name = LabelName.to_string name' ->
402 Ok (`Identifier label, content)
403 | _ -> find tl)
404 | [] -> Error (`Find_by_name (`Page, name))
405 in
406 find p.Odoc_model.Lang.Page.content.elements
407
408 let of_component _env ~parent_ref label =
409 Ok
410 ( `Label
411 ( (parent_ref :> Resolved.LabelParent.t),
412 Ident.Name.typed_label label.Component.Label.label ),
413 label.text )
414
415 let in_label_parent env (parent : label_parent_lookup_result) name =
416 match parent with
417 | `S (p, _, sg) -> (
418 find_ambiguous ~kind:`Label
419 (fun sg l -> Find.label_in_sig sg (LabelName.make_std l))
420 sg (LabelName.to_string name)
421 >>= function
422 | `FLabel lbl ->
423 Ok (`Label ((p :> Resolved.LabelParent.t), name), lbl.text))
424 | (`T _ | `C _ | `CT _) as r -> wrong_kind_error [ `S; `Page ] r
425 | `P _ as page -> in_page env page (LabelName.to_string name)
426end
427
428module EC = struct
429 (** Extension constructor *)
430
431 type t = Resolved.Constructor.t
432
433 let in_env env name =
434 env_lookup_by_name Env.s_extension name env
435 >>= fun (`Extension (id, _, _)) -> Ok (`Identifier id :> t)
436
437 let of_component _env ~parent_ref name =
438 Ok (`Extension (parent_ref, ExtensionName.make_std name))
439
440 let in_signature _env ((parent', parent_cp, sg) : signature_lookup_result)
441 name =
442 let sg = Tools.prefix_signature (parent_cp, sg) in
443 find Find.extension_in_sig sg ExtensionName.to_string name >>= fun _ ->
444 Ok (`Extension (parent', name))
445end
446
447module ED = struct
448 (** Extension decl *)
449
450 let in_env env name =
451 env_lookup_by_name Env.s_extension name env
452 >>= fun (`Extension (id, _, te)) ->
453 (* Type extensions always have at least 1 constructor.
454 The reference to the type extension shares the same name as the first constructor. *)
455 match te.constructors with
456 | [] -> assert false
457 | c :: _ ->
458 let id_parent = match id.iv with `Extension (p, _) -> p in
459 Ok
460 (`Identifier
461 (Identifier.Mk.extension_decl
462 ( id_parent,
463 (ExtensionName.make_std c.name, ExtensionName.make_std name)
464 )))
465
466 let in_signature _env ((parent', parent_cp, sg) : signature_lookup_result)
467 name =
468 let sg = Tools.prefix_signature (parent_cp, sg) in
469 find Find.extension_in_sig sg ExtensionName.to_string name
470 >>= fun (`FExt (ext, _) : Find.extension) ->
471 (* Type extensions always have at least 1 constructor.
472 The reference to the type extension shares the same name as the first constructor. *)
473 match ext.constructors with
474 | [] -> assert false
475 | c :: _ ->
476 Ok (`ExtensionDecl (parent', ExtensionName.make_std c.name, name))
477end
478
479module EX = struct
480 (** Exception *)
481
482 type t = Resolved.Exception.t
483
484 let in_env env name : t ref_result =
485 env_lookup_by_name Env.s_exception name env >>= fun (`Exception (id, _)) ->
486 Ok (`Identifier id)
487
488 let of_component _env ~parent_ref name = Ok (`Exception (parent_ref, name))
489
490 let in_signature _env ((parent', parent_cp, sg) : signature_lookup_result)
491 name =
492 let sg = Tools.prefix_signature (parent_cp, sg) in
493 find Find.exception_in_sig sg ExceptionName.to_string name >>= fun _ ->
494 Ok (`Exception (parent', name))
495end
496
497module FTP = struct
498 (** Fragment type parent *)
499
500 type t = fragment_type_parent_lookup_result
501
502 let of_element env : _ -> t ref_result = function
503 | `Module _ as e ->
504 M.of_element env e |> module_lookup_to_signature_lookup env >>= fun r ->
505 Ok (`S r)
506 | `ModuleType _ as e ->
507 MT.of_element env e |> module_type_lookup_to_signature_lookup env
508 >>= fun r -> Ok (`S r)
509 | `Type _ as e -> Ok (`T (DT.of_element env e))
510
511 let in_env env name =
512 env_lookup_by_name Env.s_fragment_type_parent name env >>= of_element env
513end
514
515module CS = struct
516 (** Constructor *)
517
518 type t = Resolved.Constructor.t
519
520 let in_env env name =
521 env_lookup_by_name Env.s_constructor name env
522 >>= fun (`Constructor (id, _)) -> Ok (`Identifier id :> t)
523
524 let not_a_constructor name =
525 (* Let's pretend we didn't see the field/unboxed field and say we didn't find anything. *)
526 Error (`Find_by_name (`Cons, name))
527
528 let in_parent _env (parent : fragment_type_parent_lookup_result) name =
529 let name_s = ConstructorName.to_string name in
530 match parent with
531 | `S (parent', parent_cp, sg) -> (
532 let sg = Tools.prefix_signature (parent_cp, sg) in
533 let find_ambiguous =
534 (find_ambiguous : ?kind:([> `Any ] as 'a) ->
535 (Component.Signature.t -> string -> Find.any_in_type_in_sig list)
536 ->
537 Component.Signature.t -> string -> (Find.any_in_type_in_sig, [> `Find_by_name of 'a * string ]) result)
538 in
539 find_ambiguous Find.any_in_type_in_sig sg name_s >>= function
540 | `In_type (_, _, `FField _) -> not_a_constructor name_s
541 | `In_type (_, _, `FUnboxedField _) -> not_a_constructor name_s
542 | `In_type (typ_name, _, `FPoly cs) ->
543 Ok
544 (`PolyConstructor
545 (`Type (parent', typ_name), ConstructorName.make_std cs.name))
546 | `In_type (typ_name, _, `FConstructor _) ->
547 Ok (`Constructor (`Type (parent', typ_name), name)))
548 | `T (parent', t) -> (
549 find Find.any_in_type t (fun x -> x) name_s >>= function
550 | `FField _ -> not_a_constructor name_s
551 | `FUnboxedField _ -> not_a_constructor name_s
552 | `FPoly cs ->
553 Ok
554 (`PolyConstructor
555 ( (parent' : Resolved.DataType.t),
556 ConstructorName.make_std cs.name ))
557 | `FConstructor _ ->
558 Ok (`Constructor ((parent' : Resolved.DataType.t), name)))
559
560 let of_component _env parent name =
561 Ok
562 (`Constructor
563 ((parent : Resolved.DataType.t), ConstructorName.make_std name))
564
565 let poly_of_component _env parent name =
566 Ok
567 (`PolyConstructor
568 ((parent : Resolved.DataType.t), ConstructorName.make_std name))
569end
570
571module F = struct
572 (** Field *)
573
574 type t = Resolved.Field.t
575
576 let in_env env name =
577 env_lookup_by_name Env.s_field name env >>= fun (`Field (id, _)) ->
578 Ok (`Identifier id :> t)
579
580 let not_a_field name =
581 (* Let's pretend we didn't see the constructor/unboxed field and say we didn't find anything. *)
582 Error (`Find_by_name (`Field, name))
583
584 let in_parent _env (parent : fragment_type_parent_lookup_result) name =
585 let name_s = FieldName.to_string name in
586 match parent with
587 | `S (parent', parent_cp, sg) -> (
588 let sg = Tools.prefix_signature (parent_cp, sg) in
589 find_ambiguous Find.any_in_type_in_sig sg name_s >>= function
590 | `In_type (_, _, `FConstructor _) -> not_a_field name_s
591 | `In_type (_, _, `FPoly _) -> not_a_field name_s
592 | `In_type (_, _, `FUnboxedField _) -> not_a_field name_s
593 | `In_type (typ_name, _, `FField _) ->
594 Ok
595 (`Field
596 ((`Type (parent', typ_name) :> Resolved.FieldParent.t), name)))
597 | `T (parent', t) -> (
598 find Find.any_in_type t (fun x -> x) name_s >>= function
599 | `FConstructor _ -> not_a_field name_s
600 | `FPoly _ -> not_a_field name_s
601 | `FUnboxedField _ -> not_a_field name_s
602 | `FField _ -> Ok (`Field ((parent' :> Resolved.FieldParent.t), name)))
603
604 let of_component _env parent name =
605 Ok
606 (`Field
607 ( (parent : Resolved.DataType.t :> Resolved.FieldParent.t),
608 FieldName.make_std name ))
609end
610
611module UF = struct
612 (** Unboxed field *)
613
614 type t = Resolved.UnboxedField.t
615
616 let in_env env name =
617 env_lookup_by_name Env.s_unboxed_field name env >>= fun (`UnboxedField (id, _)) ->
618 Ok (`Identifier id :> t)
619
620 let not_an_unboxed_field name =
621 (* Let's pretend we didn't see the constructor/field and say we didn't find anything. *)
622 Error (`Find_by_name (`UnboxedField, name))
623
624 let in_parent _env (parent : fragment_type_parent_lookup_result) name =
625 let name_s = UnboxedFieldName.to_string name in
626 match parent with
627 | `S (parent', parent_cp, sg) -> (
628 let sg = Tools.prefix_signature (parent_cp, sg) in
629 find_ambiguous Find.any_in_type_in_sig sg name_s >>= function
630 | `In_type (_, _, `FConstructor _) -> not_an_unboxed_field name_s
631 | `In_type (_, _, `FPoly _) -> not_an_unboxed_field name_s
632 | `In_type (_, _, `FField _) -> not_an_unboxed_field name_s
633 | `In_type (typ_name, _, `FUnboxedField _) ->
634 Ok
635 (`UnboxedField
636 ((`Type (parent', typ_name) :> Resolved.UnboxedFieldParent.t), name)))
637 | `T (parent', t) -> (
638 find Find.any_in_type t (fun x -> x) name_s >>= function
639 | `FConstructor _ -> not_an_unboxed_field name_s
640 | `FPoly _ -> not_an_unboxed_field name_s
641 | `FField _ -> not_an_unboxed_field name_s
642 | `FUnboxedField _ -> Ok (`UnboxedField ((parent' :> Resolved.UnboxedFieldParent.t), name)))
643
644 let of_component _env parent name =
645 Ok
646 (`UnboxedField
647 ( (parent : Resolved.DataType.t :> Resolved.UnboxedFieldParent.t),
648 UnboxedFieldName.make_std name ))
649end
650
651module MM = struct
652 (** Method *)
653
654 type t = Resolved.Method.t
655
656 (* TODO: Resolve methods in env *)
657 let in_env _env name : t ref_result = Error (`Lookup_by_name (`Any, name))
658
659 let in_class_signature _env (parent', cs) name =
660 find Find.method_in_class_signature cs MethodName.to_string name
661 >>= fun _ -> Ok (`Method (parent', name))
662
663 let of_component _env parent' name = Ok (`Method (parent', name))
664end
665
666module MV = struct
667 (** Instance variable *)
668
669 type t = Resolved.InstanceVariable.t
670
671 (* TODO: Resolve instance variables in env *)
672 let in_env _env name : t ref_result = Error (`Lookup_by_name (`Any, name))
673
674 let in_class_signature _env (parent', cs) name =
675 find Find.instance_variable_in_class_signature cs
676 InstanceVariableName.to_string name
677 >>= fun _ -> Ok (`InstanceVariable (parent', name))
678
679 let of_component _env parent' name = Ok (`InstanceVariable (parent', name))
680end
681
682module Page = struct
683 type t = page_lookup_result
684
685 let in_env env name : t ref_result =
686 match Env.lookup_page_by_name name env with
687 | Ok p -> Ok (`Identifier p.Odoc_model.Lang.Page.name, p)
688 | Error `Not_found -> Error (`Lookup_by_name (`Page, name))
689
690 let of_element _env (`Page (id, page)) : t = (`Identifier id, page)
691end
692
693module Asset = struct
694 type t = asset_lookup_result
695
696 let in_env env name : t ref_result =
697 match Env.lookup_asset_by_name name env with
698 | Ok p -> Ok (`Identifier p.Odoc_model.Lang.Asset.name)
699 | Error `Not_found -> Error (`Lookup_by_name (`Page (* TODO *), name))
700end
701
702module LP = struct
703 (** Label parent *)
704
705 type t = label_parent_lookup_result
706
707 let of_element env : _ -> t ref_result = function
708 | `Module _ as e ->
709 M.of_element env e |> module_lookup_to_signature_lookup env >>= fun r ->
710 Ok (`S r)
711 | `ModuleType _ as e ->
712 MT.of_element env e |> module_type_lookup_to_signature_lookup env
713 >>= fun r -> Ok (`S r)
714 | `Type _ as e -> Ok (`T (DT.of_element env e))
715 | `Class _ as e -> Ok (`C (CL.of_element env e))
716 | `ClassType _ as e -> Ok (`CT (CT.of_element env e))
717 | `Page _ as e -> Ok (`P (Page.of_element env e))
718
719 let in_env env name =
720 env_lookup_by_name Env.s_label_parent name env >>= of_element env
721
722 let in_signature env ((parent', parent_cp, sg) : signature_lookup_result) name
723 =
724 let sg = Tools.prefix_signature (parent_cp, sg) in
725 find_ambiguous Find.label_parent_in_sig sg name >>= function
726 | `FModule (name, m) ->
727 module_lookup_to_signature_lookup env
728 (M.of_component env m
729 (`Module (parent_cp, name))
730 (`Module (parent', name)))
731 >>= fun s -> Ok (`S s)
732 | `FModuleType (name, mt) ->
733 module_type_lookup_to_signature_lookup env
734 (MT.of_component env mt
735 (`ModuleType (parent_cp, name))
736 (`ModuleType (parent', name)))
737 >>= fun s -> Ok (`S s)
738 | `FType (name, t) ->
739 DT.of_component env ~parent_ref:parent' t name >>= fun t -> Ok (`T t)
740 | `FClass (name, c) ->
741 CL.of_component env ~parent_ref:parent' c name >>= fun c -> Ok (`C c)
742 | `FClassType (name, ct) ->
743 CT.of_component env ~parent_ref:parent' ct name >>= fun ct ->
744 Ok (`CT ct)
745end
746
747let rec resolve_label_parent_reference env (r : LabelParent.t) =
748 let label_parent_res_of_type_res : type_lookup_result -> _ =
749 fun r -> Ok (r :> label_parent_lookup_result)
750 in
751 match r with
752 | `Resolved _ -> failwith "unimplemented"
753 | `Root (name, `TUnknown) -> LP.in_env env name
754 | (`Module _ | `ModuleType _ | `Root (_, (`TModule | `TModuleType))) as sr ->
755 resolve_signature_reference env sr >>= fun s -> Ok (`S s)
756 | `Root (name, `TType) -> T.in_env env name >>= label_parent_res_of_type_res
757 | `Type (parent, name) ->
758 resolve_signature_reference env parent >>= fun p ->
759 T.in_signature env p name >>= label_parent_res_of_type_res
760 | `Root (name, `TClass) -> CL.in_env env name >>= fun r -> Ok (`C r)
761 | `Class (parent, name) ->
762 resolve_signature_reference env parent >>= fun p ->
763 T.in_signature env p name >>= class_lookup_result_of_type >>= fun r ->
764 Ok (`C r)
765 | `Root (name, `TClassType) -> CT.in_env env name >>= fun r -> Ok (`CT r)
766 | `ClassType (parent, name) ->
767 resolve_signature_reference env parent >>= fun p ->
768 T.in_signature env p name >>= class_type_lookup_result_of_type
769 >>= fun r -> Ok (`CT r)
770 | `Dot (parent, name) ->
771 resolve_label_parent_reference env parent
772 >>= signature_lookup_result_of_label_parent
773 >>= fun p -> LP.in_signature env p name
774 | `Root (name, `TPage) | `Root (name, `TChildPage) ->
775 Page.in_env env name >>= fun r -> Ok (`P r)
776 | `Root (name, `TChildModule) ->
777 resolve_signature_reference env (`Root (name, `TModule)) >>= fun s ->
778 Ok (`S s)
779 | `Page_path p -> Path.page_in_env env p >>= fun r -> Ok (`P r)
780 | `Module_path p ->
781 Path.module_in_env env p >>= module_lookup_to_signature_lookup env
782 >>= fun r -> Ok (`S r)
783 | `Any_path p ->
784 Path.any_in_env env p >>= fun r -> Ok (r :> label_parent_lookup_result)
785
786and resolve_fragment_type_parent_reference (env : Env.t)
787 (r : FragmentTypeParent.t) : (fragment_type_parent_lookup_result, _) result
788 =
789 let fragment_type_parent_res_of_type_res : datatype_lookup_result -> _ =
790 fun r -> Ok (`T r)
791 in
792 match r with
793 | `Resolved _ -> failwith "unimplemented"
794 | `Root (name, `TUnknown) -> FTP.in_env env name
795 | (`Module _ | `ModuleType _ | `Root (_, (`TModule | `TModuleType))) as sr ->
796 resolve_signature_reference env sr >>= fun s -> Ok (`S s)
797 | `Root (name, `TType) ->
798 DT.in_env env name >>= fragment_type_parent_res_of_type_res
799 | `Type (parent, name) ->
800 resolve_signature_reference env parent >>= fun p ->
801 DT.in_signature env p name
802 | `Dot (parent, name) ->
803 resolve_label_parent_reference env parent
804 >>= signature_lookup_result_of_label_parent
805 >>= fun p -> DT.in_signature env p (TypeName.make_std name)
806 | `Module_path p ->
807 Path.module_in_env env p >>= module_lookup_to_signature_lookup env
808 >>= fun r -> Ok (`S r)
809
810and resolve_signature_reference :
811 Env.t -> Signature.t -> signature_lookup_result ref_result =
812 fun env' r ->
813 let resolve env =
814 match r with
815 | `Resolved _r ->
816 failwith "What's going on here then?"
817 (* Some (resolve_resolved_signature_reference env r ~add_canonical) *)
818 | `Root (name, `TModule) ->
819 M.in_env env name >>= module_lookup_to_signature_lookup env
820 | `Module (parent, name) ->
821 resolve_signature_reference env parent >>= fun p ->
822 M.in_signature env p name >>= module_lookup_to_signature_lookup env
823 | `Root (name, `TModuleType) ->
824 MT.in_env env name >>= module_type_lookup_to_signature_lookup env
825 | `ModuleType (parent, name) ->
826 resolve_signature_reference env parent >>= fun p ->
827 MT.in_signature env p name
828 >>= module_type_lookup_to_signature_lookup env
829 | `Root (name, `TUnknown) -> (
830 env_lookup_by_name Env.s_signature name env >>= function
831 | `Module (_, _) as e ->
832 module_lookup_to_signature_lookup env (M.of_element env e)
833 | `ModuleType (_, _) as e ->
834 module_type_lookup_to_signature_lookup env (MT.of_element env e))
835 | `Dot (parent, name) -> (
836 resolve_label_parent_reference env parent
837 >>= signature_lookup_result_of_label_parent
838 >>= fun (parent, parent_cp, sg) ->
839 let parent_cp = Tools.reresolve_parent env parent_cp in
840 let sg = Tools.prefix_signature (parent_cp, sg) in
841 find_ambiguous ~kind:`S Find.signature_in_sig sg name >>= function
842 | `FModule (name, m) ->
843 module_lookup_to_signature_lookup env
844 (M.of_component env m
845 (`Module (parent_cp, name))
846 (`Module (parent, name)))
847 | `FModuleType (name, mt) ->
848 module_type_lookup_to_signature_lookup env
849 (MT.of_component env mt
850 (`ModuleType (parent_cp, name))
851 (`ModuleType (parent, name))))
852 | `Module_path p ->
853 Path.module_in_env env p >>= module_lookup_to_signature_lookup env
854 in
855 resolve env'
856
857and resolve_module_reference env (r : Module.t) : M.t ref_result =
858 match r with
859 | `Resolved _r -> failwith "What's going on!?"
860 (* Some (resolve_resolved_module_reference env r ~add_canonical)*)
861 | `Dot (parent, name) ->
862 resolve_label_parent_reference env parent
863 >>= signature_lookup_result_of_label_parent
864 >>= fun p -> M.in_signature env p (ModuleName.make_std name)
865 | `Module (parent, name) ->
866 resolve_signature_reference env parent >>= fun p ->
867 M.in_signature env p name
868 | `Root (name, _) -> M.in_env env name
869 | `Module_path p -> Path.module_in_env env p
870
871let resolve_class_signature_reference env (r : ClassSignature.t) =
872 (* Casting from ClassSignature to LabelParent.
873 TODO: Add [resolve_class_signature_reference] when it's easier to implement. *)
874 resolve_label_parent_reference env (r :> LabelParent.t) >>= function
875 | (`T _ | `C _ | `CT _) as p -> type_lookup_to_class_signature_lookup env p
876 | (`S _ | `P _) as r -> wrong_kind_error [ `T; `C; `CT ] r
877
878(***)
879
880let resolved1 r = Ok ((r :> Resolved.t), None)
881
882let resolved_with_text (r, txt) = Ok ((r :> Reference.Resolved.t), Some txt)
883
884let resolved3 (r, _, _) = resolved1 r
885
886and resolved2 (r, _) = resolved1 r
887
888let resolve_asset_reference env (r : Reference.Asset.t) : Asset.t ref_result =
889 match r with `Resolved r -> Ok r | `Asset_path p -> Path.asset_in_env env p
890
891let resolved_type_lookup = function
892 | `T (r, _) -> resolved1 r
893 | `C (r, _) -> resolved1 r
894 | `CT (r, _) -> resolved1 r
895
896let resolved_page_path_lookup = function
897 | `S (r, _, _) -> resolved1 r
898 | `P (r, _) -> resolved1 r
899
900let resolve_reference_dot_sg env ~parent_path ~parent_ref ~parent_sg name =
901 let parent_path = Tools.reresolve_parent env parent_path in
902 let parent_sg = Tools.prefix_signature (parent_path, parent_sg) in
903 find_ambiguous Find.any_in_sig parent_sg name >>= function
904 | `FModule (name, m) ->
905 resolved3
906 (M.of_component env m
907 (`Module (parent_path, name))
908 (`Module (parent_ref, name)))
909 | `FModuleType (name, mt) ->
910 resolved3
911 (MT.of_component env mt
912 (`ModuleType (parent_path, name))
913 (`ModuleType (parent_ref, name)))
914 | `FType (name, t) -> DT.of_component env t ~parent_ref name >>= resolved2
915 | `FClass (name, c) -> CL.of_component env c ~parent_ref name >>= resolved2
916 | `FClassType (name, ct) ->
917 CT.of_component env ct ~parent_ref name >>= resolved2
918 | `FValue (name, _) -> V.of_component env ~parent_ref name >>= resolved1
919 | `FLabel label -> L.of_component env ~parent_ref label >>= resolved_with_text
920 | `FExn (name, _) -> EX.of_component env ~parent_ref name >>= resolved1
921 | `FExt _ -> EC.of_component env ~parent_ref name >>= resolved1
922 | `In_type (typ_name, _, r) -> (
923 let parent = `Type (parent_ref, typ_name) in
924 match r with
925 | `FConstructor _ -> CS.of_component env parent name >>= resolved1
926 | `FPoly p -> CS.poly_of_component env parent p.name >>= resolved1
927 | `FField _ -> F.of_component env parent name >>= resolved1
928 | `FUnboxedField _ -> UF.of_component env parent name >>= resolved1)
929 | `FModule_subst _ | `FType_subst _ | `FModuleType_subst _ ->
930 Error (`Find_by_name (`Any, name))
931
932let resolve_reference_dot_page env page name =
933 L.in_page env page name >>= resolved_with_text
934
935let resolve_reference_dot_type env ~parent_ref t name =
936 find Find.any_in_type t (fun x -> x) name >>= function
937 | `FConstructor _ -> CS.of_component env parent_ref name >>= resolved1
938 | `FPoly p -> CS.poly_of_component env parent_ref p.name >>= resolved1
939 | `FField _ -> F.of_component env parent_ref name >>= resolved1
940 | `FUnboxedField _ -> UF.of_component env parent_ref name >>= resolved1
941
942let resolve_reference_dot_class env p name =
943 type_lookup_to_class_signature_lookup env p >>= fun (parent_ref, cs) ->
944 find_ambiguous Find.any_in_class_signature cs name >>= function
945 | `FMethod (name, _) -> MM.of_component env parent_ref name >>= resolved1
946 | `FInstance_variable (name, _) ->
947 MV.of_component env parent_ref name >>= resolved1
948
949let resolve_reference_dot env parent name =
950 resolve_label_parent_reference env parent >>= function
951 | `S (parent_ref, parent_path, parent_sg) ->
952 resolve_reference_dot_sg ~parent_path ~parent_ref ~parent_sg env name
953 | `T (parent_ref, t) -> resolve_reference_dot_type env ~parent_ref t name
954 | (`C _ | `CT _) as p -> resolve_reference_dot_class env p name
955 | `P _ as page -> resolve_reference_dot_page env page name
956
957(** Warnings may be generated with [Error.implicit_warning] *)
958let resolve_reference :
959 Env.t ->
960 Reference.t ->
961 ( Reference.Resolved.t * Odoc_model.Comment.paragraph option,
962 Errors.Tools_error.reference_lookup_error )
963 result =
964 let resolved = resolved3 in
965 fun env r ->
966 match r with
967 | `Root (name, `TUnknown) -> (
968 let identifier ?text id = Ok (`Identifier (id :> Identifier.t), text) in
969 env_lookup_by_name Env.s_any name env >>= function
970 | `Module (_, _) as e -> resolved (M.of_element env e)
971 | `ModuleType (_, _) as e -> resolved (MT.of_element env e)
972 | `Value (id, _) -> identifier id
973 | `Type (id, _) -> identifier id
974 | `Label (id, _) ->
975 let text =
976 match Env.lookup_by_id Env.s_label id env with
977 | Some (`Label (_, lbl)) -> Some lbl.Component.Label.text
978 | None -> None
979 in
980 identifier ?text id
981 | `Class (id, _) -> identifier id
982 | `ClassType (id, _) -> identifier id
983 | `Constructor (id, _) -> identifier id
984 | `Exception (id, _) -> identifier id
985 | `Extension (id, _, _) -> identifier id
986 | `ExtensionDecl (id, _) -> identifier id
987 | `Field (id, _) -> identifier id
988 | `UnboxedField (id, _) -> identifier id
989 | `Page (id, _) -> identifier id)
990 | `Resolved r -> Ok (r, None)
991 | `Root (name, (`TModule | `TChildModule)) -> M.in_env env name >>= resolved
992 | `Module (parent, name) ->
993 resolve_signature_reference env parent >>= fun p ->
994 M.in_signature env p name >>= resolved
995 | `Root (name, `TModuleType) -> MT.in_env env name >>= resolved
996 | `ModuleType (parent, name) ->
997 resolve_signature_reference env parent >>= fun p ->
998 MT.in_signature env p name >>= resolved
999 | `Root (name, `TType) -> T.in_env env name >>= resolved_type_lookup
1000 | `Type (parent, name) ->
1001 resolve_signature_reference env parent >>= fun p ->
1002 T.in_signature env p name >>= resolved_type_lookup
1003 | `Root (name, `TClass) -> CL.in_env env name >>= resolved2
1004 | `Class (parent, name) ->
1005 resolve_signature_reference env parent >>= fun p ->
1006 T.in_signature env p name >>= class_lookup_result_of_type >>= resolved2
1007 | `Root (name, `TClassType) -> CT.in_env env name >>= resolved2
1008 | `ClassType (parent, name) ->
1009 resolve_signature_reference env parent >>= fun p ->
1010 T.in_signature env p name >>= class_type_lookup_result_of_type
1011 >>= resolved2
1012 | `Root (name, `TValue) -> V.in_env env name >>= resolved1
1013 | `Value (parent, name) ->
1014 resolve_signature_reference env parent >>= fun p ->
1015 V.in_signature env p name >>= resolved1
1016 | `Root (name, `TLabel) -> L.in_env env name >>= resolved_with_text
1017 | `Label (parent, name) ->
1018 resolve_label_parent_reference env parent >>= fun p ->
1019 L.in_label_parent env p name >>= resolved_with_text
1020 | `Root (name, (`TPage | `TChildPage)) -> Page.in_env env name >>= resolved2
1021 | `Root (name, `TAsset) -> Asset.in_env env name >>= resolved1
1022 | `Dot (parent, name) -> resolve_reference_dot env parent name
1023 | `Root (name, `TConstructor) -> CS.in_env env name >>= resolved1
1024 | `Constructor (parent, name) ->
1025 resolve_fragment_type_parent_reference env parent >>= fun p ->
1026 CS.in_parent env p name >>= resolved1
1027 | `Root (name, `TException) -> EX.in_env env name >>= resolved1
1028 | `Exception (parent, name) ->
1029 resolve_signature_reference env parent >>= fun p ->
1030 EX.in_signature env p name >>= resolved1
1031 | `Root (name, `TExtension) -> EC.in_env env name >>= resolved1
1032 | `Extension (parent, name) ->
1033 resolve_signature_reference env parent >>= fun p ->
1034 EC.in_signature env p name >>= resolved1
1035 | `Root (name, `TExtensionDecl) -> ED.in_env env name >>= resolved1
1036 | `ExtensionDecl (parent, name) ->
1037 resolve_signature_reference env parent >>= fun p ->
1038 ED.in_signature env p name >>= resolved1
1039 | `Root (name, `TField) -> F.in_env env name >>= resolved1
1040 | `Field (parent, name) ->
1041 resolve_fragment_type_parent_reference env parent >>= fun p ->
1042 F.in_parent env p name >>= resolved1
1043 | `Root (name, `TUnboxedField) -> UF.in_env env name >>= resolved1
1044 | `UnboxedField (parent, name) ->
1045 resolve_fragment_type_parent_reference env parent >>= fun p ->
1046 UF.in_parent env p name >>= resolved1
1047 | `Root (name, `TMethod) -> MM.in_env env name >>= resolved1
1048 | `Method (parent, name) ->
1049 resolve_class_signature_reference env parent >>= fun p ->
1050 MM.in_class_signature env p name >>= resolved1
1051 | `Root (name, `TInstanceVariable) -> MV.in_env env name >>= resolved1
1052 | `InstanceVariable (parent, name) ->
1053 resolve_class_signature_reference env parent >>= fun p ->
1054 MV.in_class_signature env p name >>= resolved1
1055 | `Page_path p -> Path.page_in_env env p >>= resolved2
1056 | `Asset_path a -> Path.asset_in_env env a >>= resolved1
1057 | `Module_path p ->
1058 Path.module_in_env env p
1059 >>= module_lookup_to_signature_lookup env
1060 >>= resolved
1061 | `Any_path p -> Path.any_in_env env p >>= resolved_page_path_lookup
1062
1063let resolve_module_reference env m =
1064 Odoc_model.Error.catch_warnings (fun () -> resolve_module_reference env m)
1065
1066let resolve_asset_reference env m =
1067 Odoc_model.Error.catch_warnings (fun () -> resolve_asset_reference env m)
1068
1069let resolve_reference env m =
1070 Odoc_model.Error.catch_warnings (fun () -> resolve_reference env m)