jon.recoil.org
this repo has no description
1module Maps = Odoc_model.Paths.Identifier.Maps
2
3module ModuleMap = Map.Make (struct
4 type t = Ident.module_
5
6 let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any)
7end)
8
9module TypeMap = Map.Make (struct
10 type t = Ident.type_
11
12 let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any)
13end)
14
15module ModuleTypeMap = Map.Make (struct
16 type t = Ident.module_type
17
18 let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any)
19end)
20
21module ValueMap = Map.Make (struct
22 type t = Ident.value
23
24 let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any)
25end)
26
27module IdentMap = Map.Make (struct
28 type t = Ident.any
29
30 let compare = Ident.compare
31end)
32
33module Delayed = struct
34 let eager = ref false
35
36 type 'a t = { mutable v : 'a option; mutable get : (unit -> 'a) option }
37
38 let get : 'a t -> 'a =
39 fun x ->
40 match (x.v, x.get) with
41 | Some x, _ -> x
42 | None, Some get ->
43 let v = get () in
44 x.v <- Some v;
45 x.get <- None;
46 v
47 | _, _ -> failwith "bad delayed"
48
49 let put : (unit -> 'a) -> 'a t =
50 fun f ->
51 if !eager then { v = Some (f ()); get = None }
52 else { v = None; get = Some f }
53
54 let put_val : 'a -> 'a t = fun v -> { v = Some v; get = None }
55end
56
57module Opt = struct
58 let map f = function Some x -> Some (f x) | None -> None
59end
60
61module rec Module : sig
62 type decl =
63 | Alias of Cpath.module_ * ModuleType.simple_expansion option
64 | ModuleType of ModuleType.expr
65
66 type t = {
67 source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option;
68 source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option;
69 doc : CComment.docs;
70 type_ : decl;
71 canonical : Odoc_model.Paths.Path.Module.t option;
72 hidden : bool;
73 }
74end =
75 Module
76
77and ModuleSubstitution : sig
78 type t = { doc : CComment.docs; manifest : Cpath.module_ }
79end =
80 ModuleSubstitution
81
82and ModuleTypeSubstitution : sig
83 type t = { doc : CComment.docs; manifest : ModuleType.expr }
84end =
85 ModuleTypeSubstitution
86
87and TypeExpr : sig
88 module Polymorphic_variant : sig
89 type kind = Odoc_model.Lang.TypeExpr.Polymorphic_variant.kind
90
91 module Constructor : sig
92 type t = {
93 name : string;
94 constant : bool;
95 arguments : TypeExpr.t list;
96 doc : CComment.docs;
97 }
98 end
99
100 type element = Type of TypeExpr.t | Constructor of Constructor.t
101
102 type t = { kind : kind; elements : element list }
103 end
104
105 module Object : sig
106 type method_ = { name : string; type_ : TypeExpr.t }
107
108 type field = Method of method_ | Inherit of TypeExpr.t
109
110 type t = { fields : field list; open_ : bool }
111 end
112
113 module Package : sig
114 type substitution = Cfrag.type_ * TypeExpr.t
115
116 type t = { path : Cpath.module_type; substitutions : substitution list }
117 end
118
119 type label = Odoc_model.Lang.TypeExpr.label
120
121 type t =
122 | Var of string * string option
123 | Any
124 | Alias of t * string
125 | Arrow of label option * t * t * string list * string list
126 | Tuple of (string option * t) list
127 | Unboxed_tuple of (string option * t) list
128 | Constr of Cpath.type_ * t list
129 | Polymorphic_variant of TypeExpr.Polymorphic_variant.t
130 | Object of TypeExpr.Object.t
131 | Class of Cpath.class_type * t list
132 | Poly of (string * string option) list * t
133 | Quote of t
134 | Splice of t
135 | Package of TypeExpr.Package.t
136end =
137 TypeExpr
138
139and Extension : sig
140 module Constructor : sig
141 type t = {
142 name : string;
143 source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option;
144 doc : CComment.docs;
145 args : TypeDecl.Constructor.argument;
146 res : TypeExpr.t option;
147 }
148 end
149
150 type t = {
151 type_path : Cpath.type_;
152 doc : CComment.docs;
153 type_params : TypeDecl.param list;
154 private_ : bool;
155 constructors : Constructor.t list;
156 }
157end =
158 Extension
159
160and Exception : sig
161 type t = {
162 source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option;
163 source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option;
164 doc : CComment.docs;
165 args : TypeDecl.Constructor.argument;
166 res : TypeExpr.t option;
167 }
168end =
169 Exception
170
171and FunctorParameter : sig
172 type parameter = { id : Ident.module_; expr : ModuleType.expr }
173
174 type t = Named of parameter | Unit
175end =
176 FunctorParameter
177
178and ModuleType : sig
179 type substitution =
180 | ModuleEq of Cfrag.module_ * Module.decl
181 | ModuleSubst of Cfrag.module_ * Cpath.module_
182 | ModuleTypeEq of Cfrag.module_type * ModuleType.expr
183 | ModuleTypeSubst of Cfrag.module_type * ModuleType.expr
184 | TypeEq of Cfrag.type_ * TypeDecl.Equation.t
185 | TypeSubst of Cfrag.type_ * TypeDecl.Equation.t
186
187 type type_of_desc =
188 | ModPath of Cpath.module_
189 | StructInclude of Cpath.module_
190
191 type simple_expansion =
192 | Signature of Signature.t
193 | Functor of FunctorParameter.t * simple_expansion
194
195 type typeof_t = {
196 t_desc : type_of_desc;
197 t_original_path : Cpath.module_;
198 t_expansion : simple_expansion option;
199 }
200
201 module U : sig
202 type expr =
203 | Path of Cpath.module_type
204 | Signature of Signature.t
205 | With of substitution list * expr
206 | TypeOf of type_of_desc * Cpath.module_
207 | Strengthen of expr * Cpath.module_ * bool
208 end
209
210 type path_t = {
211 p_expansion : simple_expansion option;
212 p_path : Cpath.module_type;
213 }
214
215 type with_t = {
216 w_substitutions : substitution list;
217 w_expansion : simple_expansion option;
218 w_expr : U.expr;
219 }
220
221 type strengthen_t = {
222 s_expansion : simple_expansion option;
223 s_expr : U.expr;
224 s_path : Cpath.module_;
225 s_aliasable : bool
226 }
227
228 type expr =
229 | Path of path_t
230 | Signature of Signature.t
231 | With of with_t
232 | Functor of FunctorParameter.t * expr
233 | TypeOf of typeof_t
234 | Strengthen of strengthen_t
235
236 type t = {
237 source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option;
238 source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option;
239 doc : CComment.docs;
240 canonical : Odoc_model.Paths.Path.ModuleType.t option;
241 expr : expr option;
242 }
243end =
244 ModuleType
245
246and TypeDecl : sig
247 module Field : sig
248 type t = {
249 name : string;
250 doc : CComment.docs;
251 mutable_ : bool;
252 type_ : TypeExpr.t;
253 }
254 end
255
256 module UnboxedField : sig
257 type t = {
258 name : string;
259 doc : CComment.docs;
260 mutable_ : bool;
261 type_ : TypeExpr.t;
262 }
263 end
264
265 module Constructor : sig
266 type argument = Tuple of TypeExpr.t list | Record of Field.t list
267
268 type t = {
269 name : string;
270 doc : CComment.docs;
271 args : argument;
272 res : TypeExpr.t option;
273 }
274 end
275
276 module Representation : sig
277 type t =
278 | Variant of Constructor.t list
279 | Record of Field.t list
280 | Record_unboxed_product of UnboxedField.t list
281 | Extensible
282 end
283
284 type param = Odoc_model.Lang.TypeDecl.param
285
286 module Equation : sig
287 type t = {
288 params : param list;
289 private_ : bool;
290 manifest : TypeExpr.t option;
291 constraints : (TypeExpr.t * TypeExpr.t) list;
292 }
293 end
294
295 type t = {
296 source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option;
297 source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option;
298 doc : CComment.docs;
299 canonical : Odoc_model.Paths.Path.Type.t option;
300 equation : Equation.t;
301 representation : Representation.t option;
302 }
303end =
304 TypeDecl
305
306and Value : sig
307 type value = Odoc_model.Lang.Value.value
308
309 type t = {
310 source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option;
311 source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option;
312 doc : CComment.docs;
313 type_ : TypeExpr.t;
314 value : value;
315 modalities : string list;
316 }
317end =
318 Value
319
320and Signature : sig
321 type recursive = Odoc_model.Lang.Signature.recursive
322
323 type item =
324 | Module of Ident.module_ * recursive * Module.t Delayed.t
325 | ModuleSubstitution of Ident.module_ * ModuleSubstitution.t
326 | ModuleType of Ident.module_type * ModuleType.t Delayed.t
327 | ModuleTypeSubstitution of Ident.module_type * ModuleTypeSubstitution.t
328 | Type of Ident.type_ * recursive * TypeDecl.t Delayed.t
329 | TypeSubstitution of Ident.type_ * TypeDecl.t
330 | Exception of Ident.exception_ * Exception.t
331 | TypExt of Extension.t
332 | Value of Ident.value * Value.t Delayed.t
333 | Class of Ident.type_ * recursive * Class.t
334 | ClassType of Ident.type_ * recursive * ClassType.t
335 | Include of Include.t
336 | Open of Open.t
337 | Comment of CComment.docs_or_stop
338
339 (* When doing destructive substitution we keep track of the items that have been removed,
340 and the path they've been substituted with *)
341 type removed_item =
342 | RModule of Odoc_model.Names.ModuleName.t * Cpath.module_
343 | RType of Odoc_model.Names.TypeName.t * TypeExpr.t * TypeDecl.Equation.t
344 (** [RType (_, texpr, eq)], [eq.manifest = Some texpr] *)
345 | RModuleType of Odoc_model.Names.ModuleTypeName.t * ModuleType.expr
346
347 type t = {
348 items : item list;
349 compiled : bool;
350 removed : removed_item list;
351 doc : CComment.docs;
352 }
353end =
354 Signature
355
356and Open : sig
357 type t = { expansion : Signature.t; doc : CComment.docs }
358end =
359 Open
360
361and Include : sig
362 type decl = Alias of Cpath.module_ | ModuleType of ModuleType.U.expr
363
364 type t = {
365 parent : Odoc_model.Paths.Identifier.Signature.t;
366 strengthened : Cpath.module_ option;
367 doc : CComment.docs;
368 status : [ `Default | `Inline | `Closed | `Open ];
369 shadowed : Odoc_model.Lang.Include.shadowed;
370 expansion_ : Signature.t;
371 expanded : bool;
372 decl : decl;
373 loc : Odoc_model.Location_.span;
374 }
375end =
376 Include
377
378and Class : sig
379 type decl =
380 | ClassType of ClassType.expr
381 | Arrow of TypeExpr.label option * TypeExpr.t * decl
382
383 type t = {
384 source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option;
385 source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option;
386 doc : CComment.docs;
387 virtual_ : bool;
388 params : TypeDecl.param list;
389 type_ : decl;
390 expansion : ClassSignature.t option;
391 }
392end =
393 Class
394
395and ClassType : sig
396 type expr =
397 | Constr of Cpath.class_type * TypeExpr.t list
398 | Signature of ClassSignature.t
399
400 type t = {
401 source_loc : Odoc_model.Paths.Identifier.SourceLocation.t option;
402 source_loc_jane : Odoc_model.Lang.Source_loc_jane.t option;
403 doc : CComment.docs;
404 virtual_ : bool;
405 params : TypeDecl.param list;
406 expr : expr;
407 expansion : ClassSignature.t option;
408 }
409end =
410 ClassType
411
412and ClassSignature : sig
413 module Constraint : sig
414 type t = { left : TypeExpr.t; right : TypeExpr.t; doc : CComment.docs }
415 end
416
417 module Inherit : sig
418 type t = { expr : ClassType.expr; doc : CComment.docs }
419 end
420
421 type item =
422 | Method of Ident.method_ * Method.t
423 | InstanceVariable of Ident.instance_variable * InstanceVariable.t
424 | Constraint of Constraint.t
425 | Inherit of Inherit.t
426 | Comment of CComment.docs_or_stop
427
428 type t = { self : TypeExpr.t option; items : item list; doc : CComment.docs }
429end =
430 ClassSignature
431
432and Method : sig
433 type t = {
434 doc : CComment.docs;
435 private_ : bool;
436 virtual_ : bool;
437 type_ : TypeExpr.t;
438 }
439end =
440 Method
441
442and InstanceVariable : sig
443 type t = {
444 doc : CComment.docs;
445 mutable_ : bool;
446 virtual_ : bool;
447 type_ : TypeExpr.t;
448 }
449end =
450 InstanceVariable
451
452and Substitution : sig
453 type subst_module =
454 [ `Prefixed of Cpath.module_ * Cpath.Resolved.module_
455 | `Substituted
456 | `Renamed of Ident.module_ ]
457
458 type subst_module_type =
459 [ `Prefixed of Cpath.module_type * Cpath.Resolved.module_type
460 | `Renamed of Ident.module_type ]
461
462 type subst_type =
463 [ `Prefixed of Cpath.type_ * Cpath.Resolved.type_ | `Renamed of Ident.type_ ]
464
465 type subst_class_type =
466 [ `Prefixed of Cpath.class_type * Cpath.Resolved.class_type
467 | `Renamed of Ident.type_ ]
468
469 type t = {
470 module_ : subst_module ModuleMap.t;
471 module_type : subst_module_type ModuleTypeMap.t;
472 type_ : subst_type TypeMap.t;
473 class_type : subst_class_type TypeMap.t;
474 type_replacement : (TypeExpr.t * TypeDecl.Equation.t) TypeMap.t;
475 module_type_replacement : ModuleType.expr ModuleTypeMap.t;
476 path_invalidating_modules : Ident.module_ list;
477 unresolve_opaque_paths : bool;
478 }
479end =
480 Substitution
481
482and CComment : sig
483 type block_element =
484 [ Odoc_model.Comment.nestable_block_element
485 | `Heading of Label.t
486 | `Tag of Odoc_model.Comment.tag
487 | `Media of
488 Odoc_model.Comment.media_href * Odoc_model.Comment.media * string ]
489
490 type docs = {
491 elements : block_element Odoc_model.Comment.with_location list;
492 warnings_tag : string option;
493 }
494
495 type docs_or_stop = [ `Docs of docs | `Stop ]
496end =
497 CComment
498
499and Label : sig
500 type t = {
501 attrs : Odoc_model.Comment.heading_attrs;
502 label : Ident.label;
503 text : Odoc_model.Comment.paragraph;
504 location : Odoc_model.Location_.span;
505 }
506end =
507 Label
508
509module Element = struct
510 open Odoc_model.Paths
511
512 type module_ = [ `Module of Identifier.Path.Module.t * Module.t Delayed.t ]
513
514 type module_type = [ `ModuleType of Identifier.ModuleType.t * ModuleType.t ]
515
516 type datatype = [ `Type of Identifier.Type.t * TypeDecl.t ]
517
518 type value = [ `Value of Identifier.Value.t * Value.t ]
519
520 type label = [ `Label of Identifier.Label.t * Label.t ]
521
522 type class_ = [ `Class of Identifier.Class.t * Class.t ]
523
524 type class_type = [ `ClassType of Identifier.ClassType.t * ClassType.t ]
525
526 type type_ = [ datatype | class_ | class_type ]
527
528 type signature = [ module_ | module_type ]
529
530 type constructor =
531 [ `Constructor of Identifier.Constructor.t * TypeDecl.Constructor.t ]
532
533 type exception_ = [ `Exception of Identifier.Exception.t * Exception.t ]
534
535 type extension =
536 [ `Extension of
537 Identifier.Extension.t * Extension.Constructor.t * Extension.t ]
538
539 type extension_decl =
540 [ `ExtensionDecl of Identifier.Extension.t * Extension.Constructor.t ]
541
542 type field = [ `Field of Identifier.Field.t * TypeDecl.Field.t ]
543
544 type unboxed_field =
545 [ `UnboxedField of Identifier.UnboxedField.t * TypeDecl.UnboxedField.t ]
546
547 (* No component for pages yet *)
548 type page = [ `Page of Identifier.Page.t * Odoc_model.Lang.Page.t ]
549
550 type label_parent = [ signature | type_ | page ]
551
552 type fragment_type_parent = [ signature | datatype ]
553
554 type any =
555 [ signature
556 | value
557 | datatype
558 | label
559 | class_
560 | class_type
561 | constructor
562 | exception_
563 | extension
564 | extension_decl
565 | field
566 | unboxed_field
567 | page ]
568
569 let identifier : [< any ] -> Odoc_model.Paths.Identifier.t =
570 let open Odoc_model.Paths.Identifier in
571 function
572 | `Module (id, _) -> (id :> t)
573 | `ModuleType (id, _) -> (id :> t)
574 | `Type (id, _) -> (id :> t)
575 | `ClassType (id, _) -> (id :> t)
576 | `Class (id, _) -> (id :> t)
577 | `Value (id, _) -> (id :> t)
578 | `Label (id, _) -> (id :> t)
579 | `Constructor (id, _) -> (id :> t)
580 | `Exception (id, _) -> (id :> t)
581 | `Field (id, _) -> (id :> t)
582 | `UnboxedField (id, _) -> (id :> t)
583 | `Extension (id, _, _) -> (id :> t)
584 | `ExtensionDecl (id, _) -> (id :> t)
585 | `Page (id, _) -> (id :> t)
586end
587
588module Fmt = struct
589 type config = {
590 short_paths : bool;
591 show_canonical : bool;
592 show_removed : bool;
593 show_expansions : bool;
594 show_include_expansions : bool;
595 }
596
597 let default =
598 {
599 short_paths = false;
600 show_canonical = true;
601 show_removed = true;
602 show_expansions = true;
603 show_include_expansions = true;
604 }
605
606 type id = Odoc_model.Paths.Identifier.t
607 type path = Odoc_model.Paths.Path.t
608 type rpath = Odoc_model.Paths.Path.Resolved.t
609 open Odoc_model.Names
610 open Odoc_model.Paths
611
612 let fpf = Format.fprintf
613
614 let fpp_opt (c : config) fmt pp_a ppf = function
615 | Some t -> fpf ppf fmt (pp_a c) t
616 | None -> ()
617
618 let fpp_list fmt_sep fmt_outer pp_a ppf t =
619 let pp_sep ppf () = fpf ppf fmt_sep in
620 match t with
621 | [] -> ()
622 | t -> fpf ppf fmt_outer (Format.pp_print_list ~pp_sep pp_a) t
623
624 (* Three helper functions to help with paths. Generally paths
625 have constructors of the form [`Hidden(p1)] or
626 [`Alias(p1,p2)]. When printing these paths, if we're printing a
627 short path we often want to just ignore the constructor and print
628 one of the inner paths, [p1] or [p2]. These functions do that. If
629 [short_paths] is set in the config, we skip to one of the inner
630 paths - in [wrap] there's no choice, but in [wrap2] we pick [p1]
631 and in [wrap2r] we pick [p2]. If [short_paths] is not set, we
632 print a string representing the constructor, and one or both paths
633 with brackets. *)
634 let wrap : type a.
635 config ->
636 string ->
637 (config -> Format.formatter -> a -> unit) ->
638 Format.formatter ->
639 a ->
640 unit =
641 fun c txt fn ppf x ->
642 if c.short_paths then Format.fprintf ppf "%a" (fn c) x
643 else Format.fprintf ppf "%s(%a)" txt (fn c) x
644
645 let wrap2 : type a b.
646 config ->
647 string ->
648 (config -> Format.formatter -> a -> unit) ->
649 (config -> Format.formatter -> b -> unit) ->
650 Format.formatter ->
651 a ->
652 b ->
653 unit =
654 fun c txt fn1 fn2 ppf x y ->
655 if c.short_paths then Format.fprintf ppf "%a" (fn1 c) x
656 else Format.fprintf ppf "%s(%a,%a)" txt (fn1 c) x (fn2 c) y
657
658 let wrap2r : type a b.
659 config ->
660 string ->
661 (config -> Format.formatter -> a -> unit) ->
662 (config -> Format.formatter -> b -> unit) ->
663 Format.formatter ->
664 a ->
665 b ->
666 unit =
667 fun c txt fn1 fn2 ppf x y ->
668 if c.short_paths then Format.fprintf ppf "%a" (fn2 c) y
669 else Format.fprintf ppf "%s(%a,%a)" txt (fn1 c) x (fn2 c) y
670
671 let str : config -> Format.formatter -> string -> unit =
672 fun _ ppf s -> Format.fprintf ppf "%s" s
673
674 let bool : config -> Format.formatter -> bool -> unit =
675 fun _ ppf b -> Format.fprintf ppf "%b" b
676
677 let ident_fmt : config -> Format.formatter -> [< Ident.any ] -> unit =
678 fun c ppf i ->
679 if c.short_paths then Ident.short_fmt ppf i else Ident.fmt ppf i
680
681 let rec model_identifier c ppf (p : id) =
682 match p.iv with
683 | `Root (_, unit_name) ->
684 wrap c "root" (fun _ -> ModuleName.fmt) ppf unit_name
685 | `Module (parent, name) ->
686 Format.fprintf ppf "%a.%s" (model_identifier c)
687 (parent :> id)
688 (ModuleName.to_string name)
689 | `ModuleType (parent, name) ->
690 Format.fprintf ppf "%a.%s" (model_identifier c)
691 (parent :> id)
692 (ModuleTypeName.to_string name)
693 | `Type (parent, name) ->
694 Format.fprintf ppf "%a.%s" (model_identifier c)
695 (parent :> id)
696 (TypeName.to_string name)
697 | `Parameter (parent, name) ->
698 Format.fprintf ppf "(param %a %s)" (model_identifier c)
699 (parent :> id)
700 (ModuleName.to_string name)
701 | `Result parent ->
702 if c.short_paths then model_identifier c ppf (parent :> id)
703 else Format.fprintf ppf "%a.result" (model_identifier c) (parent :> id)
704 | `Constructor (ty, x) ->
705 Format.fprintf ppf "%a.%s" (model_identifier c)
706 (ty :> id)
707 (ConstructorName.to_string x)
708 | `Value (parent, name) ->
709 Format.fprintf ppf "%a.%s" (model_identifier c)
710 (parent :> id)
711 (ValueName.to_string name)
712 | `Class (sg, name) ->
713 Format.fprintf ppf "%a.%s" (model_identifier c)
714 (sg :> id)
715 (TypeName.to_string name)
716 | `ClassType (sg, name) ->
717 Format.fprintf ppf "%a.%s" (model_identifier c)
718 (sg :> id)
719 (TypeName.to_string name)
720 | `InstanceVariable (sg, name) ->
721 Format.fprintf ppf "%a.%s" (model_identifier c)
722 (sg :> id)
723 (InstanceVariableName.to_string name)
724 | `Method (sg, name) ->
725 Format.fprintf ppf "%a.%s" (model_identifier c)
726 (sg :> id)
727 (MethodName.to_string name)
728 | `Label (parent, name) ->
729 Format.fprintf ppf "%a.%s" (model_identifier c)
730 (parent :> id)
731 (LabelName.to_string name)
732 | `Field (ty, name) ->
733 Format.fprintf ppf "%a.%s" (model_identifier c)
734 (ty :> id)
735 (FieldName.to_string name)
736 | `UnboxedField (ty, name) ->
737 Format.fprintf ppf "%a.%s" (model_identifier c)
738 (ty :> id)
739 (UnboxedFieldName.to_string name)
740 | `Exception (p, name) ->
741 Format.fprintf ppf "%a.%s" (model_identifier c)
742 (p :> id)
743 (ExceptionName.to_string name)
744 | `Extension (p, name) ->
745 Format.fprintf ppf "%a.%s" (model_identifier c)
746 (p :> id)
747 (ExtensionName.to_string name)
748 | `ExtensionDecl (p, _, name) ->
749 Format.fprintf ppf "%a.%s" (model_identifier c)
750 (p :> id)
751 (ExtensionName.to_string name)
752 | `Page (_, name) | `LeafPage (_, name) ->
753 Format.fprintf ppf "%s" (PageName.to_string name)
754 | `SourcePage (p, name) ->
755 Format.fprintf ppf "%a/%s" (model_identifier c) (p :> id) name
756 | `SourceLocation (p, def) ->
757 Format.fprintf ppf "%a#%s" (model_identifier c)
758 (p :> id)
759 (DefName.to_string def)
760 | `SourceLocationInternal (p, def) ->
761 Format.fprintf ppf "%a#%s" (model_identifier c)
762 (p :> id)
763 (LocalName.to_string def)
764 | `SourceLocationMod p ->
765 Format.fprintf ppf "%a#" (model_identifier c) (p :> id)
766 | `AssetFile (p, name) ->
767 Format.fprintf ppf "%a/%s" (model_identifier c)
768 (p :> id)
769 (AssetName.to_string name)
770
771 let rec signature : config -> Format.formatter -> Signature.t -> unit =
772 fun c ppf sg ->
773 let open Signature in
774 let ident_fmt = if c.short_paths then Ident.short_fmt else Ident.fmt in
775 let sig_item ppf = function
776 | Module (id, _, m) ->
777 Format.fprintf ppf "@[<hov 2>module %a %a@]" ident_fmt id (module_ c)
778 (Delayed.get m)
779 | ModuleSubstitution (id, m) ->
780 Format.fprintf ppf "@[<v 2>module %a := %a@]" ident_fmt id
781 (module_path c) m.ModuleSubstitution.manifest
782 | ModuleType (id, mt) ->
783 Format.fprintf ppf "@[<hov 2>module type %a %a@]" ident_fmt id
784 (module_type c) (Delayed.get mt)
785 | ModuleTypeSubstitution (id, mts) ->
786 Format.fprintf ppf "@[<v 2>module type %a := %a@]" ident_fmt id
787 (module_type_expr c) mts.ModuleTypeSubstitution.manifest
788 | Type (id, _, t) ->
789 Format.fprintf ppf "@[<v 2>type %a%a@]" ident_fmt id (type_decl c)
790 (Delayed.get t)
791 | TypeSubstitution (id, t) ->
792 Format.fprintf ppf "@[<v 2>type %a :=%a@]" ident_fmt id (type_decl c)
793 t
794 | Exception (id, e) ->
795 Format.fprintf ppf "@[<v 2>exception %a %a@]" ident_fmt id
796 (exception_ c) e
797 | TypExt e ->
798 Format.fprintf ppf "@[<v 2>type_extension %a@]" (extension c) e
799 | Value (id, v) ->
800 Format.fprintf ppf "@[<v 2>val %a %a@]" ident_fmt id (value c)
801 (Delayed.get v)
802 | Class (id, _, cls) ->
803 Format.fprintf ppf "@[<v 2>class %a %a@]" ident_fmt id (class_ c) cls
804 | ClassType (id, _, cty) ->
805 Format.fprintf ppf "@[<v 2>class type %a %a@]" ident_fmt id
806 (class_type c) cty
807 | Include i -> Format.fprintf ppf "@[<hov 2>include %a@]" (include_ c) i
808 | Open o -> Format.fprintf ppf "open [ %a ]" (signature c) o.expansion
809 | Comment _c -> ()
810 in
811 let rec inner ppf = function
812 | [ x ] -> sig_item ppf x
813 | x :: xs -> Format.fprintf ppf "%a@ %a" sig_item x inner xs
814 | [] -> ()
815 in
816 let removed_fmt ppf removed =
817 match (c.show_removed, removed) with
818 | false, _ | _, [] -> ()
819 | true, items ->
820 Format.fprintf ppf "@ (removed=%a)" (removed_item_list c) items
821 in
822 Format.fprintf ppf "%a%a" inner sg.items removed_fmt sg.removed
823
824 and option : type a.
825 config ->
826 (config -> Format.formatter -> a -> unit) ->
827 Format.formatter ->
828 a option ->
829 unit =
830 fun c pp ppf x ->
831 match x with
832 | Some x -> Format.fprintf ppf "Some(%a)" (pp c) x
833 | None -> Format.fprintf ppf "None"
834
835 and class_signature c ppf sg =
836 let open ClassSignature in
837 Format.fprintf ppf "@[<v>self=%a@," (option c type_expr) sg.self;
838 List.iter
839 (function
840 | Method (id, m) ->
841 Format.fprintf ppf "@[<v 2>method %a : %a@]@," Ident.fmt id
842 (method_ c) m
843 | InstanceVariable (id, i) ->
844 Format.fprintf ppf "@[<v 2>instance variable %a : %a@]@," Ident.fmt
845 id (instance_variable c) i
846 | Constraint cst ->
847 Format.fprintf ppf "@[<v 2>constraint %a = %a@]@," (type_expr c)
848 cst.Constraint.left (type_expr c) cst.right
849 | Inherit i ->
850 Format.fprintf ppf "@[<v 2>inherit %a" (class_type_expr c)
851 i.Inherit.expr
852 | Comment _ -> ())
853 sg.items
854
855 and method_ c ppf m =
856 let open Method in
857 Format.fprintf ppf "%s%s%a"
858 (if m.private_ then "private " else "")
859 (if m.virtual_ then "virtual " else "")
860 (type_expr c) m.type_
861
862 and instance_variable c ppf i =
863 let open InstanceVariable in
864 Format.fprintf ppf "%s%s%a"
865 (if i.mutable_ then "mutable " else "")
866 (if i.virtual_ then "virtual " else "")
867 (type_expr c) i.type_
868
869 and list c pp ppf ls =
870 match ls with
871 | x :: y :: rest ->
872 Format.fprintf ppf "%a, %a" (pp c) x (list c pp) (y :: rest)
873 | [ x ] -> Format.fprintf ppf "%a" (pp c) x
874 | [] -> ()
875
876 and class_type_expr c ppf cty =
877 let open ClassType in
878 match cty with
879 | Constr (p, ts) ->
880 Format.fprintf ppf "constr(%a,%a)" (class_type_path c) p
881 (list c type_expr) ts
882 | Signature sg -> Format.fprintf ppf "(%a)" (class_signature c) sg
883
884 and removed_item c ppf r =
885 let open Signature in
886 match r with
887 | RModule (id, path) ->
888 Format.fprintf ppf "module %a (%a)" ModuleName.fmt id (module_path c)
889 path
890 | RType (id, texpr, eq) ->
891 Format.fprintf ppf "type %a %a = (%a)" type_params eq.params
892 TypeName.fmt id (type_expr c) texpr
893 | RModuleType (id, mty) ->
894 Format.fprintf ppf "module type %a = %a" ModuleTypeName.fmt id
895 (module_type_expr c) mty
896
897 and removed_item_list c ppf r =
898 match r with
899 | [] -> ()
900 | [ x ] -> Format.fprintf ppf "%a" (removed_item c) x
901 | x :: ys ->
902 Format.fprintf ppf "%a;%a" (removed_item c) x (removed_item_list c) ys
903
904 and class_decl c ppf cls =
905 let open Class in
906 match cls with
907 | ClassType cty -> Format.fprintf ppf "%a" (class_type_expr c) cty
908 | Arrow (lbl, ty, decl) ->
909 Format.fprintf ppf "%a%a -> %a" type_expr_label lbl (type_expr c) ty
910 (class_decl c) decl
911
912 and class_ c ppf cls = Format.fprintf ppf "%a" (class_decl c) cls.type_
913
914 and class_type _c ppf _ = Format.fprintf ppf "<todo>"
915
916 and include_ c ppf i =
917 Format.fprintf ppf "%a@ %a" (include_decl c) i.decl
918 (simple_expansion c true)
919 (ModuleType.Signature i.expansion_ : ModuleType.simple_expansion)
920
921 and include_decl c ppf =
922 let open Include in
923 function
924 | Alias p -> Format.fprintf ppf "%a" (module_path c) p
925 | ModuleType mt -> Format.fprintf ppf "%a" (u_module_type_expr c) mt
926
927 and value c ppf v =
928 let open Value in
929 Format.fprintf ppf ": %a" (type_expr c) v.type_
930
931 and module_decl c ppf d =
932 let open Module in
933 match d with
934 | Alias (p, Some e) ->
935 Format.fprintf ppf "=@ %a@ %a" (module_path c) p
936 (simple_expansion c false) e
937 | Alias (p, None) -> Format.fprintf ppf "=@ %a" (module_path c) p
938 | ModuleType mt ->
939 Format.fprintf ppf ": %a%a" (module_type_expr c) mt
940 (module_type_expansion c) mt
941
942 and module_ c ppf m =
943 let fmt_canonical ppf popt =
944 if c.show_canonical then
945 Format.fprintf ppf "@ (canonical=%a)" (option c model_path) popt
946 else ()
947 in
948 Format.fprintf ppf "%a%a" (module_decl c) m.type_ fmt_canonical
949 (m.canonical :> path option)
950
951 and simple_expansion c is_include ppf (m : ModuleType.simple_expansion) =
952 if c.show_expansions || (is_include && c.show_include_expansions) then
953 match m with
954 | ModuleType.Signature sg ->
955 Format.fprintf ppf "@[<hv 2>(sig :@ %a@;<1 -1>end@])" (signature c) sg
956 | Functor (arg, sg) ->
957 Format.fprintf ppf "(functor: (%a) -> %a)" (functor_parameter c) arg
958 (simple_expansion c is_include)
959 sg
960 else ()
961
962 and module_type c ppf mt =
963 match mt.expr with
964 | Some x ->
965 Format.fprintf ppf "= %a%a" (module_type_expr c) x
966 (module_type_expansion c) x
967 | None -> ()
968
969 and module_type_type_of_desc c ppf t =
970 match t with
971 | ModuleType.ModPath p ->
972 Format.fprintf ppf "module type of %a" (module_path c) p
973 | StructInclude p ->
974 Format.fprintf ppf "module type of struct include %a end"
975 (module_path c) p
976
977 and u_module_type_expr c ppf mt =
978 let open ModuleType.U in
979 match mt with
980 | Path p -> module_type_path c ppf p
981 | Signature sg -> Format.fprintf ppf "sig@,@[<v 2>%a@]end" (signature c) sg
982 | With (subs, e) ->
983 Format.fprintf ppf "%a with [%a]" (u_module_type_expr c) e
984 (substitution_list c) subs
985 | TypeOf (t_desc, _) -> module_type_type_of_desc c ppf t_desc
986 | Strengthen (e, p, _) ->
987 Format.fprintf ppf "%a with %a" (u_module_type_expr c) e (module_path c) p
988
989 and module_type_expr c ppf mt =
990 let open ModuleType in
991 match mt with
992 | Path { p_path; _ } -> module_type_path c ppf p_path
993 | Signature sg ->
994 Format.fprintf ppf "@,@[<hv 2>sig@ %a@;<1 -2>end@]" (signature c) sg
995 | With { w_substitutions = subs; w_expr; _ } ->
996 Format.fprintf ppf "%a with @[<hov 2>%a@]" (u_module_type_expr c) w_expr
997 (substitution_list c) subs
998 | Functor (arg, res) ->
999 Format.fprintf ppf "(%a) -> %a" (functor_parameter c) arg
1000 (module_type_expr c) res
1001 | TypeOf { t_desc = ModPath p; _ } ->
1002 Format.fprintf ppf "module type of %a" (module_path c) p
1003 | TypeOf { t_desc = StructInclude p; _ } ->
1004 Format.fprintf ppf "module type of struct include %a end"
1005 (module_path c) p
1006 | Strengthen { s_expr; s_path; _ } ->
1007 Format.fprintf ppf "%a with %a" (u_module_type_expr c) s_expr
1008 (module_path c) s_path
1009
1010 and module_type_expansion c ppf mt =
1011 let open ModuleType in
1012 match mt with
1013 | Signature _ -> ()
1014 | Path { p_expansion = Some e; _ }
1015 | With { w_expansion = Some e; _ }
1016 | TypeOf { t_expansion = Some e; _ } ->
1017 Format.fprintf ppf "@ %a" (simple_expansion c false) e
1018 | _ -> ()
1019
1020 and functor_parameter c ppf x =
1021 let open FunctorParameter in
1022 match x with
1023 | Unit -> ()
1024 | Named x -> Format.fprintf ppf "%a" (functor_parameter_parameter c) x
1025
1026 and functor_parameter_parameter c ppf x =
1027 Format.fprintf ppf "%a : %a" Ident.fmt x.FunctorParameter.id
1028 (module_type_expr c) x.FunctorParameter.expr
1029
1030 and type_decl c ppf t =
1031 let open TypeDecl in
1032 match t.representation with
1033 | Some repr ->
1034 Format.fprintf ppf "%a = %a"
1035 (fpp_opt c " : %a" type_expr)
1036 t.equation.Equation.manifest (type_decl_repr c) repr
1037 | None -> (fpp_opt c " = %a" type_expr) ppf t.equation.Equation.manifest
1038
1039 and type_decl_repr c ppf =
1040 let open TypeDecl.Representation in
1041 function
1042 | Variant cs -> fpp_list " | " "%a" (type_decl_constructor c) ppf cs
1043 | Record fs -> type_decl_fields c ppf fs
1044 | Record_unboxed_product fs -> type_decl_unboxed_fields c ppf fs
1045 | Extensible -> Format.fprintf ppf ".."
1046
1047 and type_decl_constructor c ppf t =
1048 let open TypeDecl.Constructor in
1049 match t.res with
1050 | Some res ->
1051 fpf ppf "%s : %a -> %a" t.name
1052 (type_decl_constructor_arg c)
1053 t.args (type_expr c) res
1054 | None -> fpf ppf "%s of %a" t.name (type_decl_constructor_arg c) t.args
1055
1056 and type_decl_constructor_arg c ppf =
1057 let open TypeDecl.Constructor in
1058 function
1059 | Tuple ts -> type_constructor_params c ppf ts
1060 | Record fs -> type_decl_fields c ppf fs
1061
1062 and type_decl_field c ppf t =
1063 let open TypeDecl.Field in
1064 let mutable_ = if t.mutable_ then "mutable " else "" in
1065 fpf ppf "%s%s : %a" mutable_ t.name (type_expr c) t.type_
1066
1067 and type_decl_unboxed_field c ppf t =
1068 let open TypeDecl.UnboxedField in
1069 let mutable_ = if t.mutable_ then "mutable " else "" in
1070 fpf ppf "%s%s : %a" mutable_ t.name (type_expr c) t.type_
1071
1072 and type_decl_fields c ppf fs =
1073 fpf ppf "{ %a }" (fpp_list "; " "%a" (type_decl_field c)) fs
1074
1075 and type_decl_unboxed_fields c ppf fs =
1076 fpf ppf "#{ %a }" (fpp_list "; " "%a" (type_decl_unboxed_field c)) fs
1077
1078 and type_constructor_params c ppf ts =
1079 fpp_list " * " "%a" (type_expr c) ppf ts
1080
1081 and type_param ppf t =
1082 let desc =
1083 match t.Odoc_model.Lang.TypeDecl.desc with Any -> "_" | Var (n, _) -> n
1084 and variance =
1085 match t.variance with
1086 | Some Pos -> "+"
1087 | Some Neg -> "-"
1088 | Some Bivariant -> "+-"
1089 | None -> ""
1090 and injectivity = if t.injectivity then "!" else "" in
1091 Format.fprintf ppf "%s%s%s" variance injectivity desc
1092
1093 and type_params ppf ts =
1094 let pp_sep ppf () = Format.fprintf ppf ", " in
1095 Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep type_param) ts
1096
1097 and type_equation_manifest c ppf t =
1098 match t.TypeDecl.Equation.manifest with
1099 | None -> ()
1100 | Some m -> Format.fprintf ppf " = %a" (type_expr c) m
1101
1102 and type_equation_params _c ppf t =
1103 match t.TypeDecl.Equation.params with
1104 | [] -> ()
1105 | ps -> Format.fprintf ppf "%a" type_params ps
1106
1107 and type_equation c ppf t =
1108 Format.fprintf ppf "(params %a)%a" (type_equation_params c) t
1109 (type_equation_manifest c) t
1110
1111 and exception_ _c _ppf _e = ()
1112
1113 and extension c ppf e =
1114 Format.fprintf ppf "%a" (type_path c) e.Extension.type_path
1115
1116 and substitution c ppf t =
1117 let open ModuleType in
1118 match t with
1119 | ModuleEq (frag, decl) ->
1120 Format.fprintf ppf "%a %a" (module_fragment c) frag (module_decl c) decl
1121 | ModuleSubst (frag, mpath) ->
1122 Format.fprintf ppf "%a := %a" (module_fragment c) frag (module_path c)
1123 mpath
1124 | ModuleTypeEq (frag, mty) ->
1125 Format.fprintf ppf "%a = %a" (module_type_fragment c) frag
1126 (module_type_expr c) mty
1127 | ModuleTypeSubst (frag, mty) ->
1128 Format.fprintf ppf "%a := %a" (module_type_fragment c) frag
1129 (module_type_expr c) mty
1130 | TypeEq (frag, decl) ->
1131 Format.fprintf ppf "%a%a" (type_fragment c) frag (type_equation c) decl
1132 | TypeSubst (frag, decl) ->
1133 Format.fprintf ppf "%a%a" (type_fragment c) frag (type_equation c) decl
1134
1135 and substitution_list c ppf l =
1136 match l with
1137 | [ sub ] -> Format.fprintf ppf "%a" (substitution c) sub
1138 | sub :: subs ->
1139 Format.fprintf ppf "%a; %a" (substitution c) sub (substitution_list c)
1140 subs
1141 | [] -> ()
1142
1143 and type_expr_label ppf l =
1144 match l with
1145 | Some (Odoc_model.Lang.TypeExpr.Label l) -> Format.fprintf ppf "%s:" l
1146 | Some (RawOptional o) -> Format.fprintf ppf "?(%s):" o
1147 | Some (Optional o) -> Format.fprintf ppf "?%s:" o
1148 | None -> ()
1149
1150 and type_expr_list c ppf l =
1151 match l with
1152 | [ t ] -> Format.fprintf ppf "%a" (type_expr c) t
1153 | t :: ts ->
1154 Format.fprintf ppf "%a * %a" (type_expr c) t (type_expr_list c) ts
1155 | [] -> ()
1156
1157 and type_labeled_tuple c ppf l =
1158 match l with
1159 | [ t ] -> with_label c ppf t
1160 | t :: ts ->
1161 Format.fprintf ppf "%a * %a" (with_label c) t (type_labeled_tuple c) ts
1162 | [] -> ()
1163
1164 and with_label c ppf (l, ty) =
1165 match l with
1166 | None -> type_expr c ppf ty
1167 | Some lbl -> Format.fprintf ppf "%s:%a" lbl (type_expr c) ty
1168
1169 and type_object _c ppf _o = Format.fprintf ppf "(object)"
1170
1171 and type_class c ppf (x, ys) =
1172 Format.fprintf ppf "(class %a %a)" (class_type_path c) x (type_expr_list c)
1173 ys
1174
1175 and type_package _c ppf _p = Format.fprintf ppf "(package)"
1176
1177 and type_expr_polymorphic_variant c ppf p =
1178 let open TypeExpr.Polymorphic_variant in
1179 let pp_element ppf = function
1180 | Type t -> type_expr c ppf t
1181 | Constructor cstr ->
1182 fpf ppf "`%s%a" cstr.Constructor.name
1183 (fpp_list " * " " of %a" (type_expr c))
1184 cstr.arguments
1185 in
1186 let pp_elements = fpp_list " | " "%a" pp_element in
1187 match p.kind with
1188 | Fixed -> fpf ppf "[ %a ]" pp_elements p.elements
1189 | Closed xs ->
1190 fpf ppf "[ %a > %a ]" pp_elements p.elements
1191 (fpp_list " " "%a" Format.pp_print_string)
1192 xs
1193 | Open -> fpf ppf "[> %a ]" pp_elements p.elements
1194
1195 and type_expr c ppf e =
1196 let open TypeExpr in
1197 match e with
1198 | Var (x, _) -> Format.fprintf ppf "%s" x
1199 | Any -> Format.fprintf ppf "_"
1200 | Alias (x, y) -> Format.fprintf ppf "(alias %a %s)" (type_expr c) x y
1201 | Arrow (l, t1, t2, _, _) ->
1202 Format.fprintf ppf "%a(%a) -> %a" type_expr_label l (type_expr c) t1
1203 (type_expr c) t2
1204 | Tuple ts -> Format.fprintf ppf "(%a)" (type_labeled_tuple c) ts
1205 | Unboxed_tuple ts -> Format.fprintf ppf "#(%a)" (type_labeled_tuple c) ts
1206 | Constr (p, args) -> (
1207 match args with
1208 | [] -> Format.fprintf ppf "%a" (type_path c) p
1209 | _ ->
1210 Format.fprintf ppf "[%a] %a" (type_expr_list c) args (type_path c) p
1211 )
1212 | Polymorphic_variant poly ->
1213 Format.fprintf ppf "(poly_var %a)"
1214 (type_expr_polymorphic_variant c)
1215 poly
1216 | Object x -> type_object c ppf x
1217 | Class (x, y) -> type_class c ppf (x, y)
1218 | Poly (_ss, _t) -> Format.fprintf ppf "(poly)"
1219 | Quote t -> Format.fprintf ppf "(quote %a)" (type_expr c) t
1220 | Splice t -> Format.fprintf ppf "(splice %a)" (type_expr c) t
1221 | Package x -> type_package c ppf x
1222
1223 and resolved_module_path :
1224 config -> Format.formatter -> Cpath.Resolved.module_ -> unit =
1225 fun c ppf p ->
1226 match p with
1227 | `Local ident -> ident_fmt c ppf ident
1228 | `Apply (p1, p2) ->
1229 Format.fprintf ppf "%a(%a)" (resolved_module_path c) p1
1230 (resolved_module_path c) p2
1231 | `Gpath p -> Format.fprintf ppf "%a" (model_resolved_path c) (p :> rpath)
1232 | `Substituted p -> wrap c "substituted" resolved_module_path ppf p
1233 | `Module (p, m) ->
1234 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1235 (ModuleName.to_string m)
1236 | `Alias (p1, p2, _) ->
1237 wrap2r c "alias" resolved_module_path module_path ppf p1 p2
1238 | `Subst (p1, p2) ->
1239 wrap2r c "subst" resolved_module_type_path resolved_module_path ppf p1
1240 p2
1241 | `Hidden p1 -> wrap c "hidden" resolved_module_path ppf p1
1242 | `Canonical (p1, p2) ->
1243 wrap2 c "canonical" resolved_module_path model_path ppf p1 (p2 :> path)
1244 | `OpaqueModule m -> wrap c "opaquemodule" resolved_module_path ppf m
1245
1246 and module_path : config -> Format.formatter -> Cpath.module_ -> unit =
1247 fun c ppf p ->
1248 match p with
1249 | `Resolved p -> wrap c "resolved" resolved_module_path ppf p
1250 | `Dot (p, n) ->
1251 Format.fprintf ppf "%a.%a" (module_path c) p ModuleName.fmt n
1252 | `Module (p, n) ->
1253 Format.fprintf ppf "%a.%a" (resolved_parent_path c) p ModuleName.fmt n
1254 | `Apply (p1, p2) ->
1255 Format.fprintf ppf "%a(%a)" (module_path c) p1 (module_path c) p2
1256 | `Identifier (id, b) ->
1257 wrap2 c "identifier" model_identifier bool ppf (id :> id) b
1258 | `Local (id, b) -> wrap2 c "local" ident_fmt bool ppf id b
1259 | `Substituted p -> wrap c "substituted" module_path ppf p
1260 | `Forward s -> wrap c "forward" str ppf s
1261 | `Root r -> wrap c "unresolvedroot" str ppf (ModuleName.to_string r)
1262
1263 and resolved_module_type_path :
1264 config -> Format.formatter -> Cpath.Resolved.module_type -> unit =
1265 fun c ppf p ->
1266 match p with
1267 | `Local id -> ident_fmt c ppf id
1268 | `Gpath p -> model_resolved_path c ppf (p :> rpath)
1269 | `Substituted x -> wrap c "substituted" resolved_module_type_path ppf x
1270 | `ModuleType (p, m) ->
1271 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1272 (ModuleTypeName.to_string m)
1273 | `CanonicalModuleType (m1, m2) ->
1274 wrap2 c "canonicalt" resolved_module_type_path model_path ppf m1
1275 (m2 :> path)
1276 | `OpaqueModuleType m ->
1277 wrap c "opaquemoduletype" resolved_module_type_path ppf m
1278 | `AliasModuleType (mt1, mt2) ->
1279 wrap2 c "aliasmoduletype" resolved_module_type_path
1280 resolved_module_type_path ppf mt1 mt2
1281 | `SubstT (mt1, mt2) ->
1282 wrap2 c "substt" resolved_module_type_path resolved_module_type_path ppf
1283 mt1 mt2
1284
1285 and module_type_path : config -> Format.formatter -> Cpath.module_type -> unit
1286 =
1287 fun c ppf m ->
1288 match m with
1289 | `Resolved p -> wrap c "r" resolved_module_type_path ppf p
1290 | `Identifier (id, b) ->
1291 wrap2 c "identifier" model_identifier bool ppf (id :> id) b
1292 | `Local (id, b) -> wrap2 c "local" ident_fmt bool ppf id b
1293 | `Substituted s -> wrap c "substituted" module_type_path ppf s
1294 | `DotMT (m, s) ->
1295 Format.fprintf ppf "%a.%a" (module_path c) m ModuleTypeName.fmt s
1296 | `ModuleType (m, n) ->
1297 Format.fprintf ppf "%a.%a" (resolved_parent_path c) m ModuleTypeName.fmt
1298 n
1299
1300 and resolved_type_path :
1301 config -> Format.formatter -> Cpath.Resolved.type_ -> unit =
1302 fun c ppf p ->
1303 match p with
1304 | `CoreType n -> Format.fprintf ppf "%s" (TypeName.to_string n)
1305 | `Local id -> ident_fmt c ppf id
1306 | `Gpath p -> model_resolved_path c ppf (p :> rpath)
1307 | `Substituted x -> wrap c "substituted" resolved_type_path ppf x
1308 | `CanonicalType (t1, t2) ->
1309 wrap2 c "canonicaltype" resolved_type_path model_path ppf t1
1310 (t2 :> path)
1311 | `Class (p, t) ->
1312 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1313 (TypeName.to_string t)
1314 | `ClassType (p, t) ->
1315 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1316 (TypeName.to_string t)
1317 | `Type (p, t) ->
1318 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1319 (TypeName.to_string t)
1320
1321 and resolved_value_path :
1322 config -> Format.formatter -> Cpath.Resolved.value -> unit =
1323 fun c ppf p ->
1324 match p with
1325 | `Value (p, t) ->
1326 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1327 (ValueName.to_string t)
1328 | `Gpath p -> Format.fprintf ppf "%a" (model_resolved_path c) (p :> rpath)
1329
1330 and resolved_parent_path :
1331 config -> Format.formatter -> Cpath.Resolved.parent -> unit =
1332 fun c ppf p ->
1333 match p with
1334 | `Module m -> resolved_module_path c ppf m
1335 | `ModuleType m ->
1336 if c.short_paths then resolved_module_type_path c ppf m
1337 else Format.fprintf ppf ">>%a<<" (resolved_module_type_path c) m
1338 | `FragmentRoot -> Format.fprintf ppf "FragmentRoot"
1339
1340 and type_path : config -> Format.formatter -> Cpath.type_ -> unit =
1341 fun c ppf p ->
1342 match p with
1343 | `Resolved r -> wrap c "resolved" resolved_type_path ppf r
1344 | `Identifier (id, b) ->
1345 wrap2 c "identifier" model_identifier bool ppf (id :> id) b
1346 | `Local (id, b) -> wrap2 c "local" ident_fmt bool ppf id b
1347 | `Substituted s -> wrap c "substituted" type_path ppf s
1348 | `DotT (m, s) ->
1349 Format.fprintf ppf "%a.%a" (module_path c) m TypeName.fmt s
1350 | `Class (p, t) ->
1351 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1352 (TypeName.to_string t)
1353 | `ClassType (p, t) ->
1354 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1355 (TypeName.to_string t)
1356 | `Type (p, t) ->
1357 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1358 (TypeName.to_string t)
1359
1360 and value_path : config -> Format.formatter -> Cpath.value -> unit =
1361 fun c ppf p ->
1362 match p with
1363 | `Resolved r -> wrap c "resolved" resolved_value_path ppf r
1364 | `DotV (m, s) ->
1365 Format.fprintf ppf "%a.%a" (module_path c) m ValueName.fmt s
1366 | `Value (p, t) ->
1367 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1368 (ValueName.to_string t)
1369 | `Identifier (id, b) ->
1370 wrap2 c "identifier" model_identifier bool ppf (id :> id) b
1371
1372 and resolved_class_type_path :
1373 config -> Format.formatter -> Cpath.Resolved.class_type -> unit =
1374 fun c ppf p ->
1375 match p with
1376 | `Local id -> Format.fprintf ppf "%a" Ident.fmt id
1377 | `Gpath p -> Format.fprintf ppf "%a" (model_resolved_path c) (p :> rpath)
1378 | `Substituted s -> wrap c "substituted" resolved_class_type_path ppf s
1379 | `Class (p, t) ->
1380 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1381 (TypeName.to_string t)
1382 | `ClassType (p, t) ->
1383 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1384 (TypeName.to_string t)
1385
1386 and class_type_path : config -> Format.formatter -> Cpath.class_type -> unit =
1387 fun c ppf p ->
1388 match p with
1389 | `Resolved r -> Format.fprintf ppf "%a" (resolved_class_type_path c) r
1390 | `Identifier (id, b) ->
1391 wrap2 c "identifier" model_identifier bool ppf (id :> id) b
1392 | `Local (id, b) -> wrap2 c "local" ident_fmt bool ppf id b
1393 | `Substituted s -> wrap c "substituted" class_type_path ppf s
1394 | `DotT (m, s) ->
1395 Format.fprintf ppf "%a.%a" (module_path c) m TypeName.fmt s
1396 | `Class (p, t) ->
1397 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1398 (TypeName.to_string t)
1399 | `ClassType (p, t) ->
1400 Format.fprintf ppf "%a.%s" (resolved_parent_path c) p
1401 (TypeName.to_string t)
1402
1403 and model_path : config -> Format.formatter -> path -> unit =
1404 fun c ppf (p : path) ->
1405 let dot p s =
1406 Format.fprintf ppf "%a.%s" (model_path c)
1407 (p : Odoc_model.Paths.Path.Module.t :> path)
1408 s
1409 in
1410
1411 match p with
1412 | `Resolved rp -> wrap c "resolved" model_resolved_path ppf rp
1413 | `Identifier (id, b) ->
1414 wrap2 c "identifier" model_identifier bool ppf (id :> id) b
1415 | `Root s -> wrap c "root" str ppf (ModuleName.to_string s)
1416 | `Forward s -> wrap c "forward" str ppf s
1417 | `Dot (p, s) -> dot p (ModuleName.to_string s)
1418 | `DotMT (p, s) -> dot p (ModuleTypeName.to_string s)
1419 | `DotT (p, s) -> dot p (TypeName.to_string s)
1420 | `DotV (p, s) -> dot p (ValueName.to_string s)
1421 | `Apply (func, arg) ->
1422 Format.fprintf ppf "%a(%a)" (model_path c)
1423 (func :> path)
1424 (model_path c)
1425 (arg :> path)
1426 | `Substituted m ->
1427 wrap c "substituted" model_path ppf (m :> Odoc_model.Paths.Path.t)
1428 | `SubstitutedMT m ->
1429 wrap c "substitutedmt" model_path ppf (m :> Odoc_model.Paths.Path.t)
1430 | `SubstitutedT m ->
1431 wrap c "substitutedt" model_path ppf (m :> Odoc_model.Paths.Path.t)
1432 | `SubstitutedCT m ->
1433 wrap c "substitutedct" model_path ppf (m :> Odoc_model.Paths.Path.t)
1434
1435 and model_resolved_path (c : config) ppf (p : rpath) =
1436 let open Odoc_model.Paths.Path.Resolved in
1437 match p with
1438 | `CoreType x -> Format.fprintf ppf "%s" (TypeName.to_string x)
1439 | `Identifier id -> Format.fprintf ppf "%a" (model_identifier c) (id :> id)
1440 | `Module (parent, name) ->
1441 Format.fprintf ppf "%a.%s" (model_resolved_path c)
1442 (parent :> t)
1443 (ModuleName.to_string name)
1444 | `ModuleType (parent, name) ->
1445 Format.fprintf ppf "%a.%s" (model_resolved_path c)
1446 (parent :> t)
1447 (ModuleTypeName.to_string name)
1448 | `Type (parent, name) ->
1449 Format.fprintf ppf "%a.%s" (model_resolved_path c)
1450 (parent :> t)
1451 (TypeName.to_string name)
1452 | `Value (parent, name) ->
1453 Format.fprintf ppf "%a.%s" (model_resolved_path c)
1454 (parent :> t)
1455 (ValueName.to_string name)
1456 | `Alias (dest, src) ->
1457 wrap2r c "alias" model_resolved_path model_path ppf
1458 (dest :> t)
1459 (src :> path)
1460 | `AliasModuleType (path, realpath) ->
1461 wrap2r c "aliasmoduletype" model_resolved_path model_resolved_path ppf
1462 (path :> t)
1463 (realpath :> t)
1464 | `Subst (modty, m) ->
1465 wrap2 c "subst" model_resolved_path model_resolved_path ppf
1466 (modty :> t)
1467 (m :> t)
1468 | `SubstT (t1, t2) ->
1469 wrap2 c "substt" model_resolved_path model_resolved_path ppf
1470 (t1 :> t)
1471 (t2 :> t)
1472 | `CanonicalModuleType (t1, t2) ->
1473 wrap2 c "canonicalmoduletype" model_resolved_path model_path ppf
1474 (t1 :> t)
1475 (t2 :> path)
1476 | `CanonicalType (t1, t2) ->
1477 wrap2 c "canonicaltype" model_resolved_path model_path ppf
1478 (t1 :> t)
1479 (t2 :> path)
1480 | `Apply (funct, arg) ->
1481 Format.fprintf ppf "%a(%a)" (model_resolved_path c)
1482 (funct :> t)
1483 (model_resolved_path c)
1484 (arg :> t)
1485 | `Canonical (p1, p2) ->
1486 wrap2 c "canonical" model_resolved_path model_path ppf
1487 (p1 :> t)
1488 (p2 :> path)
1489 | `Hidden p -> wrap c "hidden" model_resolved_path ppf (p :> t)
1490 | `Class (parent, name) ->
1491 Format.fprintf ppf "%a.%s" (model_resolved_path c)
1492 (parent :> t)
1493 (TypeName.to_string name)
1494 | `ClassType (parent, name) ->
1495 Format.fprintf ppf "%a.%s" (model_resolved_path c)
1496 (parent :> t)
1497 (TypeName.to_string name)
1498 | `OpaqueModule m -> wrap c "opaquemodule" model_resolved_path ppf (m :> t)
1499 | `OpaqueModuleType m ->
1500 wrap c "opaquemoduletype" model_resolved_path ppf (m :> t)
1501 | `Substituted m -> wrap c "substituted" model_resolved_path ppf (m :> t)
1502 | `SubstitutedMT m ->
1503 wrap c "substitutedmt" model_resolved_path ppf (m :> t)
1504 | `SubstitutedT m -> wrap c "substitutedt" model_resolved_path ppf (m :> t)
1505 | `SubstitutedCT m ->
1506 wrap c "substitutedct" model_resolved_path ppf (m :> t)
1507
1508 and model_fragment c ppf (f : Odoc_model.Paths.Fragment.t) =
1509 match f with
1510 | `Resolved rf -> model_resolved_fragment c ppf rf
1511 | `Dot (sg, d) ->
1512 Format.fprintf ppf "*%a.%s" (model_fragment c)
1513 (sg :> Odoc_model.Paths.Fragment.t)
1514 d
1515 | `Root -> ()
1516
1517 and model_resolved_fragment c ppf (f : Odoc_model.Paths.Fragment.Resolved.t) =
1518 let open Odoc_model.Paths.Fragment.Resolved in
1519 match f with
1520 | `Root (`ModuleType p) ->
1521 Format.fprintf ppf "root(%a)" (model_resolved_path c) (p :> rpath)
1522 | `Root (`Module p) ->
1523 Format.fprintf ppf "root(%a)" (model_resolved_path c) (p :> rpath)
1524 | `Module (`Root _, m) when c.short_paths ->
1525 Format.fprintf ppf "%s" (ModuleName.to_string m)
1526 | `Module (sg, m) ->
1527 Format.fprintf ppf "%a.%s"
1528 (model_resolved_fragment c)
1529 (sg :> t)
1530 (ModuleName.to_string m)
1531 | `Module_type (`Root _, m) when c.short_paths ->
1532 Format.fprintf ppf "%s" (ModuleTypeName.to_string m)
1533 | `Module_type (sg, mty) ->
1534 Format.fprintf ppf "%a.%s"
1535 (model_resolved_fragment c)
1536 (sg :> t)
1537 (ModuleTypeName.to_string mty)
1538 | `Type (`Root _, t) when c.short_paths ->
1539 Format.fprintf ppf "%s" (TypeName.to_string t)
1540 | `Type (sg, t) ->
1541 Format.fprintf ppf "%a.%s"
1542 (model_resolved_fragment c)
1543 (sg :> t)
1544 (TypeName.to_string t)
1545 | `Subst (path, m) ->
1546 Format.fprintf ppf "(%a subst -> %a)" (model_resolved_path c)
1547 (path :> rpath)
1548 (model_resolved_fragment c)
1549 (m :> t)
1550 | `Alias (_, _) -> Format.fprintf ppf "UNIMPLEMENTED subst alias!?"
1551 | `Class (sg, cls) ->
1552 Format.fprintf ppf "%a.%s"
1553 (model_resolved_fragment c)
1554 (sg :> t)
1555 (TypeName.to_string cls)
1556 | `ClassType (sg, cls) ->
1557 Format.fprintf ppf "%a.%s"
1558 (model_resolved_fragment c)
1559 (sg :> t)
1560 (TypeName.to_string cls)
1561 | `OpaqueModule m ->
1562 Format.fprintf ppf "opaquemodule(%a)"
1563 (model_resolved_fragment c)
1564 (m :> Odoc_model.Paths.Fragment.Resolved.t)
1565
1566 and resolved_root_fragment c ppf (f : Cfrag.root) =
1567 match f with
1568 | `ModuleType p ->
1569 Format.fprintf ppf "root(%a)" (resolved_module_type_path c) p
1570 | `Module p -> Format.fprintf ppf "root(%a)" (resolved_module_path c) p
1571
1572 and resolved_signature_fragment c ppf (f : Cfrag.resolved_signature) =
1573 match f with
1574 | `Root r -> Format.fprintf ppf "%a" (resolved_root_fragment c) r
1575 | (`Subst _ | `Alias _ | `Module _) as x -> resolved_module_fragment c ppf x
1576 | `OpaqueModule m ->
1577 Format.fprintf ppf "opaquemodule(%a)" (resolved_module_fragment c) m
1578
1579 and resolved_module_fragment c ppf (f : Cfrag.resolved_module) =
1580 match f with
1581 | `Subst (s, f) ->
1582 wrap2r c "subst" resolved_module_type_path resolved_module_fragment ppf
1583 s f
1584 | `Alias (m, f) ->
1585 wrap2r c "alias" resolved_module_path resolved_module_fragment ppf m f
1586 | `Module (`Root _, n) when c.short_paths ->
1587 Format.fprintf ppf "%s" (ModuleName.to_string n)
1588 | `Module (p, n) ->
1589 Format.fprintf ppf "%a.%s"
1590 (resolved_signature_fragment c)
1591 p (ModuleName.to_string n)
1592 | `OpaqueModule m -> wrap c "opaquemodule" resolved_module_fragment ppf m
1593
1594 and resolved_module_type_fragment c ppf (f : Cfrag.resolved_module_type) =
1595 match f with
1596 | `ModuleType (`Root _, n) when c.short_paths ->
1597 Format.fprintf ppf "%s" (ModuleTypeName.to_string n)
1598 | `ModuleType (p, n) ->
1599 Format.fprintf ppf "%a.%s"
1600 (resolved_signature_fragment c)
1601 p
1602 (ModuleTypeName.to_string n)
1603
1604 and resolved_type_fragment c ppf (f : Cfrag.resolved_type) =
1605 match f with
1606 | `Type (`Root _, n) when c.short_paths ->
1607 Format.fprintf ppf "%s" (TypeName.to_string n)
1608 | `Class (`Root _, n) when c.short_paths ->
1609 Format.fprintf ppf "%s" (TypeName.to_string n)
1610 | `ClassType (`Root _, n) when c.short_paths ->
1611 Format.fprintf ppf "%s" (TypeName.to_string n)
1612 | `Type (s, n) ->
1613 Format.fprintf ppf "%a.%s"
1614 (resolved_signature_fragment c)
1615 s (TypeName.to_string n)
1616 | `Class (s, n) ->
1617 Format.fprintf ppf "%a.%s"
1618 (resolved_signature_fragment c)
1619 s (TypeName.to_string n)
1620 | `ClassType (s, n) ->
1621 Format.fprintf ppf "%a.%s"
1622 (resolved_signature_fragment c)
1623 s (TypeName.to_string n)
1624
1625 and signature_fragment c ppf (f : Cfrag.signature) =
1626 match f with
1627 | `Resolved r ->
1628 Format.fprintf ppf "r(%a)" (resolved_signature_fragment c) r
1629 | `Dot (s, n) -> Format.fprintf ppf "%a.%s" (signature_fragment c) s n
1630 | `Root -> Format.fprintf ppf "root"
1631
1632 and module_fragment c ppf (f : Cfrag.module_) =
1633 match f with
1634 | `Resolved r -> wrap c "resolved" resolved_module_fragment ppf r
1635 | `Dot (`Root, n) when c.short_paths -> Format.fprintf ppf "%s" n
1636 | `Dot (s, n) -> Format.fprintf ppf "%a.%s" (signature_fragment c) s n
1637
1638 and module_type_fragment c ppf (f : Cfrag.module_type) =
1639 match f with
1640 | `Resolved r -> wrap c "resolved" resolved_module_type_fragment ppf r
1641 | `Dot (`Root, n) when c.short_paths -> Format.fprintf ppf "%s" n
1642 | `Dot (s, n) -> Format.fprintf ppf "%a.%s" (signature_fragment c) s n
1643
1644 and type_fragment c ppf (f : Cfrag.type_) =
1645 match f with
1646 | `Resolved r -> wrap c "resolved" resolved_type_fragment ppf r
1647 | `Dot (`Root, n) when c.short_paths -> Format.fprintf ppf "%s" n
1648 | `Dot (s, n) -> Format.fprintf ppf "%a.%s" (signature_fragment c) s n
1649
1650 and model_resolved_reference c ppf (r : Odoc_model.Paths.Reference.Resolved.t)
1651 =
1652 let open Odoc_model.Paths.Reference.Resolved in
1653 match r with
1654 | `Identifier id -> Format.fprintf ppf "%a" (model_identifier c) id
1655 | `Hidden p ->
1656 Format.fprintf ppf "hidden(%a)" (model_resolved_reference c) (p :> t)
1657 | `Module (parent, name) ->
1658 Format.fprintf ppf "%a.%s"
1659 (model_resolved_reference c)
1660 (parent :> t)
1661 (ModuleName.to_string name)
1662 | `ModuleType (parent, name) ->
1663 Format.fprintf ppf "%a.%s"
1664 (model_resolved_reference c)
1665 (parent :> t)
1666 (ModuleTypeName.to_string name)
1667 | `Type (parent, name) ->
1668 Format.fprintf ppf "%a.%s"
1669 (model_resolved_reference c)
1670 (parent :> t)
1671 (TypeName.to_string name)
1672 | `Constructor (parent, name) ->
1673 Format.fprintf ppf "%a.%s"
1674 (model_resolved_reference c)
1675 (parent :> t)
1676 (ConstructorName.to_string name)
1677 | `PolyConstructor (parent, name) ->
1678 Format.fprintf ppf "%a.%s"
1679 (model_resolved_reference c)
1680 (parent :> t)
1681 (ConstructorName.to_string name)
1682 | `Field (parent, name) ->
1683 Format.fprintf ppf "%a.%s"
1684 (model_resolved_reference c)
1685 (parent :> t)
1686 (FieldName.to_string name)
1687 | `UnboxedField (parent, name) ->
1688 Format.fprintf ppf "%a.#%s"
1689 (model_resolved_reference c)
1690 (parent :> t)
1691 (UnboxedFieldName.to_string name)
1692 | `Extension (parent, name) ->
1693 Format.fprintf ppf "%a.%s"
1694 (model_resolved_reference c)
1695 (parent :> t)
1696 (ExtensionName.to_string name)
1697 | `ExtensionDecl (parent, name, _) ->
1698 Format.fprintf ppf "%a.%s"
1699 (model_resolved_reference c)
1700 (parent :> t)
1701 (ExtensionName.to_string name)
1702 | `Exception (parent, name) ->
1703 Format.fprintf ppf "%a.%s"
1704 (model_resolved_reference c)
1705 (parent :> t)
1706 (ExceptionName.to_string name)
1707 | `Value (parent, name) ->
1708 Format.fprintf ppf "%a.%s"
1709 (model_resolved_reference c)
1710 (parent :> t)
1711 (ValueName.to_string name)
1712 | `Class (parent, name) ->
1713 Format.fprintf ppf "%a.%s"
1714 (model_resolved_reference c)
1715 (parent :> t)
1716 (TypeName.to_string name)
1717 | `ClassType (parent, name) ->
1718 Format.fprintf ppf "%a.%s"
1719 (model_resolved_reference c)
1720 (parent :> t)
1721 (TypeName.to_string name)
1722 | `Method (parent, name) ->
1723 Format.fprintf ppf "%a.%s"
1724 (model_resolved_reference c)
1725 (parent :> t)
1726 (MethodName.to_string name)
1727 | `InstanceVariable (parent, name) ->
1728 Format.fprintf ppf "%a.%s"
1729 (model_resolved_reference c)
1730 (parent :> t)
1731 (InstanceVariableName.to_string name)
1732 | `Alias (x, y) ->
1733 Format.fprintf ppf "alias(%a,%a)" (model_resolved_path c)
1734 (x :> rpath)
1735 (model_resolved_reference c)
1736 (y :> Odoc_model.Paths.Reference.Resolved.t)
1737 | `AliasModuleType (x, y) ->
1738 Format.fprintf ppf "aliasmoduletype(%a,%a)" (model_resolved_path c)
1739 (x :> rpath)
1740 (model_resolved_reference c)
1741 (y :> Odoc_model.Paths.Reference.Resolved.t)
1742 | `Label (parent, name) ->
1743 Format.fprintf ppf "%a.%s"
1744 (model_resolved_reference c)
1745 (parent :> t)
1746 (LabelName.to_string name)
1747
1748 and model_reference_hierarchy _c ppf
1749 ((tag, components) : Reference.Hierarchy.t) =
1750 (match tag with
1751 | `TRelativePath -> fpf ppf "./"
1752 | `TAbsolutePath -> fpf ppf "/"
1753 | `TCurrentPackage -> fpf ppf "//");
1754 let pp_sep ppf () = fpf ppf "/" in
1755 Format.pp_print_list ~pp_sep Format.pp_print_string ppf components
1756
1757 and model_reference c ppf (r : Reference.t) =
1758 let open Reference in
1759 match r with
1760 | `Resolved r' -> Format.fprintf ppf "r(%a)" (model_resolved_reference c) r'
1761 | `Root (name, _) -> Format.fprintf ppf "unresolvedroot(%s)" name
1762 | `Dot (parent, str) ->
1763 Format.fprintf ppf "%a.%s" (model_reference c) (parent :> t) str
1764 | `Page_path p -> model_reference_hierarchy c ppf p
1765 | `Asset_path p -> model_reference_hierarchy c ppf p
1766 | `Module_path p -> model_reference_hierarchy c ppf p
1767 | `Any_path p -> model_reference_hierarchy c ppf p
1768 | `Module (parent, name) ->
1769 Format.fprintf ppf "%a.%s" (model_reference c)
1770 (parent :> t)
1771 (ModuleName.to_string name)
1772 | `ModuleType (parent, name) ->
1773 Format.fprintf ppf "%a.%s" (model_reference c)
1774 (parent :> t)
1775 (ModuleTypeName.to_string name)
1776 | `Type (parent, name) ->
1777 Format.fprintf ppf "%a.%s" (model_reference c)
1778 (parent :> t)
1779 (TypeName.to_string name)
1780 | `Constructor (parent, name) ->
1781 Format.fprintf ppf "%a.%s" (model_reference c)
1782 (parent :> t)
1783 (ConstructorName.to_string name)
1784 | `Field (parent, name) ->
1785 Format.fprintf ppf "%a.%s" (model_reference c)
1786 (parent :> t)
1787 (FieldName.to_string name)
1788 | `UnboxedField (parent, name) ->
1789 Format.fprintf ppf "%a.%s" (model_reference c)
1790 (parent :> t)
1791 (UnboxedFieldName.to_string name)
1792 | `Extension (parent, name) ->
1793 Format.fprintf ppf "%a.%s" (model_reference c)
1794 (parent :> t)
1795 (ExtensionName.to_string name)
1796 | `ExtensionDecl (parent, name) ->
1797 Format.fprintf ppf "%a.%s" (model_reference c)
1798 (parent :> t)
1799 (ExtensionName.to_string name)
1800 | `Exception (parent, name) ->
1801 Format.fprintf ppf "%a.%s" (model_reference c)
1802 (parent :> t)
1803 (ExceptionName.to_string name)
1804 | `Value (parent, name) ->
1805 Format.fprintf ppf "%a.%s" (model_reference c)
1806 (parent :> t)
1807 (ValueName.to_string name)
1808 | `Class (parent, name) ->
1809 Format.fprintf ppf "%a.%s" (model_reference c)
1810 (parent :> t)
1811 (TypeName.to_string name)
1812 | `ClassType (parent, name) ->
1813 Format.fprintf ppf "%a.%s" (model_reference c)
1814 (parent :> t)
1815 (TypeName.to_string name)
1816 | `Method (parent, name) ->
1817 Format.fprintf ppf "%a.%s" (model_reference c)
1818 (parent :> t)
1819 (MethodName.to_string name)
1820 | `InstanceVariable (parent, name) ->
1821 Format.fprintf ppf "%a.%s" (model_reference c)
1822 (parent :> t)
1823 (InstanceVariableName.to_string name)
1824 | `Label (parent, name) ->
1825 Format.fprintf ppf "%a.%s" (model_reference c)
1826 (parent :> t)
1827 (LabelName.to_string name)
1828end
1829
1830module LocalIdents = struct
1831 open Odoc_model
1832 (** The purpose of this module is to extract identifiers that could be
1833 referenced in Paths - that is, modules, module types, types, classes and
1834 class types. That way we can assign them an Ident.t ahead of time and be
1835 self-consistent. Because we don't need _all_ of the identifiers we don't
1836 traverse the entire structure. Additionally, we stop at (class_)signature
1837 boundaries since identifiers within these won't be referenced except
1838 within them, so we only do that on demand. *)
1839
1840 type t = {
1841 modules : Paths.Identifier.Module.t list;
1842 module_types : Paths.Identifier.ModuleType.t list;
1843 types : Paths.Identifier.Type.t list;
1844 classes : Paths.Identifier.Class.t list;
1845 class_types : Paths.Identifier.ClassType.t list;
1846 }
1847
1848 let empty =
1849 {
1850 modules = [];
1851 module_types = [];
1852 types = [];
1853 classes = [];
1854 class_types = [];
1855 }
1856
1857 open Lang
1858
1859 let rec signature_items s ids =
1860 let open Signature in
1861 List.fold_left
1862 (fun ids c ->
1863 match c with
1864 | Module (_, { Module.id; _ }) ->
1865 { ids with modules = id :: ids.modules }
1866 | ModuleType m ->
1867 { ids with module_types = m.ModuleType.id :: ids.module_types }
1868 | ModuleSubstitution { ModuleSubstitution.id; _ } ->
1869 { ids with modules = id :: ids.modules }
1870 | ModuleTypeSubstitution { ModuleTypeSubstitution.id; _ } ->
1871 { ids with module_types = id :: ids.module_types }
1872 | Type (_, t) -> { ids with types = t.TypeDecl.id :: ids.types }
1873 | TypeSubstitution t -> { ids with types = t.TypeDecl.id :: ids.types }
1874 | Class (_, c) -> { ids with classes = c.Class.id :: ids.classes }
1875 | ClassType (_, c) ->
1876 { ids with class_types = c.ClassType.id :: ids.class_types }
1877 | TypExt _ | Exception _ | Value _ | Comment _ -> ids
1878 | Include i -> signature i.Include.expansion.content ids
1879 | Open o -> signature o.Open.expansion ids)
1880 ids s
1881
1882 and signature s ids = signature_items s.items ids
1883end
1884
1885module Of_Lang = struct
1886 open Odoc_model
1887
1888 type map = {
1889 modules : Ident.module_ Paths.Identifier.Maps.Module.t;
1890 module_types : Ident.module_type Paths.Identifier.Maps.ModuleType.t;
1891 functor_parameters : Ident.module_ Paths.Identifier.Maps.FunctorParameter.t;
1892 types : Ident.type_ Paths.Identifier.Maps.Type.t;
1893 path_types : Ident.type_ Paths.Identifier.Maps.Path.Type.t;
1894 path_class_types : Ident.type_ Paths.Identifier.Maps.Path.ClassType.t;
1895 classes : Ident.type_ Paths.Identifier.Maps.Class.t;
1896 class_types : Ident.type_ Paths.Identifier.Maps.ClassType.t;
1897 }
1898
1899 let empty () =
1900 let open Paths.Identifier.Maps in
1901 {
1902 modules = Module.empty;
1903 module_types = ModuleType.empty;
1904 functor_parameters = FunctorParameter.empty;
1905 types = Type.empty;
1906 path_types = Path.Type.empty;
1907 path_class_types = Path.ClassType.empty;
1908 classes = Class.empty;
1909 class_types = ClassType.empty;
1910 }
1911
1912 let map_of_idents ids map =
1913 let open Paths.Identifier in
1914 (* New types go into [types_new] and [path_types_new]
1915 New classes go into [classes_new] and [path_class_types_new]
1916 New class_types go into [class_types_new], [path_types_new] and [path_class_types_new] *)
1917 let types_new, path_types_new =
1918 List.fold_left
1919 (fun (types, path_types) i ->
1920 let id = Ident.Of_Identifier.type_ i in
1921 ( Maps.Type.add i id types,
1922 Maps.Path.Type.add (i :> Path.Type.t) id path_types ))
1923 (map.types, map.path_types)
1924 ids.LocalIdents.types
1925 in
1926 let classes_new, path_class_types_new =
1927 List.fold_left
1928 (fun (classes, path_class_types) i ->
1929 let id = Ident.Of_Identifier.class_ i in
1930 ( Maps.Class.add i id classes,
1931 Maps.Path.ClassType.add (i :> Path.ClassType.t) id path_class_types
1932 ))
1933 (map.classes, map.path_class_types)
1934 ids.LocalIdents.classes
1935 in
1936 let class_types_new, path_types_new, path_class_types_new =
1937 List.fold_left
1938 (fun (class_types, path_types, path_class_types) i ->
1939 let id = Ident.Of_Identifier.class_type i in
1940 ( Maps.ClassType.add i id class_types,
1941 Maps.Path.Type.add (i :> Path.Type.t) id path_types,
1942 Maps.Path.ClassType.add (i :> Path.ClassType.t) id path_class_types
1943 ))
1944 (map.class_types, path_types_new, path_class_types_new)
1945 ids.LocalIdents.class_types
1946 in
1947 let modules_new =
1948 List.fold_left
1949 (fun acc i ->
1950 Maps.Module.add (i :> Module.t) (Ident.Of_Identifier.module_ i) acc)
1951 map.modules ids.LocalIdents.modules
1952 in
1953 let module_types_new =
1954 List.fold_left
1955 (fun acc i ->
1956 Maps.ModuleType.add i (Ident.Of_Identifier.module_type i) acc)
1957 map.module_types ids.LocalIdents.module_types
1958 in
1959 let modules = modules_new in
1960 let module_types = module_types_new in
1961 let functor_parameters = map.functor_parameters in
1962 let types = types_new in
1963 let classes = classes_new in
1964 let class_types = class_types_new in
1965 let path_types = path_types_new in
1966 let path_class_types = path_class_types_new in
1967 {
1968 modules;
1969 module_types;
1970 functor_parameters;
1971 types;
1972 classes;
1973 class_types;
1974 path_types;
1975 path_class_types;
1976 }
1977
1978 let option conv ident_map x =
1979 match x with None -> None | Some x' -> Some (conv ident_map x')
1980
1981 let identifier lookup map i =
1982 match lookup i map with
1983 | x -> `Local x
1984 | exception Not_found -> `Identifier i
1985
1986 let find_any_module i ident_map =
1987 match i with
1988 | { Odoc_model.Paths.Identifier.iv = `Root _ | `Module _; _ } as id ->
1989 Maps.Module.find id ident_map.modules
1990 | {
1991 Odoc_model.Paths.Identifier.iv = #Paths.Identifier.FunctorParameter.t_pv;
1992 _;
1993 } as id ->
1994 Maps.FunctorParameter.find id ident_map.functor_parameters
1995 | _ -> raise Not_found
1996
1997 let rec resolved_module_path :
1998 _ -> Odoc_model.Paths.Path.Resolved.Module.t -> Cpath.Resolved.module_ =
1999 fun ident_map p ->
2000 let recurse = resolved_module_path ident_map in
2001 match p with
2002 | `Identifier i -> (
2003 match identifier find_any_module ident_map i with
2004 | `Local l -> `Local l
2005 | `Identifier _ -> `Gpath p)
2006 | `Module (p, name) -> `Module (`Module (recurse p), name)
2007 | `Apply (p1, p2) -> `Apply (recurse p1, recurse p2)
2008 | `Alias (p1, p2) -> `Alias (recurse p1, module_path ident_map p2, None)
2009 | `Subst (p1, p2) ->
2010 `Subst (resolved_module_type_path ident_map p1, recurse p2)
2011 | `Canonical (p1, p2) -> `Canonical (recurse p1, p2)
2012 | `Hidden p1 -> `Hidden (recurse p1)
2013 | `OpaqueModule m -> `OpaqueModule (recurse m)
2014 | `Substituted m -> `Substituted (recurse m)
2015
2016 and resolved_module_type_path :
2017 _ ->
2018 Odoc_model.Paths.Path.Resolved.ModuleType.t ->
2019 Cpath.Resolved.module_type =
2020 fun ident_map p ->
2021 match p with
2022 | `Identifier i -> (
2023 match identifier Maps.ModuleType.find ident_map.module_types i with
2024 | `Local l -> `Local l
2025 | `Identifier _ -> `Gpath p)
2026 | `ModuleType (p, name) ->
2027 `ModuleType (`Module (resolved_module_path ident_map p), name)
2028 | `CanonicalModuleType (p1, p2) ->
2029 `CanonicalModuleType (resolved_module_type_path ident_map p1, p2)
2030 | `OpaqueModuleType m ->
2031 `OpaqueModuleType (resolved_module_type_path ident_map m)
2032 | `AliasModuleType (m1, m2) ->
2033 `AliasModuleType
2034 ( resolved_module_type_path ident_map m1,
2035 resolved_module_type_path ident_map m2 )
2036 | `SubstT (p1, p2) ->
2037 `SubstT
2038 ( resolved_module_type_path ident_map p1,
2039 resolved_module_type_path ident_map p2 )
2040 | `SubstitutedMT m -> `Substituted (resolved_module_type_path ident_map m)
2041
2042 and resolved_type_path :
2043 _ -> Odoc_model.Paths.Path.Resolved.Type.t -> Cpath.Resolved.type_ =
2044 fun ident_map p ->
2045 match p with
2046 | `CoreType _ as c -> c
2047 | `Identifier i -> (
2048 match identifier Maps.Path.Type.find ident_map.path_types i with
2049 | `Local l -> `Local l
2050 | `Identifier _ -> `Gpath p)
2051 | `CanonicalType (p1, p2) ->
2052 `CanonicalType (resolved_type_path ident_map p1, p2)
2053 | `Type (p, name) -> `Type (`Module (resolved_module_path ident_map p), name)
2054 | `Class (p, name) ->
2055 `Class (`Module (resolved_module_path ident_map p), name)
2056 | `ClassType (p, name) ->
2057 `ClassType (`Module (resolved_module_path ident_map p), name)
2058 | `SubstitutedT m -> `Substituted (resolved_type_path ident_map m)
2059 | `SubstitutedCT m ->
2060 `Substituted
2061 (resolved_class_type_path ident_map m :> Cpath.Resolved.type_)
2062
2063 and resolved_value_path :
2064 _ -> Odoc_model.Paths.Path.Resolved.Value.t -> Cpath.Resolved.value =
2065 fun ident_map p ->
2066 match p with
2067 | `Value (p, name) ->
2068 `Value (`Module (resolved_module_path ident_map p), name)
2069 | `Identifier _ -> `Gpath p
2070
2071 and resolved_class_type_path :
2072 _ ->
2073 Odoc_model.Paths.Path.Resolved.ClassType.t ->
2074 Cpath.Resolved.class_type =
2075 fun ident_map p ->
2076 match p with
2077 | `Identifier i -> (
2078 match
2079 identifier Maps.Path.ClassType.find ident_map.path_class_types i
2080 with
2081 | `Local l -> `Local l
2082 | `Identifier _ -> `Gpath p)
2083 | `Class (p, name) ->
2084 `Class (`Module (resolved_module_path ident_map p), name)
2085 | `ClassType (p, name) ->
2086 `ClassType (`Module (resolved_module_path ident_map p), name)
2087 | `SubstitutedCT c -> `Substituted (resolved_class_type_path ident_map c)
2088
2089 and module_path : _ -> Odoc_model.Paths.Path.Module.t -> Cpath.module_ =
2090 fun ident_map p ->
2091 match p with
2092 | `Resolved r -> `Resolved (resolved_module_path ident_map r)
2093 | `Substituted m -> `Substituted (module_path ident_map m)
2094 | `Identifier (i, b) -> (
2095 match identifier find_any_module ident_map i with
2096 | `Identifier i -> `Identifier (i, b)
2097 | `Local i -> `Local (i, b))
2098 | `Dot (path', x) -> `Dot (module_path ident_map path', x)
2099 | `Apply (p1, p2) ->
2100 `Apply (module_path ident_map p1, module_path ident_map p2)
2101 | `Forward str -> `Forward str
2102 | `Root str -> `Root str
2103
2104 and module_type_path :
2105 _ -> Odoc_model.Paths.Path.ModuleType.t -> Cpath.module_type =
2106 fun ident_map p ->
2107 match p with
2108 | `Resolved r -> `Resolved (resolved_module_type_path ident_map r)
2109 | `SubstitutedMT m -> `Substituted (module_type_path ident_map m)
2110 | `Identifier (i, b) -> (
2111 match identifier Maps.ModuleType.find ident_map.module_types i with
2112 | `Identifier i -> `Identifier (i, b)
2113 | `Local i -> `Local (i, b))
2114 | `DotMT (path', x) -> `DotMT (module_path ident_map path', x)
2115
2116 and type_path : _ -> Odoc_model.Paths.Path.Type.t -> Cpath.type_ =
2117 fun ident_map p ->
2118 match p with
2119 | `Resolved r -> `Resolved (resolved_type_path ident_map r)
2120 | `SubstitutedT t -> `Substituted (type_path ident_map t)
2121 | `Identifier (i, b) -> (
2122 match identifier Maps.Path.Type.find ident_map.path_types i with
2123 | `Identifier i -> `Identifier (i, b)
2124 | `Local i -> `Local (i, b))
2125 | `DotT (path', x) -> `DotT (module_path ident_map path', x)
2126
2127 and value_path : _ -> Odoc_model.Paths.Path.Value.t -> Cpath.value =
2128 fun ident_map p ->
2129 match p with
2130 | `Resolved r -> `Resolved (resolved_value_path ident_map r)
2131 | `DotV (path', x) -> `DotV (module_path ident_map path', x)
2132 | `Identifier (i, b) -> `Identifier (i, b)
2133
2134 and class_type_path :
2135 _ -> Odoc_model.Paths.Path.ClassType.t -> Cpath.class_type =
2136 fun ident_map p ->
2137 match p with
2138 | `Resolved r -> `Resolved (resolved_class_type_path ident_map r)
2139 | `SubstitutedCT c -> `Substituted (class_type_path ident_map c)
2140 | `Identifier (i, b) -> (
2141 match
2142 identifier Maps.Path.ClassType.find ident_map.path_class_types i
2143 with
2144 | `Identifier i -> `Identifier (i, b)
2145 | `Local i -> `Local (i, b))
2146 | `DotT (path', x) -> `DotT (module_path ident_map path', x)
2147
2148 let rec resolved_signature_fragment :
2149 map ->
2150 Odoc_model.Paths.Fragment.Resolved.Signature.t ->
2151 Cfrag.resolved_signature =
2152 fun ident_map ty ->
2153 match ty with
2154 | `Root (`ModuleType path) ->
2155 `Root (`ModuleType (resolved_module_type_path ident_map path))
2156 | `Root (`Module path) ->
2157 `Root (`Module (resolved_module_path ident_map path))
2158 | (`Alias _ | `Subst _ | `Module _ | `OpaqueModule _) as x ->
2159 (resolved_module_fragment ident_map x :> Cfrag.resolved_signature)
2160
2161 and resolved_module_fragment :
2162 _ -> Odoc_model.Paths.Fragment.Resolved.Module.t -> Cfrag.resolved_module
2163 =
2164 fun ident_map ty ->
2165 match ty with
2166 | `Subst (p, m) ->
2167 `Subst
2168 ( resolved_module_type_path ident_map p,
2169 resolved_module_fragment ident_map m )
2170 | `Alias (p, m) ->
2171 `Alias
2172 ( resolved_module_path ident_map p,
2173 resolved_module_fragment ident_map m )
2174 | `Module (p, m) -> `Module (resolved_signature_fragment ident_map p, m)
2175 | `OpaqueModule m -> `OpaqueModule (resolved_module_fragment ident_map m)
2176
2177 and resolved_module_type_fragment :
2178 _ ->
2179 Odoc_model.Paths.Fragment.Resolved.ModuleType.t ->
2180 Cfrag.resolved_module_type =
2181 fun ident_map ty ->
2182 match ty with
2183 | `Module_type (p, m) ->
2184 `ModuleType (resolved_signature_fragment ident_map p, m)
2185
2186 and resolved_type_fragment :
2187 _ -> Odoc_model.Paths.Fragment.Resolved.Type.t -> Cfrag.resolved_type =
2188 fun ident_map ty ->
2189 match ty with
2190 | `Type (p, n) -> `Type (resolved_signature_fragment ident_map p, n)
2191 | `Class (p, n) -> `Class (resolved_signature_fragment ident_map p, n)
2192 | `ClassType (p, n) ->
2193 `ClassType (resolved_signature_fragment ident_map p, n)
2194
2195 let rec signature_fragment :
2196 _ -> Odoc_model.Paths.Fragment.Signature.t -> Cfrag.signature =
2197 fun ident_map ty ->
2198 match ty with
2199 | `Resolved r -> `Resolved (resolved_signature_fragment ident_map r)
2200 | `Dot (p, n) -> `Dot (signature_fragment ident_map p, n)
2201 | `Root -> `Root
2202
2203 let module_fragment : _ -> Odoc_model.Paths.Fragment.Module.t -> Cfrag.module_
2204 =
2205 fun ident_map ty ->
2206 match ty with
2207 | `Resolved r -> `Resolved (resolved_module_fragment ident_map r)
2208 | `Dot (p, n) -> `Dot (signature_fragment ident_map p, n)
2209
2210 let module_type_fragment :
2211 _ -> Odoc_model.Paths.Fragment.ModuleType.t -> Cfrag.module_type =
2212 fun ident_map ty ->
2213 match ty with
2214 | `Resolved r -> `Resolved (resolved_module_type_fragment ident_map r)
2215 | `Dot (p, n) -> `Dot (signature_fragment ident_map p, n)
2216
2217 let type_fragment : _ -> Odoc_model.Paths.Fragment.Type.t -> Cfrag.type_ =
2218 fun ident_map ty ->
2219 match ty with
2220 | `Resolved r -> `Resolved (resolved_type_fragment ident_map r)
2221 | `Dot (p, n) -> `Dot (signature_fragment ident_map p, n)
2222
2223 let rec type_decl ident_map ty =
2224 let open Odoc_model.Lang.TypeDecl in
2225 {
2226 TypeDecl.source_loc = ty.source_loc;
2227 source_loc_jane = ty.source_loc_jane;
2228 doc = docs ident_map ty.doc;
2229 canonical = ty.canonical;
2230 equation = type_equation ident_map ty.equation;
2231 representation =
2232 Opt.map (type_decl_representation ident_map) ty.representation;
2233 }
2234
2235 and type_decl_representation ident_map r =
2236 let open Odoc_model.Lang.TypeDecl.Representation in
2237 match r with
2238 | Variant cs ->
2239 TypeDecl.Representation.Variant
2240 (List.map (type_decl_constructor ident_map) cs)
2241 | Record fs -> Record (List.map (type_decl_field ident_map) fs)
2242 | Record_unboxed_product fs ->
2243 Record_unboxed_product (List.map (type_decl_unboxed_field ident_map) fs)
2244 | Extensible -> Extensible
2245
2246 and type_decl_constructor ident_map t =
2247 let open Odoc_model.Lang.TypeDecl.Constructor in
2248 let args = type_decl_constructor_argument ident_map t.args in
2249 let res = Opt.map (type_expression ident_map) t.res in
2250 {
2251 TypeDecl.Constructor.name = Paths.Identifier.name t.id;
2252 doc = docs ident_map t.doc;
2253 args;
2254 res;
2255 }
2256
2257 and type_decl_constructor_argument ident_map a =
2258 let open Odoc_model.Lang.TypeDecl.Constructor in
2259 match a with
2260 | Tuple ts ->
2261 TypeDecl.Constructor.Tuple (List.map (type_expression ident_map) ts)
2262 | Record fs -> Record (List.map (type_decl_field ident_map) fs)
2263
2264 and type_decl_field ident_map f =
2265 let open Odoc_model.Lang.TypeDecl.Field in
2266 let type_ = type_expression ident_map f.type_ in
2267 {
2268 TypeDecl.Field.name = Paths.Identifier.name f.id;
2269 doc = docs ident_map f.doc;
2270 mutable_ = f.mutable_;
2271 type_;
2272 }
2273
2274 and type_decl_unboxed_field ident_map f =
2275 let type_ = type_expression ident_map f.type_ in
2276 {
2277 TypeDecl.UnboxedField.name = Paths.Identifier.name f.id;
2278 doc = docs ident_map f.doc;
2279 mutable_ = f.mutable_;
2280 type_;
2281 }
2282
2283 and type_equation ident_map teq =
2284 let open Odoc_model.Lang.TypeDecl.Equation in
2285 {
2286 TypeDecl.Equation.params = teq.params;
2287 private_ = teq.private_;
2288 manifest = option type_expression ident_map teq.manifest;
2289 constraints =
2290 List.map
2291 (fun (x, y) ->
2292 (type_expression ident_map x, type_expression ident_map y))
2293 teq.constraints;
2294 }
2295
2296 and type_expr_polyvar ident_map v =
2297 let open Odoc_model.Lang.TypeExpr.Polymorphic_variant in
2298 let map_element = function
2299 | Type expr ->
2300 TypeExpr.Polymorphic_variant.Type (type_expression ident_map expr)
2301 | Constructor c ->
2302 Constructor
2303 TypeExpr.Polymorphic_variant.Constructor.
2304 {
2305 name = c.name;
2306 constant = c.constant;
2307 arguments = List.map (type_expression ident_map) c.arguments;
2308 doc = docs ident_map c.doc;
2309 }
2310 in
2311 {
2312 TypeExpr.Polymorphic_variant.kind = v.kind;
2313 elements = List.map map_element v.elements;
2314 }
2315
2316 and type_object ident_map o =
2317 let open Odoc_model.Lang.TypeExpr.Object in
2318 let map_field = function
2319 | Method m ->
2320 TypeExpr.(
2321 Object.Method
2322 {
2323 Object.name = m.name;
2324 type_ = type_expression ident_map m.type_;
2325 })
2326 | Inherit i -> Inherit (type_expression ident_map i)
2327 in
2328 { TypeExpr.Object.open_ = o.open_; fields = List.map map_field o.fields }
2329
2330 and type_package ident_map pkg =
2331 let open Odoc_model.Lang.TypeExpr.Package in
2332 {
2333 TypeExpr.Package.path = module_type_path ident_map pkg.path;
2334 substitutions =
2335 List.map
2336 (fun (x, y) ->
2337 let f = type_fragment ident_map x in
2338 (f, type_expression ident_map y))
2339 pkg.substitutions;
2340 }
2341
2342 and type_expression ident_map expr =
2343 let open Odoc_model.Lang.TypeExpr in
2344 match expr with
2345 | Var (s, jk) -> TypeExpr.Var (s, jk)
2346 | Any -> Any
2347 | Constr (p, xs) ->
2348 Constr (type_path ident_map p, List.map (type_expression ident_map) xs)
2349 | Arrow (lbl, t1, t2, modes, ret_modes) ->
2350 Arrow (lbl, type_expression ident_map t1, type_expression ident_map t2, modes, ret_modes)
2351 | Tuple ts ->
2352 Tuple
2353 (List.map (fun (lbl, ty) -> (lbl, type_expression ident_map ty)) ts)
2354 | Unboxed_tuple ts ->
2355 Unboxed_tuple (List.map (fun (l, t) -> l, type_expression ident_map t) ts)
2356 | Polymorphic_variant v ->
2357 Polymorphic_variant (type_expr_polyvar ident_map v)
2358 | Poly (s, ts) -> Poly (s, type_expression ident_map ts)
2359 | Alias (t, s) -> Alias (type_expression ident_map t, s)
2360 | Class (p, ts) ->
2361 Class
2362 (class_type_path ident_map p, List.map (type_expression ident_map) ts)
2363 | Object o -> Object (type_object ident_map o)
2364 | Quote t -> Quote (type_expression ident_map t)
2365 | Splice t -> Splice (type_expression ident_map t)
2366 | Package p -> Package (type_package ident_map p)
2367
2368 and module_decl ident_map m =
2369 match m with
2370 | Lang.Module.Alias (p, e) ->
2371 Module.Alias
2372 (module_path ident_map p, option simple_expansion ident_map e)
2373 | Lang.Module.ModuleType s ->
2374 Module.ModuleType (module_type_expr ident_map s)
2375
2376 and include_decl ident_map m =
2377 match m with
2378 | Odoc_model.Lang.Include.Alias p -> Include.Alias (module_path ident_map p)
2379 | ModuleType s -> ModuleType (u_module_type_expr ident_map s)
2380
2381 and simple_expansion ident_map
2382 (f : Odoc_model.Lang.ModuleType.simple_expansion) :
2383 ModuleType.simple_expansion =
2384 let open Odoc_model.Lang.ModuleType in
2385 let open Odoc_model.Lang.FunctorParameter in
2386 match f with
2387 | Signature t -> Signature (signature ident_map t)
2388 | Functor (arg, sg) -> (
2389 match arg with
2390 | Named arg ->
2391 let identifier = arg.Odoc_model.Lang.FunctorParameter.id in
2392 let id = Ident.Of_Identifier.functor_parameter identifier in
2393 let ident_map' =
2394 {
2395 ident_map with
2396 functor_parameters =
2397 Maps.FunctorParameter.add identifier id
2398 ident_map.functor_parameters;
2399 }
2400 in
2401 let arg' = functor_parameter ident_map' id arg in
2402 Functor (FunctorParameter.Named arg', simple_expansion ident_map' sg)
2403 | Unit -> Functor (FunctorParameter.Unit, simple_expansion ident_map sg)
2404 )
2405
2406 and module_ ident_map m =
2407 let type_ = module_decl ident_map m.Odoc_model.Lang.Module.type_ in
2408 let canonical = m.Odoc_model.Lang.Module.canonical in
2409 {
2410 Module.source_loc = m.source_loc;
2411 source_loc_jane = m.source_loc_jane;
2412 doc = docs ident_map m.doc;
2413 type_;
2414 canonical;
2415 hidden = m.hidden;
2416 }
2417
2418 and with_module_type_substitution ident_map m =
2419 let open Odoc_model.Lang.ModuleType in
2420 match m with
2421 | ModuleEq (frag, decl) ->
2422 ModuleType.ModuleEq
2423 (module_fragment ident_map frag, module_decl ident_map decl)
2424 | ModuleSubst (frag, p) ->
2425 ModuleType.ModuleSubst
2426 (module_fragment ident_map frag, module_path ident_map p)
2427 | ModuleTypeEq (frag, mty) ->
2428 ModuleType.ModuleTypeEq
2429 (module_type_fragment ident_map frag, module_type_expr ident_map mty)
2430 | ModuleTypeSubst (frag, mty) ->
2431 ModuleType.ModuleTypeSubst
2432 (module_type_fragment ident_map frag, module_type_expr ident_map mty)
2433 | TypeEq (frag, eqn) ->
2434 ModuleType.TypeEq
2435 (type_fragment ident_map frag, type_equation ident_map eqn)
2436 | TypeSubst (frag, eqn) ->
2437 ModuleType.TypeSubst
2438 (type_fragment ident_map frag, type_equation ident_map eqn)
2439
2440 and functor_parameter ident_map id a =
2441 let expr' =
2442 module_type_expr ident_map a.Odoc_model.Lang.FunctorParameter.expr
2443 in
2444 { FunctorParameter.id; expr = expr' }
2445
2446 and extension ident_map e =
2447 let open Odoc_model.Lang.Extension in
2448 let type_path = type_path ident_map e.type_path in
2449 let constructors =
2450 List.map (extension_constructor ident_map) e.constructors
2451 in
2452 {
2453 Extension.type_path;
2454 doc = docs ident_map e.doc;
2455 type_params = e.type_params;
2456 private_ = e.private_;
2457 constructors;
2458 }
2459
2460 and extension_constructor ident_map c =
2461 let open Odoc_model.Lang.Extension.Constructor in
2462 let args = type_decl_constructor_argument ident_map c.args in
2463 let res = Opt.map (type_expression ident_map) c.res in
2464 {
2465 Extension.Constructor.name = Paths.Identifier.name c.id;
2466 source_loc = c.source_loc;
2467 doc = docs ident_map c.doc;
2468 args;
2469 res;
2470 }
2471
2472 and exception_ ident_map e =
2473 let open Odoc_model.Lang.Exception in
2474 let args = type_decl_constructor_argument ident_map e.args in
2475 let res = Opt.map (type_expression ident_map) e.res in
2476 {
2477 Exception.source_loc = e.source_loc;
2478 source_loc_jane = e.source_loc_jane;
2479 doc = docs ident_map e.doc;
2480 args;
2481 res;
2482 }
2483
2484 and u_module_type_expr ident_map m =
2485 let open Odoc_model in
2486 match m with
2487 | Lang.ModuleType.U.Signature s ->
2488 let s = signature ident_map s in
2489 ModuleType.U.Signature s
2490 | Path p ->
2491 let p' = module_type_path ident_map p in
2492 Path p'
2493 | With (w, e) ->
2494 let w' = List.map (with_module_type_substitution ident_map) w in
2495 With (w', u_module_type_expr ident_map e)
2496 | TypeOf (t_desc, t_original_path) ->
2497 let t_desc =
2498 match t_desc with
2499 | ModPath p -> ModuleType.ModPath (module_path ident_map p)
2500 | StructInclude p -> StructInclude (module_path ident_map p)
2501 in
2502 (* see comment in module_type_expr below *)
2503 let t_original_path = module_path (empty ()) t_original_path in
2504 TypeOf (t_desc, t_original_path)
2505 | Strengthen (e, p, a) ->
2506 let e = u_module_type_expr ident_map e in
2507 let p = module_path ident_map p in
2508 Strengthen (e, p, a)
2509
2510 and module_type_expr ident_map m =
2511 let open Odoc_model in
2512 let open Paths in
2513 match m with
2514 | Lang.ModuleType.Signature s ->
2515 let s = signature ident_map s in
2516 ModuleType.Signature s
2517 | Lang.ModuleType.Path p ->
2518 let p' =
2519 ModuleType.
2520 {
2521 p_path = module_type_path ident_map p.p_path;
2522 p_expansion = option simple_expansion ident_map p.p_expansion;
2523 }
2524 in
2525 ModuleType.Path p'
2526 | Lang.ModuleType.With w ->
2527 let w' =
2528 ModuleType.
2529 {
2530 w_substitutions =
2531 List.map
2532 (with_module_type_substitution ident_map)
2533 w.w_substitutions;
2534 w_expansion = option simple_expansion ident_map w.w_expansion;
2535 w_expr = u_module_type_expr ident_map w.w_expr;
2536 }
2537 in
2538 ModuleType.With w'
2539 | Lang.ModuleType.Functor (Named arg, expr) ->
2540 let identifier = arg.Lang.FunctorParameter.id in
2541 let id = Ident.Of_Identifier.functor_parameter identifier in
2542 let ident_map' =
2543 {
2544 ident_map with
2545 functor_parameters =
2546 Identifier.Maps.FunctorParameter.add identifier id
2547 ident_map.functor_parameters;
2548 }
2549 in
2550 let arg' = functor_parameter ident_map' id arg in
2551 let expr' = module_type_expr ident_map' expr in
2552 ModuleType.Functor (Named arg', expr')
2553 | Lang.ModuleType.Functor (Unit, expr) ->
2554 let expr' = module_type_expr ident_map expr in
2555 ModuleType.Functor (Unit, expr')
2556 | Lang.ModuleType.TypeOf { t_desc; t_original_path; t_expansion } ->
2557 let t_desc =
2558 match t_desc with
2559 | ModPath p -> ModuleType.ModPath (module_path ident_map p)
2560 | StructInclude p -> StructInclude (module_path ident_map p)
2561 in
2562 let t_expansion = option simple_expansion ident_map t_expansion in
2563 (* Nb, we _never_ want to relativize this path, because this should always be
2564 the _original_ path. That's why we're passing in (empty()) rather than
2565 ident_map. We don't leave it as a Lang path because we'll occasionally
2566 _create_ a `TypeOf` expression as part of fragmap *)
2567 let t_original_path = module_path (empty ()) t_original_path in
2568 ModuleType.(TypeOf { t_desc; t_original_path; t_expansion })
2569 | Lang.ModuleType.Strengthen s ->
2570 let s' =
2571 ModuleType.
2572 { s_expr = u_module_type_expr ident_map s.s_expr;
2573 s_path = module_path ident_map s.s_path;
2574 s_aliasable = s.s_aliasable;
2575 s_expansion = option simple_expansion ident_map s.s_expansion
2576 }
2577 in
2578 ModuleType.Strengthen s'
2579
2580 and module_type ident_map m =
2581 let expr =
2582 Opt.map (module_type_expr ident_map) m.Odoc_model.Lang.ModuleType.expr
2583 in
2584 {
2585 ModuleType.source_loc = m.source_loc;
2586 source_loc_jane = m.source_loc_jane;
2587 doc = docs ident_map m.doc;
2588 canonical = m.canonical;
2589 expr;
2590 }
2591
2592 and value ident_map v =
2593 let type_ = type_expression ident_map v.Lang.Value.type_ in
2594 {
2595 Value.type_;
2596 doc = docs ident_map v.doc;
2597 value = v.value;
2598 source_loc = v.source_loc;
2599 source_loc_jane = v.source_loc_jane;
2600 modalities = v.Lang.Value.modalities;
2601 }
2602
2603 and include_ ident_map i =
2604 let open Odoc_model.Lang.Include in
2605 let decl = include_decl ident_map i.decl in
2606 {
2607 Include.parent = i.parent;
2608 doc = docs ident_map i.doc;
2609 shadowed = i.expansion.shadowed;
2610 expansion_ = apply_sig_map ident_map i.expansion.content;
2611 expanded = i.expanded;
2612 status = i.status;
2613 strengthened = option module_path ident_map i.strengthened;
2614 decl;
2615 loc = i.loc;
2616 }
2617
2618 and class_ ident_map c =
2619 let open Odoc_model.Lang.Class in
2620 let expansion = Opt.map (class_signature ident_map) c.expansion in
2621 {
2622 Class.source_loc = c.source_loc;
2623 source_loc_jane = c.source_loc_jane;
2624 doc = docs ident_map c.doc;
2625 virtual_ = c.virtual_;
2626 params = c.params;
2627 type_ = class_decl ident_map c.type_;
2628 expansion;
2629 }
2630
2631 and class_decl ident_map c =
2632 let open Odoc_model.Lang.Class in
2633 match c with
2634 | ClassType e -> Class.ClassType (class_type_expr ident_map e)
2635 | Arrow (lbl, e, d) ->
2636 Arrow (lbl, type_expression ident_map e, class_decl ident_map d)
2637
2638 and class_type_expr ident_map e =
2639 let open Odoc_model.Lang.ClassType in
2640 match e with
2641 | Constr (p, ts) ->
2642 ClassType.Constr
2643 (class_type_path ident_map p, List.map (type_expression ident_map) ts)
2644 | Signature s -> Signature (class_signature ident_map s)
2645
2646 and class_type ident_map t =
2647 let open Odoc_model.Lang.ClassType in
2648 let expansion = Opt.map (class_signature ident_map) t.expansion in
2649 {
2650 ClassType.source_loc = t.source_loc;
2651 source_loc_jane = t.source_loc_jane;
2652 doc = docs ident_map t.doc;
2653 virtual_ = t.virtual_;
2654 params = t.params;
2655 expr = class_type_expr ident_map t.expr;
2656 expansion;
2657 }
2658
2659 and class_signature ident_map sg =
2660 let open Odoc_model.Lang.ClassSignature in
2661 let items =
2662 List.map
2663 (function
2664 | Method m ->
2665 let id = Ident.Of_Identifier.method_ m.id in
2666 let m' = method_ ident_map m in
2667 ClassSignature.Method (id, m')
2668 | InstanceVariable i ->
2669 let id = Ident.Of_Identifier.instance_variable i.id in
2670 let i' = instance_variable ident_map i in
2671 ClassSignature.InstanceVariable (id, i')
2672 | Constraint cst -> Constraint (class_constraint ident_map cst)
2673 | Inherit e -> Inherit (inherit_ ident_map e)
2674 | Comment c -> Comment (docs_or_stop ident_map c))
2675 sg.items
2676 in
2677 {
2678 ClassSignature.self = Opt.map (type_expression ident_map) sg.self;
2679 items;
2680 doc = docs ident_map sg.doc;
2681 }
2682
2683 and method_ ident_map m =
2684 let open Odoc_model.Lang.Method in
2685 {
2686 Method.doc = docs ident_map m.doc;
2687 private_ = m.private_;
2688 virtual_ = m.virtual_;
2689 type_ = type_expression ident_map m.type_;
2690 }
2691
2692 and instance_variable ident_map i =
2693 {
2694 InstanceVariable.doc = docs ident_map i.doc;
2695 mutable_ = i.mutable_;
2696 virtual_ = i.virtual_;
2697 type_ = type_expression ident_map i.type_;
2698 }
2699
2700 and class_constraint ident_map cst =
2701 {
2702 ClassSignature.Constraint.doc = docs ident_map cst.doc;
2703 left = type_expression ident_map cst.left;
2704 right = type_expression ident_map cst.right;
2705 }
2706
2707 and inherit_ ident_map ih =
2708 {
2709 ClassSignature.Inherit.doc = docs ident_map ih.doc;
2710 expr = class_type_expr ident_map ih.expr;
2711 }
2712
2713 and module_substitution ident_map (t : Odoc_model.Lang.ModuleSubstitution.t) =
2714 {
2715 ModuleSubstitution.doc = docs ident_map t.doc;
2716 manifest = module_path ident_map t.manifest;
2717 }
2718
2719 and module_type_substitution ident_map
2720 (t : Odoc_model.Lang.ModuleTypeSubstitution.t) =
2721 {
2722 ModuleTypeSubstitution.doc = docs ident_map t.doc;
2723 manifest = module_type_expr ident_map t.manifest;
2724 }
2725
2726 and module_of_module_substitution ident_map
2727 (t : Odoc_model.Lang.ModuleSubstitution.t) =
2728 let manifest = module_path ident_map t.manifest in
2729 {
2730 Module.source_loc = None;
2731 source_loc_jane = None;
2732 doc = docs ident_map t.doc;
2733 type_ = Alias (manifest, None);
2734 canonical = None;
2735 hidden = false;
2736 }
2737
2738 and signature : _ -> Odoc_model.Lang.Signature.t -> Signature.t =
2739 fun ident_map items ->
2740 (* First we construct a list of brand new [Ident.t]s
2741 for each item in the signature *)
2742 let ident_map =
2743 map_of_idents (LocalIdents.signature items LocalIdents.empty) ident_map
2744 in
2745 (* Now we construct the Components for each item,
2746 converting all paths containing Identifiers pointing at
2747 our elements to local paths *)
2748 apply_sig_map ident_map items
2749
2750 and open_ ident_map o =
2751 Open.
2752 {
2753 expansion = apply_sig_map ident_map o.Odoc_model.Lang.Open.expansion;
2754 doc = docs ident_map o.Odoc_model.Lang.Open.doc;
2755 }
2756
2757 and removed_item ident_map r =
2758 let open Odoc_model.Lang.Signature in
2759 match r with
2760 | RModule (id, p) -> Signature.RModule (id, module_path ident_map p)
2761 | RType (id, texpr, eqn) ->
2762 RType (id, type_expression ident_map texpr, type_equation ident_map eqn)
2763 | RModuleType (id, m) -> RModuleType (id, module_type_expr ident_map m)
2764
2765 and apply_sig_map ident_map sg =
2766 let items =
2767 List.rev_map
2768 (let open Odoc_model.Lang.Signature in
2769 let open Odoc_model.Paths in
2770 function
2771 | Type (r, t) ->
2772 let id = Identifier.Maps.Type.find t.id ident_map.types in
2773 let t' = Delayed.put (fun () -> type_decl ident_map t) in
2774 Signature.Type (id, r, t')
2775 | TypeSubstitution t ->
2776 let id = Identifier.Maps.Type.find t.id ident_map.types in
2777 let t' = type_decl ident_map t in
2778 Signature.TypeSubstitution (id, t')
2779 | Module (r, m) ->
2780 let id =
2781 Identifier.Maps.Module.find
2782 (m.id :> Identifier.Module.t)
2783 ident_map.modules
2784 in
2785 let m' = Delayed.put (fun () -> module_ ident_map m) in
2786 Signature.Module (id, r, m')
2787 | ModuleSubstitution m ->
2788 let id = Identifier.Maps.Module.find m.id ident_map.modules in
2789 let m' = module_substitution ident_map m in
2790 Signature.ModuleSubstitution (id, m')
2791 | ModuleTypeSubstitution m ->
2792 let id =
2793 Identifier.Maps.ModuleType.find m.id ident_map.module_types
2794 in
2795 let m' = module_type_substitution ident_map m in
2796 Signature.ModuleTypeSubstitution (id, m')
2797 | ModuleType m ->
2798 let id =
2799 Identifier.Maps.ModuleType.find m.id ident_map.module_types
2800 in
2801 let m' = Delayed.put (fun () -> module_type ident_map m) in
2802 Signature.ModuleType (id, m')
2803 | Value v ->
2804 let id = Ident.Of_Identifier.value v.id in
2805 let v' = Delayed.put (fun () -> value ident_map v) in
2806 Signature.Value (id, v')
2807 | Comment c -> Comment (docs_or_stop ident_map c)
2808 | TypExt e -> TypExt (extension ident_map e)
2809 | Exception e ->
2810 let id = Ident.Of_Identifier.exception_ e.id in
2811 Exception (id, exception_ ident_map e)
2812 | Class (r, c) ->
2813 let id = Identifier.Maps.Class.find c.id ident_map.classes in
2814 Class (id, r, class_ ident_map c)
2815 | ClassType (r, c) ->
2816 let id =
2817 Identifier.Maps.ClassType.find c.id ident_map.class_types
2818 in
2819 ClassType (id, r, class_type ident_map c)
2820 | Open o -> Open (open_ ident_map o)
2821 | Include i -> Include (include_ ident_map i))
2822 sg.items
2823 |> List.rev
2824 in
2825 let removed = List.map (removed_item ident_map) sg.removed in
2826 { items; removed; compiled = sg.compiled; doc = docs ident_map sg.doc }
2827
2828 and block_element _ b :
2829 CComment.block_element Odoc_model.Comment.with_location =
2830 match b with
2831 | { Odoc_model.Location_.value = `Heading (attrs, label, text); location }
2832 ->
2833 let label = Ident.Of_Identifier.label label in
2834 Odoc_model.Location_.same b
2835 (`Heading { Label.attrs; label; text; location })
2836 | { value = `Tag _ | `Media _; _ } as t -> t
2837 | { value = #Odoc_model.Comment.nestable_block_element; _ } as n -> n
2838
2839 and docs ident_map d =
2840 {
2841 elements = List.map (block_element ident_map) d.elements;
2842 warnings_tag = d.warnings_tag;
2843 }
2844
2845 and docs_or_stop ident_map = function
2846 | `Docs d -> `Docs (docs ident_map d)
2847 | `Stop -> `Stop
2848end
2849
2850let module_of_functor_argument (arg : FunctorParameter.parameter) =
2851 {
2852 Module.source_loc = None;
2853 source_loc_jane = None;
2854 doc = { elements = []; warnings_tag = None };
2855 type_ = ModuleType arg.expr;
2856 canonical = None;
2857 hidden = false;
2858 }
2859
2860(** This is equivalent to {!Lang.extract_signature_doc}. *)
2861let extract_signature_doc (s : Signature.t) =
2862 match (s.doc, s.items) with
2863 | { elements = []; _ }, Include { expansion_; status = `Inline; _ } :: _ ->
2864 expansion_.doc
2865 | doc, _ -> doc