jon.recoil.org
this repo has no description
1open Odoc_model
2open Paths
3open Names
4
5type maps = {
6 module_ : Identifier.Module.t Component.ModuleMap.t;
7 module_type : Identifier.ModuleType.t Component.ModuleTypeMap.t;
8 functor_parameter : (Ident.module_ * Identifier.FunctorParameter.t) list;
9 type_ : Identifier.Type.t Component.TypeMap.t;
10 path_type : Identifier.Path.Type.t Component.TypeMap.t;
11 class_ : (Ident.type_ * Identifier.Class.t) list;
12 class_type : (Ident.type_ * Identifier.ClassType.t) list;
13 path_class_type : Identifier.Path.ClassType.t Component.TypeMap.t;
14 fragment_root : Cfrag.root option;
15 (* Shadowed items *)
16 shadowed : Lang.Include.shadowed;
17}
18
19let empty_shadow =
20 let open Lang.Include in
21 {
22 s_modules = [];
23 s_module_types = [];
24 s_values = [];
25 s_types = [];
26 s_classes = [];
27 s_class_types = [];
28 }
29
30let empty () =
31 {
32 module_ = Component.ModuleMap.empty;
33 module_type = Component.ModuleTypeMap.empty;
34 functor_parameter = [];
35 type_ = Component.TypeMap.empty;
36 path_type = Component.TypeMap.empty;
37 class_ = [];
38 class_type = [];
39 path_class_type = Component.TypeMap.empty;
40 fragment_root = None;
41 shadowed = empty_shadow;
42 }
43
44let with_fragment_root r = { (empty ()) with fragment_root = Some r }
45
46let with_shadowed shadowed = { (empty ()) with shadowed }
47
48(** Raises [Not_found] *)
49let lookup_module map : Ident.module_ -> _ = function
50 | `LModule _ as id ->
51 (Component.ModuleMap.find id map.module_ :> Identifier.Path.Module.t)
52
53module Opt = Component.Opt
54
55module Path = struct
56 let rec module_ map (p : Cpath.module_) : Odoc_model.Paths.Path.Module.t =
57 match p with
58 | `Substituted x -> `Substituted (module_ map x)
59 | `Local (id, b) ->
60 let m =
61 try lookup_module map id
62 with Not_found ->
63 failwith (Format.asprintf "Not_found: %a" Ident.fmt id)
64 in
65 let hidden =
66 b
67 ||
68 match m.iv with
69 | `Module (_, n) -> Odoc_model.Names.ModuleName.is_hidden n
70 | _ -> false
71 in
72 `Identifier (m, hidden)
73 | `Identifier (i, b) -> `Identifier (i, b)
74 | `Resolved x -> `Resolved (resolved_module map x)
75 | `Root x -> `Root x
76 | `Dot (p, s) -> `Dot (module_ map p, s)
77 | `Forward s -> `Forward s
78 | `Apply (m1, m2) -> `Apply (module_ map m1, module_ map m2)
79 | `Module (`Module p, n) -> `Dot (`Resolved (resolved_module map p), n)
80 | `Module (_, _) -> failwith "Probably shouldn't happen"
81
82 and module_type map (p : Cpath.module_type) :
83 Odoc_model.Paths.Path.ModuleType.t =
84 match p with
85 | `Substituted x -> `SubstitutedMT (module_type map x)
86 | `Identifier
87 (({ iv = #Odoc_model.Paths.Identifier.ModuleType.t_pv; _ } as y), b) ->
88 `Identifier (y, b)
89 | `Local (id, b) ->
90 `Identifier
91 ( (try Component.ModuleTypeMap.find id map.module_type
92 with Not_found ->
93 failwith (Format.asprintf "Not_found: %a" Ident.fmt id)),
94 b )
95 | `Resolved x -> `Resolved (resolved_module_type map x)
96 | `DotMT (p, n) -> `DotMT (module_ map p, n)
97 | `ModuleType (`Module p, n) -> `DotMT (`Resolved (resolved_module map p), n)
98 | `ModuleType (_, _) -> failwith "Probably shouldn't happen"
99
100 and type_ map (p : Cpath.type_) : Odoc_model.Paths.Path.Type.t =
101 match p with
102 | `Substituted x -> `SubstitutedT (type_ map x)
103 | `Identifier
104 (({ iv = #Odoc_model.Paths.Identifier.Path.Type.t_pv; _ } as y), b) ->
105 `Identifier (y, b)
106 | `Local (id, b) -> `Identifier (Component.TypeMap.find id map.path_type, b)
107 | `Resolved x -> `Resolved (resolved_type map x)
108 | `DotT (p, n) -> `DotT (module_ map p, n)
109 | `Type (`Module p, n) -> `DotT (`Resolved (resolved_module map p), n)
110 | `Class (`Module p, n) -> `DotT (`Resolved (resolved_module map p), n)
111 | `ClassType (`Module p, n) -> `DotT (`Resolved (resolved_module map p), n)
112 | `Type _ | `Class _ | `ClassType _ -> failwith "Probably shouldn't happen"
113
114 and class_type map (p : Cpath.class_type) : Odoc_model.Paths.Path.ClassType.t
115 =
116 match p with
117 | `Substituted x -> `SubstitutedCT (class_type map x)
118 | `Identifier
119 (({ iv = #Odoc_model.Paths.Identifier.Path.ClassType.t_pv; _ } as y), b)
120 ->
121 `Identifier (y, b)
122 | `Local (id, b) ->
123 `Identifier (Component.TypeMap.find id map.path_class_type, b)
124 | `Resolved x -> `Resolved (resolved_class_type map x)
125 | `DotT (p, n) -> `DotT (module_ map p, n)
126 | `Class (`Module p, n) -> `DotT (`Resolved (resolved_module map p), n)
127 | `ClassType (`Module p, n) -> `DotT (`Resolved (resolved_module map p), n)
128 | `Class _ | `ClassType _ -> failwith "Probably shouldn't happen"
129
130 and resolved_module map (p : Cpath.Resolved.module_) :
131 Odoc_model.Paths.Path.Resolved.Module.t =
132 match p with
133 | `Local id ->
134 `Identifier
135 (try lookup_module map id
136 with Not_found ->
137 failwith (Format.asprintf "Not_found: %a" Ident.fmt id))
138 | `Substituted x -> `Substituted (resolved_module map x)
139 | `Gpath y -> y
140 | `Subst (mty, m) ->
141 `Subst (resolved_module_type map mty, resolved_module map m)
142 | `Hidden h -> `Hidden (resolved_module map h)
143 | `Module (p, n) -> `Module (resolved_parent map p, n)
144 | `Canonical (r, m) -> `Canonical (resolved_module map r, m)
145 | `Apply (m1, m2) -> `Apply (resolved_module map m1, resolved_module map m2)
146 | `Alias (m1, m2, _) -> `Alias (resolved_module map m1, module_ map m2)
147 | `OpaqueModule m -> `OpaqueModule (resolved_module map m)
148
149 and resolved_parent map (p : Cpath.Resolved.parent) =
150 match p with
151 | `Module m -> resolved_module map m
152 | `ModuleType _ -> failwith "Invalid"
153 | `FragmentRoot -> (
154 match map.fragment_root with
155 | Some r -> resolved_parent map (r :> Cpath.Resolved.parent)
156 | None -> failwith "Invalid")
157
158 and resolved_module_type map (p : Cpath.Resolved.module_type) :
159 Odoc_model.Paths.Path.Resolved.ModuleType.t =
160 match p with
161 | `Gpath y -> y
162 | `Local id ->
163 `Identifier
164 (try Component.ModuleTypeMap.find id map.module_type
165 with Not_found ->
166 failwith (Format.asprintf "Not_found: %a" Ident.fmt id))
167 | `ModuleType (p, name) -> `ModuleType (resolved_parent map p, name)
168 | `Substituted s -> `SubstitutedMT (resolved_module_type map s)
169 | `SubstT (p1, p2) ->
170 `SubstT (resolved_module_type map p1, resolved_module_type map p2)
171 | `AliasModuleType (p1, p2) ->
172 `AliasModuleType
173 (resolved_module_type map p1, resolved_module_type map p2)
174 | `CanonicalModuleType (p1, p2) ->
175 `CanonicalModuleType (resolved_module_type map p1, p2)
176 | `OpaqueModuleType m -> `OpaqueModuleType (resolved_module_type map m)
177
178 and resolved_type map (p : Cpath.Resolved.type_) :
179 Odoc_model.Paths.Path.Resolved.Type.t =
180 match p with
181 | `CoreType _ as c -> c
182 | `Gpath y -> y
183 | `Local id -> `Identifier (Component.TypeMap.find id map.path_type)
184 | `CanonicalType (t1, t2) -> `CanonicalType (resolved_type map t1, t2)
185 | `Type (p, name) -> `Type (resolved_parent map p, name)
186 | `Class (p, name) -> `Class (resolved_parent map p, name)
187 | `ClassType (p, name) -> `ClassType (resolved_parent map p, name)
188 | `Substituted s -> `SubstitutedT (resolved_type map s)
189
190 and resolved_value map (p : Cpath.Resolved.value) :
191 Odoc_model.Paths.Path.Resolved.Value.t =
192 match p with
193 | `Value (p, name) -> `Value (resolved_parent map p, name)
194 | `Gpath y -> y
195
196 and resolved_class_type map (p : Cpath.Resolved.class_type) :
197 Odoc_model.Paths.Path.Resolved.ClassType.t =
198 match p with
199 | `Gpath y -> y
200 | `Local id -> `Identifier (Component.TypeMap.find id map.path_class_type)
201 | `Class (p, name) -> `Class (resolved_parent map p, name)
202 | `ClassType (p, name) -> `ClassType (resolved_parent map p, name)
203 | `Substituted s -> `SubstitutedCT (resolved_class_type map s)
204
205 let rec module_fragment :
206 maps -> Cfrag.module_ -> Odoc_model.Paths.Fragment.Module.t =
207 fun map f ->
208 match f with
209 | `Resolved r -> `Resolved (resolved_module_fragment map r)
210 | `Dot (sg, p) -> `Dot (signature_fragment map sg, p)
211
212 and signature_fragment :
213 maps -> Cfrag.signature -> Odoc_model.Paths.Fragment.Signature.t =
214 fun map f ->
215 match f with
216 | `Resolved r -> `Resolved (resolved_signature_fragment map r)
217 | `Dot (sg, p) -> `Dot (signature_fragment map sg, p)
218 | `Root -> `Root
219
220 and type_fragment : maps -> Cfrag.type_ -> Odoc_model.Paths.Fragment.Type.t =
221 fun map f ->
222 match f with
223 | `Resolved r -> `Resolved (resolved_type_fragment map r)
224 | `Dot (sg, p) -> `Dot (signature_fragment map sg, p)
225
226 and resolved_module_fragment :
227 maps ->
228 Cfrag.resolved_module ->
229 Odoc_model.Paths.Fragment.Resolved.Module.t =
230 fun map f ->
231 match f with
232 | `Subst (p, f) ->
233 `Subst (resolved_module_type map p, resolved_module_fragment map f)
234 | `Alias (p, f) ->
235 `Alias (resolved_module map p, resolved_module_fragment map f)
236 | `Module (p, n) -> `Module (resolved_signature_fragment map p, n)
237 | `OpaqueModule m -> `OpaqueModule (resolved_module_fragment map m)
238
239 and resolved_signature_fragment :
240 maps ->
241 Cfrag.resolved_signature ->
242 Odoc_model.Paths.Fragment.Resolved.Signature.t =
243 fun map f ->
244 match f with
245 | `Root (`ModuleType p) -> `Root (`ModuleType (resolved_module_type map p))
246 | `Root (`Module p) -> `Root (`Module (resolved_module map p))
247 | (`OpaqueModule _ | `Subst _ | `Alias _ | `Module _) as x ->
248 (resolved_module_fragment map x
249 :> Odoc_model.Paths.Fragment.Resolved.Signature.t)
250
251 and resolved_type_fragment :
252 maps -> Cfrag.resolved_type -> Odoc_model.Paths.Fragment.Resolved.Type.t =
253 fun map f ->
254 match f with
255 | `Type (p, n) -> `Type (resolved_signature_fragment map p, n)
256 | `ClassType (p, n) -> `ClassType (resolved_signature_fragment map p, n)
257 | `Class (p, n) -> `Class (resolved_signature_fragment map p, n)
258
259 let rec module_type_fragment :
260 maps -> Cfrag.module_type -> Odoc_model.Paths.Fragment.ModuleType.t =
261 fun map f ->
262 match f with
263 | `Resolved r -> `Resolved (resolved_module_type_fragment map r)
264 | `Dot (sg, p) -> `Dot (signature_fragment map sg, p)
265
266 and resolved_module_type_fragment :
267 maps ->
268 Cfrag.resolved_module_type ->
269 Odoc_model.Paths.Fragment.Resolved.ModuleType.t =
270 fun map f ->
271 match f with
272 | `ModuleType (p, n) -> `Module_type (resolved_signature_fragment map p, n)
273end
274
275module ExtractIDs = struct
276 open Component
277
278 let rec type_decl parent map id =
279 let name = Ident.Name.type_ id in
280 let typed_name =
281 if List.mem_assoc name map.shadowed.s_types then
282 List.assoc name map.shadowed.s_types
283 else Ident.Name.typed_type id
284 in
285 let identifier = Identifier.Mk.type_ (parent, typed_name) in
286 {
287 map with
288 type_ = Component.TypeMap.add id identifier map.type_;
289 path_type =
290 Component.TypeMap.add
291 (id :> Ident.type_)
292 (identifier :> Identifier.Path.Type.t)
293 map.path_type;
294 }
295
296 and module_ parent map id =
297 let name = Ident.Name.module_ id in
298 let typed_name =
299 if List.mem_assoc name map.shadowed.s_modules then
300 List.assoc name map.shadowed.s_modules
301 else Ident.Name.typed_module id
302 in
303 let identifier = Identifier.Mk.module_ (parent, typed_name) in
304 { map with module_ = Component.ModuleMap.add id identifier map.module_ }
305
306 and module_type parent map id =
307 let name = Ident.Name.module_type id in
308 let typed_name =
309 if List.mem_assoc name map.shadowed.s_module_types then
310 List.assoc name map.shadowed.s_module_types
311 else Ident.Name.typed_module_type id
312 in
313 let identifier = Identifier.Mk.module_type (parent, typed_name) in
314 {
315 map with
316 module_type = Component.ModuleTypeMap.add id identifier map.module_type;
317 }
318
319 and class_ parent map id =
320 let name = Ident.Name.type_ id in
321 let typed_name =
322 if List.mem_assoc name map.shadowed.s_classes then
323 List.assoc name map.shadowed.s_classes
324 else Ident.Name.typed_type id
325 in
326 let identifier = Identifier.Mk.class_ (parent, typed_name) in
327 {
328 map with
329 class_ = (id, identifier) :: map.class_;
330 path_class_type =
331 Component.TypeMap.add
332 (id :> Ident.type_)
333 (identifier :> Identifier.Path.ClassType.t)
334 map.path_class_type;
335 path_type =
336 Component.TypeMap.add
337 (id :> Ident.type_)
338 (identifier :> Identifier.Path.Type.t)
339 map.path_type;
340 }
341
342 and class_type parent map (id : Ident.type_) =
343 let name = Ident.Name.type_ id in
344 let typed_name =
345 if List.mem_assoc name map.shadowed.s_class_types then
346 List.assoc name map.shadowed.s_class_types
347 else Ident.Name.typed_type id
348 in
349 let identifier = Identifier.Mk.class_type (parent, typed_name) in
350 {
351 map with
352 class_type = ((id :> Ident.type_), identifier) :: map.class_type;
353 path_class_type =
354 Component.TypeMap.add
355 (id :> Ident.type_)
356 (identifier :> Identifier.Path.ClassType.t)
357 map.path_class_type;
358 path_type =
359 Component.TypeMap.add
360 (id :> Ident.type_)
361 (identifier :> Identifier.Path.Type.t)
362 map.path_type;
363 }
364
365 and include_ parent map i = signature parent map i.Include.expansion_
366
367 and open_ parent map o = signature parent map o.Open.expansion
368
369 and signature_items parent map items =
370 let open Signature in
371 let rec inner items map =
372 match items with
373 | [] -> map
374 | Module (id, _, _) :: rest -> inner rest (module_ parent map id)
375 | ModuleSubstitution (id, _) :: rest -> inner rest (module_ parent map id)
376 | ModuleType (id, _mt) :: rest -> inner rest (module_type parent map id)
377 | ModuleTypeSubstitution (id, _mt) :: rest ->
378 inner rest (module_type parent map id)
379 | Type (id, _, _t) :: rest -> inner rest (type_decl parent map id)
380 | TypeSubstitution (id, _t) :: rest ->
381 inner rest (type_decl parent map id)
382 | Class (id, _, _) :: rest -> inner rest (class_ parent map id)
383 | ClassType (id, _, _) :: rest -> inner rest (class_type parent map id)
384 | Exception (_, _) :: rest
385 | Value (_, _) :: rest
386 | TypExt _ :: rest
387 | Comment _ :: rest ->
388 inner rest map
389 | Include i :: rest -> inner rest (include_ parent map i)
390 | Open o :: rest -> inner rest (open_ parent map o)
391 in
392 inner items map
393
394 and signature parent map sg =
395 let open Signature in
396 signature_items parent map sg.items
397end
398
399let rec signature_items id map items =
400 let open Component.Signature in
401 let parent = id in
402 let rec inner : item list -> Odoc_model.Lang.Signature.item list -> _ =
403 fun items acc ->
404 match items with
405 | [] -> List.rev acc
406 | Module (id, r, m) :: rest ->
407 let m = Component.Delayed.get m in
408 inner rest
409 (Odoc_model.Lang.Signature.Module (r, module_ map parent id m) :: acc)
410 | ModuleType (id, m) :: rest ->
411 inner rest
412 (Odoc_model.Lang.Signature.ModuleType (module_type map parent id m)
413 :: acc)
414 | ModuleTypeSubstitution (id, m) :: rest ->
415 inner rest
416 (Odoc_model.Lang.Signature.ModuleTypeSubstitution
417 (module_type_substitution map parent id m)
418 :: acc)
419 | Type (id, r, t) :: rest ->
420 let t = Component.Delayed.get t in
421 inner rest (Type (r, type_decl map parent id t) :: acc)
422 | Exception (id', e) :: rest ->
423 inner rest
424 (Exception
425 (exception_ map
426 (id :> Odoc_model.Paths.Identifier.Signature.t)
427 id' e)
428 :: acc)
429 | TypExt t :: rest -> inner rest (TypExt (typ_ext map id t) :: acc)
430 | Value (id, v) :: rest ->
431 let v = Component.Delayed.get v in
432 inner rest (Value (value_ map parent id v) :: acc)
433 | Include i :: rest -> inner rest (Include (include_ id map i) :: acc)
434 | Open o :: rest -> inner rest (Open (open_ id map o) :: acc)
435 | ModuleSubstitution (id, m) :: rest ->
436 inner rest
437 (ModuleSubstitution (module_substitution map parent id m) :: acc)
438 | TypeSubstitution (id, t) :: rest ->
439 inner rest (TypeSubstitution (type_decl map parent id t) :: acc)
440 | Class (id, r, c) :: rest ->
441 inner rest (Class (r, class_ map parent id c) :: acc)
442 | ClassType (id, r, c) :: rest ->
443 inner rest (ClassType (r, class_type map parent id c) :: acc)
444 | Comment c :: rest ->
445 inner rest
446 (Comment (docs_or_stop (id :> Identifier.LabelParent.t) c) :: acc)
447 in
448 inner items []
449
450and signature :
451 Paths.Identifier.Signature.t ->
452 maps ->
453 Component.Signature.t ->
454 Lang.Signature.t =
455 fun id map sg ->
456 let open Component.Signature in
457 let map = ExtractIDs.signature_items id map sg.items in
458 let removed = List.map (removed_item map id) sg.removed in
459 {
460 items = signature_items id map sg.items;
461 compiled = sg.compiled;
462 removed;
463 doc = docs (id :> Identifier.LabelParent.t) sg.doc;
464 }
465
466and removed_item :
467 maps ->
468 Identifier.Id.signature ->
469 Component.Signature.removed_item ->
470 Lang.Signature.removed_item =
471 fun map parent item ->
472 match item with
473 | RModule (id, m) -> RModule (id, Path.module_ map m)
474 | RType (id, texpr, eqn) ->
475 RType
476 ( id,
477 type_expr map (parent :> Identifier.LabelParent.t) texpr,
478 type_decl_equation map (parent :> Identifier.FieldParent.t) eqn )
479 | RModuleType (id, m) -> RModuleType (id, module_type_expr map parent m)
480
481and class_ map parent id c =
482 let open Component.Class in
483 let identifier = List.assoc id map.class_ in
484 let expansion =
485 Opt.map
486 (class_signature map (identifier :> Identifier.ClassSignature.t))
487 c.expansion
488 in
489 {
490 id = identifier;
491 source_loc = c.source_loc;
492 source_loc_jane = c.source_loc_jane;
493 doc = docs (parent :> Identifier.LabelParent.t) c.doc;
494 virtual_ = c.virtual_;
495 params = c.params;
496 type_ =
497 class_decl map (identifier :> Paths.Identifier.Path.ClassType.t) c.type_;
498 expansion;
499 }
500
501and class_decl map parent c =
502 match c with
503 | Component.Class.ClassType expr ->
504 ClassType (class_type_expr map parent expr)
505 | Arrow (lbl, t, d) ->
506 Arrow
507 ( lbl,
508 type_expr map (parent :> Identifier.LabelParent.t) t,
509 class_decl map parent d )
510
511and class_type_expr map parent c =
512 match c with
513 | Component.ClassType.Constr (p, ts) ->
514 Constr
515 ( Path.class_type map p,
516 List.rev_map (type_expr map (parent :> Identifier.LabelParent.t)) ts
517 |> List.rev )
518 | Signature s -> Signature (class_signature map parent s)
519
520and class_type map parent id c =
521 let open Component.ClassType in
522 let identifier = List.assoc id map.class_type in
523 let expansion =
524 Opt.map
525 (class_signature map (identifier :> Identifier.ClassSignature.t))
526 c.expansion
527 in
528 {
529 Odoc_model.Lang.ClassType.id = identifier;
530 source_loc = c.source_loc;
531 source_loc_jane = c.source_loc_jane;
532 doc = docs (parent :> Identifier.LabelParent.t) c.doc;
533 virtual_ = c.virtual_;
534 params = c.params;
535 expr =
536 class_type_expr map
537 (identifier :> Paths.Identifier.Path.ClassType.t)
538 c.expr;
539 expansion;
540 }
541
542and class_signature map parent sg =
543 let open Component.ClassSignature in
544 let pparent = (parent :> Identifier.LabelParent.t) in
545 let items =
546 List.rev_map
547 (function
548 | Method (id, m) ->
549 Odoc_model.Lang.ClassSignature.Method (method_ map parent id m)
550 | InstanceVariable (id, i) ->
551 InstanceVariable (instance_variable map parent id i)
552 | Constraint cst -> Constraint (class_constraint map pparent cst)
553 | Inherit e -> Inherit (inherit_ map parent e)
554 | Comment c ->
555 Comment (docs_or_stop (parent :> Identifier.LabelParent.t) c))
556 sg.items
557 |> List.rev
558 and doc = docs (parent :> Identifier.LabelParent.t) sg.doc in
559 { self = Opt.map (type_expr map pparent) sg.self; items; doc }
560
561and method_ map parent id m =
562 let open Component.Method in
563 let identifier = Identifier.Mk.method_ (parent, Ident.Name.typed_method id) in
564 {
565 id = identifier;
566 doc = docs (parent :> Identifier.LabelParent.t) m.doc;
567 private_ = m.private_;
568 virtual_ = m.virtual_;
569 type_ = type_expr map (parent :> Identifier.LabelParent.t) m.type_;
570 }
571
572and instance_variable map parent id i =
573 let open Component.InstanceVariable in
574 let identifier =
575 Identifier.Mk.instance_variable
576 (parent, Ident.Name.typed_instance_variable id)
577 in
578 {
579 id = identifier;
580 doc = docs (parent :> Identifier.LabelParent.t) i.doc;
581 mutable_ = i.mutable_;
582 virtual_ = i.virtual_;
583 type_ = type_expr map (parent :> Identifier.LabelParent.t) i.type_;
584 }
585
586and class_constraint map parent cst =
587 let open Component.ClassSignature.Constraint in
588 let left = type_expr map parent cst.left
589 and right = type_expr map parent cst.right
590 and doc = docs (parent :> Identifier.LabelParent.t) cst.doc in
591 { left; right; doc }
592
593and inherit_ map parent ih =
594 let open Component.ClassSignature.Inherit in
595 let expr = class_type_expr map parent ih.expr
596 and doc = docs (parent :> Identifier.LabelParent.t) ih.doc in
597 { expr; doc }
598
599and simple_expansion :
600 maps ->
601 Identifier.Signature.t ->
602 Component.ModuleType.simple_expansion ->
603 Lang.ModuleType.simple_expansion =
604 fun map id e ->
605 let open Component.FunctorParameter in
606 match e with
607 | Signature sg -> Signature (signature id map sg)
608 | Functor (Named arg, sg) ->
609 let identifier = Identifier.Mk.result id in
610 let name = Ident.Name.typed_module arg.id in
611 let param_identifier = Identifier.Mk.parameter (id, name) in
612 let map =
613 {
614 map with
615 functor_parameter =
616 (arg.id, param_identifier) :: map.functor_parameter;
617 module_ = Component.ModuleMap.add arg.id param_identifier map.module_;
618 }
619 in
620 let arg = functor_parameter map arg in
621 Functor (Named arg, simple_expansion map identifier sg)
622 | Functor (Unit, sg) ->
623 Functor (Unit, simple_expansion map (Identifier.Mk.result id) sg)
624
625and combine_shadowed s1 s2 =
626 let open Odoc_model.Lang.Include in
627 (* If something was already shadowed in the include, it mustn't be
628 added to the combined map. *)
629 let combine s1 s2 =
630 List.fold_left
631 (fun acc (name, typed_name) ->
632 if List.mem_assoc name acc then acc else (name, typed_name) :: acc)
633 s2 s1
634 in
635 {
636 s_modules = combine s1.s_modules s2.s_modules;
637 s_module_types = combine s1.s_module_types s2.s_module_types;
638 s_values = combine s1.s_values s2.s_values;
639 s_types = combine s1.s_types s2.s_types;
640 s_classes = combine s1.s_classes s2.s_classes;
641 s_class_types = combine s1.s_class_types s2.s_class_types;
642 }
643
644and include_decl :
645 maps ->
646 Odoc_model.Paths.Identifier.Signature.t ->
647 Component.Include.decl ->
648 Odoc_model.Lang.Include.decl =
649 fun map identifier d ->
650 let map = { map with shadowed = empty_shadow } in
651 (* Don't start shadowing within any signatures *)
652 match d with
653 | Alias p -> Alias (Path.module_ map p)
654 | ModuleType mty ->
655 let include_parent = Identifier.fresh_include_parent identifier in
656 ModuleType (u_module_type_expr map include_parent mty)
657
658and include_ parent map i =
659 let open Component.Include in
660 let shadowed = combine_shadowed map.shadowed i.shadowed in
661 {
662 Odoc_model.Lang.Include.parent;
663 doc = docs (parent :> Identifier.LabelParent.t) i.doc;
664 decl = include_decl map parent i.decl;
665 expansion =
666 {
667 shadowed;
668 content = signature parent { map with shadowed } i.expansion_;
669 };
670 expanded = i.expanded;
671 status = i.status;
672 strengthened = Opt.map (Path.module_ map) i.strengthened;
673 loc = i.loc;
674 }
675
676and open_ parent map o =
677 let open Component.Open in
678 {
679 Odoc_model.Lang.Open.expansion = signature parent map o.expansion;
680 doc = docs (parent :> Identifier.LabelParent.t) o.doc;
681 }
682
683and value_ map parent id v =
684 let open Component.Value in
685 let name = Ident.Name.value id in
686 let typed_name =
687 if List.mem_assoc name map.shadowed.s_values then
688 List.assoc name map.shadowed.s_values
689 else Ident.Name.typed_value id
690 in
691 let identifier = Identifier.Mk.value (parent, typed_name) in
692 {
693 id = identifier;
694 source_loc = v.source_loc;
695 source_loc_jane = v.source_loc_jane;
696 doc = docs (parent :> Identifier.LabelParent.t) v.doc;
697 type_ = type_expr map (parent :> Identifier.LabelParent.t) v.type_;
698 value = v.value;
699 modalities = v.modalities;
700 }
701
702and typ_ext map parent t =
703 let open Component.Extension in
704 {
705 parent;
706 type_path = (Path.type_ map t.type_path :> Paths.Path.Type.t);
707 doc = docs (parent :> Identifier.LabelParent.t) t.doc;
708 type_params = t.type_params;
709 private_ = t.private_;
710 constructors = List.map (extension_constructor map parent) t.constructors;
711 }
712
713and extension_constructor map parent c =
714 let open Component.Extension.Constructor in
715 let identifier =
716 Identifier.Mk.extension (parent, ExtensionName.make_std c.name)
717 in
718 {
719 id = identifier;
720 source_loc = c.source_loc;
721 doc = docs (parent :> Identifier.LabelParent.t) c.doc;
722 args =
723 type_decl_constructor_argument map
724 (parent :> Identifier.FieldParent.t)
725 c.args;
726 res = Opt.map (type_expr map (parent :> Identifier.LabelParent.t)) c.res;
727 }
728
729and module_ map parent id m =
730 try
731 let open Component.Module in
732 let id =
733 (Component.ModuleMap.find id map.module_ :> Paths.Identifier.Module.t)
734 in
735 let identifier = (id :> Odoc_model.Paths.Identifier.Signature.t) in
736 let map = { map with shadowed = empty_shadow } in
737 {
738 Odoc_model.Lang.Module.id;
739 source_loc = m.source_loc;
740 source_loc_jane = m.source_loc_jane;
741 doc = docs (parent :> Identifier.LabelParent.t) m.doc;
742 type_ = module_decl map identifier m.type_;
743 canonical = m.canonical;
744 hidden = m.hidden;
745 }
746 with e ->
747 let bt = Printexc.get_backtrace () in
748 Format.fprintf Format.err_formatter
749 "Exception handling module: %a\nbacktrace:\n%s\n%!" Ident.fmt id bt;
750 raise e
751
752and module_substitution map parent id m =
753 let open Component.ModuleSubstitution in
754 {
755 Odoc_model.Lang.ModuleSubstitution.id =
756 (Component.ModuleMap.find id map.module_ :> Identifier.Module.t);
757 doc = docs (parent :> Identifier.LabelParent.t) m.doc;
758 manifest = Path.module_ map m.manifest;
759 }
760
761and module_decl :
762 maps ->
763 Odoc_model.Paths.Identifier.Signature.t ->
764 Component.Module.decl ->
765 Odoc_model.Lang.Module.decl =
766 fun map identifier d ->
767 match d with
768 | Component.Module.Alias (p, s) ->
769 Odoc_model.Lang.Module.Alias
770 (Path.module_ map p, Opt.map (simple_expansion map identifier) s)
771 | ModuleType mty -> ModuleType (module_type_expr map identifier mty)
772
773and mty_substitution map identifier = function
774 | Component.ModuleType.ModuleEq (frag, decl) ->
775 Odoc_model.Lang.ModuleType.ModuleEq
776 (Path.module_fragment map frag, module_decl map identifier decl)
777 | ModuleSubst (frag, path) ->
778 ModuleSubst (Path.module_fragment map frag, Path.module_ map path)
779 | TypeEq (frag, eqn) ->
780 TypeEq
781 ( Path.type_fragment map frag,
782 type_decl_equation map (identifier :> Identifier.FieldParent.t) eqn )
783 | TypeSubst (frag, eqn) ->
784 TypeSubst
785 ( Path.type_fragment map frag,
786 type_decl_equation map (identifier :> Identifier.FieldParent.t) eqn )
787 | ModuleTypeEq (frag, eqn) ->
788 ModuleTypeEq
789 (Path.module_type_fragment map frag, module_type_expr map identifier eqn)
790 | ModuleTypeSubst (frag, eqn) ->
791 ModuleTypeSubst
792 (Path.module_type_fragment map frag, module_type_expr map identifier eqn)
793
794and u_module_type_expr map identifier = function
795 | Component.ModuleType.U.Path p_path ->
796 Odoc_model.Lang.ModuleType.U.Path (Path.module_type map p_path)
797 | Signature s ->
798 Signature
799 (signature
800 (identifier :> Odoc_model.Paths.Identifier.Signature.t)
801 map s)
802 | With (subs, expr) ->
803 With
804 ( List.map (mty_substitution map identifier) subs,
805 u_module_type_expr map identifier expr )
806 | TypeOf (ModPath p, original_path) ->
807 TypeOf (ModPath (Path.module_ map p), Path.module_ map original_path)
808 | TypeOf (StructInclude p, original_path) ->
809 TypeOf (StructInclude (Path.module_ map p), Path.module_ map original_path)
810 | Strengthen (expr, path, aliasable) ->
811 let expr = u_module_type_expr map identifier expr in
812 let path = Path.module_ map path in
813 Strengthen (expr, path, aliasable)
814
815and module_type_expr map identifier = function
816 | Component.ModuleType.Path { p_path; p_expansion } ->
817 Odoc_model.Lang.ModuleType.Path
818 {
819 p_path = Path.module_type map p_path;
820 p_expansion = Opt.map (simple_expansion map identifier) p_expansion;
821 }
822 | Signature s ->
823 Signature
824 (signature
825 (identifier :> Odoc_model.Paths.Identifier.Signature.t)
826 map s)
827 | With { w_substitutions; w_expansion; w_expr } ->
828 With
829 {
830 w_substitutions =
831 List.map (mty_substitution map identifier) w_substitutions;
832 w_expansion = Opt.map (simple_expansion map identifier) w_expansion;
833 w_expr = u_module_type_expr map identifier w_expr;
834 }
835 | Functor (Named arg, expr) ->
836 let name = Ident.Name.typed_module arg.id in
837 let identifier' = Identifier.Mk.parameter (identifier, name) in
838 let map =
839 {
840 map with
841 functor_parameter = (arg.id, identifier') :: map.functor_parameter;
842 module_ = Component.ModuleMap.add arg.id identifier' map.module_;
843 }
844 in
845 Functor
846 ( Named (functor_parameter map arg),
847 module_type_expr map (Identifier.Mk.result identifier) expr )
848 | Functor (Unit, expr) ->
849 Functor (Unit, module_type_expr map (Identifier.Mk.result identifier) expr)
850 | TypeOf { t_desc = ModPath p; t_original_path; t_expansion } ->
851 TypeOf
852 {
853 t_desc = ModPath (Path.module_ map p);
854 t_original_path = Path.module_ map t_original_path;
855 t_expansion = Opt.map (simple_expansion map identifier) t_expansion;
856 }
857 | TypeOf { t_desc = StructInclude p; t_original_path; t_expansion } ->
858 TypeOf
859 {
860 t_desc = StructInclude (Path.module_ map p);
861 t_original_path = Path.module_ map t_original_path;
862 t_expansion = Opt.map (simple_expansion map identifier) t_expansion;
863 }
864 | Strengthen { s_expr; s_path; s_aliasable; s_expansion } ->
865 Strengthen
866 {
867 s_expr = u_module_type_expr map identifier s_expr;
868 s_path = Path.module_ map s_path;
869 s_aliasable;
870 s_expansion = Opt.map (simple_expansion map identifier) s_expansion
871 }
872
873and module_type :
874 maps ->
875 Identifier.Signature.t ->
876 Ident.module_type ->
877 Component.ModuleType.t Component.Delayed.t ->
878 Odoc_model.Lang.ModuleType.t =
879 fun map parent id mty ->
880 let identifier = Component.ModuleTypeMap.find id map.module_type in
881 let mty = Component.Delayed.get mty in
882 let sig_id = (identifier :> Odoc_model.Paths.Identifier.Signature.t) in
883 let map = { map with shadowed = empty_shadow } in
884 {
885 Odoc_model.Lang.ModuleType.id = identifier;
886 source_loc = mty.source_loc;
887 source_loc_jane = mty.source_loc_jane;
888 doc = docs (parent :> Identifier.LabelParent.t) mty.doc;
889 canonical = mty.canonical;
890 expr = Opt.map (module_type_expr map sig_id) mty.expr;
891 }
892
893and module_type_substitution :
894 maps ->
895 Identifier.Signature.t ->
896 Ident.module_type ->
897 Component.ModuleTypeSubstitution.t ->
898 Odoc_model.Lang.ModuleTypeSubstitution.t =
899 fun map parent id mty ->
900 let identifier = Component.ModuleTypeMap.find id map.module_type in
901 let sig_id = (identifier :> Odoc_model.Paths.Identifier.Signature.t) in
902 let map = { map with shadowed = empty_shadow } in
903 {
904 Odoc_model.Lang.ModuleTypeSubstitution.id = identifier;
905 doc = docs (parent :> Identifier.LabelParent.t) mty.doc;
906 manifest = module_type_expr map sig_id mty.manifest;
907 }
908
909and type_decl_constructor_argument :
910 maps ->
911 Paths.Identifier.FieldParent.t ->
912 Component.TypeDecl.Constructor.argument ->
913 Odoc_model.Lang.TypeDecl.Constructor.argument =
914 fun map parent a ->
915 match a with
916 | Tuple ls ->
917 Tuple (List.map (type_expr map (parent :> Identifier.LabelParent.t)) ls)
918 | Record fs ->
919 Record
920 (List.map (type_decl_field map (parent :> Identifier.FieldParent.t)) fs)
921
922and type_decl_field :
923 maps ->
924 Identifier.FieldParent.t ->
925 Component.TypeDecl.Field.t ->
926 Odoc_model.Lang.TypeDecl.Field.t =
927 fun map parent f ->
928 let identifier = Identifier.Mk.field (parent, FieldName.make_std f.name) in
929 {
930 id = identifier;
931 doc = docs (parent :> Identifier.LabelParent.t) f.doc;
932 mutable_ = f.mutable_;
933 type_ = type_expr map (parent :> Identifier.LabelParent.t) f.type_;
934 }
935
936and type_decl_unboxed_field :
937 maps ->
938 Identifier.UnboxedFieldParent.t ->
939 Component.TypeDecl.UnboxedField.t ->
940 Odoc_model.Lang.TypeDecl.UnboxedField.t =
941 fun map parent f ->
942 let identifier = Identifier.Mk.unboxed_field (parent, UnboxedFieldName.make_std f.name) in
943 {
944 id = identifier;
945 doc = docs (parent :> Identifier.LabelParent.t) f.doc;
946 mutable_ = f.mutable_;
947 type_ = type_expr map (parent :> Identifier.LabelParent.t) f.type_;
948 }
949
950and type_decl_equation map (parent : Identifier.FieldParent.t)
951 (eqn : Component.TypeDecl.Equation.t) : Odoc_model.Lang.TypeDecl.Equation.t
952 =
953 let parent = (parent :> Identifier.LabelParent.t) in
954 {
955 params = eqn.params;
956 private_ = eqn.private_;
957 manifest = Opt.map (type_expr map parent) eqn.manifest;
958 constraints =
959 List.map
960 (fun (x, y) -> (type_expr map parent x, type_expr map parent y))
961 eqn.constraints;
962 }
963
964and type_decl map parent id (t : Component.TypeDecl.t) :
965 Odoc_model.Lang.TypeDecl.t =
966 let identifier = Component.TypeMap.find id map.type_ in
967 {
968 id = identifier;
969 source_loc = t.source_loc;
970 source_loc_jane = t.source_loc_jane;
971 equation =
972 type_decl_equation map (parent :> Identifier.FieldParent.t) t.equation;
973 doc = docs (parent :> Identifier.LabelParent.t) t.doc;
974 canonical = t.canonical;
975 representation =
976 Opt.map (type_decl_representation map identifier) t.representation;
977 }
978
979and type_decl_representation map id (t : Component.TypeDecl.Representation.t) :
980 Odoc_model.Lang.TypeDecl.Representation.t =
981 match t with
982 | Extensible -> Extensible
983 | Variant cs -> Variant (List.map (type_decl_constructor map id) cs)
984 | Record fs ->
985 Record
986 (List.map
987 (type_decl_field map
988 (id :> Odoc_model.Paths.Identifier.FieldParent.t))
989 fs)
990 | Record_unboxed_product fs ->
991 Record_unboxed_product
992 (List.map
993 (type_decl_unboxed_field map
994 (id :> Odoc_model.Paths.Identifier.UnboxedFieldParent.t))
995 fs)
996
997and type_decl_constructor :
998 maps ->
999 Odoc_model.Paths.Identifier.DataType.t ->
1000 Component.TypeDecl.Constructor.t ->
1001 Odoc_model.Lang.TypeDecl.Constructor.t =
1002 fun map id t ->
1003 let identifier =
1004 Identifier.Mk.constructor (id, ConstructorName.make_std t.name)
1005 in
1006 let parent = (id :> Identifier.LabelParent.t) in
1007 {
1008 id = identifier;
1009 doc = docs parent t.doc;
1010 args =
1011 type_decl_constructor_argument map (id :> Identifier.FieldParent.t) t.args;
1012 res = Opt.map (type_expr map parent) t.res;
1013 }
1014
1015and type_expr_package map (parent : Identifier.LabelParent.t) t =
1016 {
1017 Lang.TypeExpr.Package.path =
1018 Path.module_type map t.Component.TypeExpr.Package.path;
1019 substitutions =
1020 List.map
1021 (fun (frag, texpr) ->
1022 (Path.type_fragment map frag, type_expr map parent texpr))
1023 t.substitutions;
1024 }
1025
1026and type_expr map (parent : Identifier.LabelParent.t) (t : Component.TypeExpr.t)
1027 : Odoc_model.Lang.TypeExpr.t =
1028 try
1029 match t with
1030 | Var (s, jk) -> Var (s, jk)
1031 | Any -> Any
1032 | Alias (t, str) -> Alias (type_expr map parent t, str)
1033 | Arrow (lbl, t1, t2, modes, ret_modes) ->
1034 Arrow (lbl, type_expr map parent t1, type_expr map parent t2, modes, ret_modes)
1035 | Tuple ts ->
1036 Tuple (List.map (fun (lbl, ty) -> (lbl, type_expr map parent ty)) ts)
1037 | Unboxed_tuple ts ->
1038 Unboxed_tuple (List.map (fun (l, t) -> l, type_expr map parent t) ts)
1039 | Constr (path, ts) ->
1040 Constr
1041 ( (Path.type_ map path :> Paths.Path.Type.t),
1042 List.map (type_expr map parent) ts )
1043 | Polymorphic_variant v ->
1044 Polymorphic_variant (type_expr_polyvar map parent v)
1045 | Object o -> Object (type_expr_object map parent o)
1046 | Class (p, ts) ->
1047 Class (Path.class_type map p, List.map (type_expr map parent) ts)
1048 | Poly (strs, t) -> Poly (strs, type_expr map parent t)
1049 | Quote t -> Quote (type_expr map parent t)
1050 | Splice t -> Splice (type_expr map parent t)
1051 | Package p -> Package (type_expr_package map parent p)
1052 with e ->
1053 let bt = Printexc.get_backtrace () in
1054 Format.fprintf Format.err_formatter
1055 "Exception %s handling type_expr: %a\nbacktrace:\n%s\n%!"
1056 (Printexc.to_string e)
1057 Component.Fmt.(type_expr default)
1058 t bt;
1059 raise e
1060
1061and type_expr_polyvar map parent v =
1062 let constructor c =
1063 {
1064 Lang.TypeExpr.Polymorphic_variant.Constructor.name =
1065 c.Component.TypeExpr.Polymorphic_variant.Constructor.name;
1066 constant = c.constant;
1067 arguments = List.map (type_expr map parent) c.arguments;
1068 doc = docs parent c.doc;
1069 }
1070 in
1071 let element = function
1072 | Component.TypeExpr.Polymorphic_variant.Type t ->
1073 Lang.TypeExpr.Polymorphic_variant.Type (type_expr map parent t)
1074 | Constructor c -> Constructor (constructor c)
1075 in
1076 { kind = v.kind; elements = List.map element v.elements }
1077
1078and type_expr_object map parent o =
1079 let method_ m =
1080 {
1081 Lang.TypeExpr.Object.name = m.Component.TypeExpr.Object.name;
1082 type_ = type_expr map parent m.type_;
1083 }
1084 in
1085 let field = function
1086 | Component.TypeExpr.Object.Method m ->
1087 Lang.TypeExpr.Object.Method (method_ m)
1088 | Inherit i -> Inherit (type_expr map parent i)
1089 in
1090 { Lang.TypeExpr.Object.fields = List.map field o.fields; open_ = o.open_ }
1091
1092and functor_parameter map f : Odoc_model.Lang.FunctorParameter.parameter =
1093 let identifier = List.assoc f.id map.functor_parameter in
1094 {
1095 Odoc_model.Lang.FunctorParameter.id = identifier;
1096 expr =
1097 module_type_expr map
1098 (identifier :> Odoc_model.Paths.Identifier.Signature.t)
1099 f.expr;
1100 }
1101
1102and exception_ map parent id (e : Component.Exception.t) :
1103 Odoc_model.Lang.Exception.t =
1104 let identifier =
1105 Identifier.Mk.exception_ (parent, Ident.Name.typed_exception id)
1106 in
1107 {
1108 id = identifier;
1109 source_loc = e.source_loc;
1110 source_loc_jane = e.source_loc_jane;
1111 doc = docs (parent :> Identifier.LabelParent.t) e.doc;
1112 args =
1113 type_decl_constructor_argument map
1114 (parent :> Identifier.FieldParent.t)
1115 e.args;
1116 res = Opt.map (type_expr map (parent :> Identifier.LabelParent.t)) e.res;
1117 }
1118
1119and block_element parent
1120 (d : Component.CComment.block_element Odoc_model.Location_.with_location) :
1121 Odoc_model.Comment.block_element Odoc_model.Location_.with_location =
1122 let value =
1123 match d.Odoc_model.Location_.value with
1124 | `Heading h ->
1125 let { Component.Label.attrs; label; text; location = _ } = h in
1126 let label =
1127 try Identifier.Mk.label (parent, Ident.Name.typed_label label)
1128 with Not_found ->
1129 Format.fprintf Format.err_formatter "Failed to find id: %a\n"
1130 Ident.fmt label;
1131 raise Not_found
1132 in
1133 `Heading (attrs, label, text)
1134 | (`Tag _ | `Media _) as orig -> orig
1135 | #Odoc_model.Comment.nestable_block_element as n -> n
1136 in
1137 { d with Odoc_model.Location_.value }
1138
1139and docs :
1140 Identifier.LabelParent.t ->
1141 Component.CComment.docs ->
1142 Odoc_model.Comment.docs =
1143 fun parent ds ->
1144 {
1145 elements =
1146 List.rev_map (fun d -> block_element parent d) ds.elements |> List.rev;
1147 warnings_tag = ds.warnings_tag;
1148 }
1149
1150and docs_or_stop parent (d : Component.CComment.docs_or_stop) =
1151 match d with `Docs d -> `Docs (docs parent d) | `Stop -> `Stop