jon.recoil.org
this repo has no description
1(*
2 * Copyright (c) 2014 Leo White <lpw25@cl.cam.ac.uk>
3 *
4 * Permission to use, copy, modify, and distribute this software for any
5 * purpose with or without fee is hereby granted, provided that the above
6 * copyright notice and this permission notice appear in all copies.
7 *
8 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 *)
16
17module Ocaml_ident = Ident
18module Ocaml_env = Env
19
20open Names
21
22module Identifier = struct
23 type 'a id = 'a Paths_types.id = { iv : 'a; ihash : int; ikey : string }
24
25 module Id = Paths_types.Identifier
26
27 type t = Id.any
28
29 type t_pv = Id.any_pv
30
31 let rec name_aux : t -> string =
32 fun x ->
33 match x.iv with
34 | `Root (_, name) -> ModuleName.to_string name
35 | `Page (_, name) -> PageName.to_string name
36 | `LeafPage (_, name) -> PageName.to_string name
37 | `Module (_, name) -> ModuleName.to_string name
38 | `Parameter (_, name) -> ModuleName.to_string name
39 | `Result x -> name_aux (x :> t)
40 | `ModuleType (_, name) -> ModuleTypeName.to_string name
41 | `Type (_, name) -> TypeName.to_string name
42 | `Constructor (_, name) -> ConstructorName.to_string name
43 | `Field (_, name) -> FieldName.to_string name
44 | `UnboxedField (_, name) -> UnboxedFieldName.to_string name
45 | `Extension (_, name) -> ExtensionName.to_string name
46 | `ExtensionDecl (_, _, name) -> ExtensionName.to_string name
47 | `Exception (_, name) -> ExceptionName.to_string name
48 | `Value (_, name) -> ValueName.to_string name
49 | `Class (_, name) -> TypeName.to_string name
50 | `ClassType (_, name) -> TypeName.to_string name
51 | `Method (_, name) -> MethodName.to_string name
52 | `InstanceVariable (_, name) -> InstanceVariableName.to_string name
53 | `Label (_, name) -> LabelName.to_string name
54 | `SourcePage (_, name) -> name
55 | `SourceLocation (x, anchor) ->
56 name_aux (x :> t) ^ "#" ^ DefName.to_string anchor
57 | `SourceLocationMod x -> name_aux (x :> t)
58 | `SourceLocationInternal (x, anchor) ->
59 name_aux (x :> t) ^ "#" ^ LocalName.to_string anchor
60 | `AssetFile (_, name) -> AssetName.to_string name
61
62 let rec is_hidden : t -> bool =
63 fun x ->
64 match x.iv with
65 | `Root (_, name) -> ModuleName.is_hidden name
66 | `Page (_, _) -> false
67 | `LeafPage (_, _) -> false
68 | `Module (_, name) -> ModuleName.is_hidden name
69 | `Parameter (_, name) -> ModuleName.is_hidden name
70 | `Result x -> is_hidden (x :> t)
71 | `ModuleType (_, name) -> ModuleTypeName.is_hidden name
72 | `Type (_, name) -> TypeName.is_hidden name
73 | `Constructor (parent, _) -> is_hidden (parent :> t)
74 | `Field (parent, _) -> is_hidden (parent :> t)
75 | `UnboxedField (parent, _) -> is_hidden (parent :> t)
76 | `Extension (parent, _) -> is_hidden (parent :> t)
77 | `ExtensionDecl (parent, _, _) -> is_hidden (parent :> t)
78 | `Exception (parent, _) -> is_hidden (parent :> t)
79 | `Value (_, name) -> ValueName.is_hidden name
80 | `Class (_, name) -> TypeName.is_hidden name
81 | `ClassType (_, name) -> TypeName.is_hidden name
82 | `Method (parent, _) -> is_hidden (parent :> t)
83 | `InstanceVariable (parent, _) -> is_hidden (parent :> t)
84 | `Label (parent, _) -> is_hidden (parent :> t)
85 | `SourceLocationMod _ | `SourceLocation _ | `SourcePage _
86 | `SourceLocationInternal _ | `AssetFile _ ->
87 false
88
89 let name : [< t_pv ] id -> string = fun n -> name_aux (n :> t)
90
91 let rec full_name_aux : t -> string list =
92 fun x ->
93 match x.iv with
94 | `Root (_, name) -> [ ModuleName.to_string name ]
95 | `Page (None, name) -> [ PageName.to_string name ]
96 | `Page (Some parent, name) ->
97 PageName.to_string name :: full_name_aux (parent :> t)
98 | `LeafPage (None, name) -> [ PageName.to_string name ]
99 | `LeafPage (Some parent, name) ->
100 PageName.to_string name :: full_name_aux (parent :> t)
101 | `Module (parent, name) ->
102 ModuleName.to_string name :: full_name_aux (parent :> t)
103 | `Parameter (parent, name) ->
104 ModuleName.to_string name :: full_name_aux (parent :> t)
105 | `Result x -> full_name_aux (x :> t)
106 | `ModuleType (parent, name) ->
107 ModuleTypeName.to_string name :: full_name_aux (parent :> t)
108 | `Type (parent, name) ->
109 TypeName.to_string name :: full_name_aux (parent :> t)
110 | `Constructor (parent, name) ->
111 ConstructorName.to_string name :: full_name_aux (parent :> t)
112 | `Field (parent, name) ->
113 FieldName.to_string name :: full_name_aux (parent :> t)
114 | `UnboxedField (parent, name) ->
115 UnboxedFieldName.to_string name :: full_name_aux (parent :> t)
116 | `Extension (parent, name) ->
117 ExtensionName.to_string name :: full_name_aux (parent :> t)
118 | `ExtensionDecl (parent, _, name) ->
119 ExtensionName.to_string name :: full_name_aux (parent :> t)
120 | `Exception (parent, name) ->
121 ExceptionName.to_string name :: full_name_aux (parent :> t)
122 | `Value (parent, name) ->
123 ValueName.to_string name :: full_name_aux (parent :> t)
124 | `Class (parent, name) ->
125 TypeName.to_string name :: full_name_aux (parent :> t)
126 | `ClassType (parent, name) ->
127 TypeName.to_string name :: full_name_aux (parent :> t)
128 | `Method (parent, name) ->
129 MethodName.to_string name :: full_name_aux (parent :> t)
130 | `InstanceVariable (parent, name) ->
131 InstanceVariableName.to_string name :: full_name_aux (parent :> t)
132 | `Label (parent, name) ->
133 LabelName.to_string name :: full_name_aux (parent :> t)
134 | `SourceLocation (parent, name) ->
135 DefName.to_string name :: full_name_aux (parent :> t)
136 | `SourceLocationInternal (parent, name) ->
137 LocalName.to_string name :: full_name_aux (parent :> t)
138 | `SourceLocationMod name -> full_name_aux (name :> t)
139 | `SourcePage (parent, name) -> name :: full_name_aux (parent :> t)
140 | `AssetFile (parent, name) ->
141 AssetName.to_string name :: full_name_aux (parent :> t)
142
143 let fullname : [< t_pv ] id -> string list =
144 fun n -> List.rev @@ full_name_aux (n :> t)
145
146 let is_hidden : [< t_pv ] id -> bool = fun n -> is_hidden (n :> t)
147
148 let rec label_parent_aux =
149 let open Id in
150 fun (n : non_src) ->
151 match n with
152 | { iv = `Result i; _ } -> label_parent_aux (i :> non_src)
153 | { iv = `Root _; _ } as p -> (p :> label_parent)
154 | { iv = `Page _; _ } as p -> (p :> label_parent)
155 | { iv = `LeafPage _; _ } as p -> (p :> label_parent)
156 | { iv = `Module (p, _); _ }
157 | { iv = `ModuleType (p, _); _ }
158 | { iv = `Parameter (p, _); _ }
159 | { iv = `Class (p, _); _ }
160 | { iv = `ClassType (p, _); _ }
161 | { iv = `Type (p, _); _ }
162 | { iv = `Extension (p, _); _ }
163 | { iv = `ExtensionDecl (p, _, _); _ }
164 | { iv = `Exception (p, _); _ }
165 | { iv = `Value (p, _); _ } ->
166 (p : signature :> label_parent)
167 | { iv = `Label (p, _); _ } -> p
168 | { iv = `Method (p, _); _ } | { iv = `InstanceVariable (p, _); _ } ->
169 (p : class_signature :> label_parent)
170 | { iv = `Constructor (p, _); _ } -> (p : datatype :> label_parent)
171 | { iv = `Field (p, _); _ } -> (p : field_parent :> label_parent)
172 | { iv = `UnboxedField (p, _); _ } -> (p : unboxed_field_parent :> label_parent)
173
174 let label_parent n = label_parent_aux (n :> Id.non_src)
175
176 let equal x y = x.ihash = y.ihash && x.ikey = y.ikey
177
178 let hash x = x.ihash
179
180 let compare x y = compare x.ikey y.ikey
181
182 type any = t
183
184 type any_pv = t_pv
185
186 module type IdSig = sig
187 type t
188 type t_pv
189 val equal : t -> t -> bool
190 val hash : t -> int
191 val compare : t -> t -> int
192 end
193
194 module Any = struct
195 type t = any
196 type t_pv = any_pv
197 let equal = equal
198 let hash = hash
199 let compare = compare
200 end
201
202 module Signature = struct
203 type t = Id.signature
204 type t_pv = Id.signature_pv
205 let equal = equal
206 let hash = hash
207 let compare = compare
208 end
209
210 module ClassSignature = struct
211 type t = Id.class_signature
212 type t_pv = Id.class_signature_pv
213 let equal = equal
214 let hash = hash
215 let compare = compare
216 end
217
218 module DataType = struct
219 type t = Id.datatype
220 type t_pv = Id.datatype_pv
221 end
222
223 module FieldParent = struct
224 type t = Paths_types.Identifier.field_parent
225 type t_pv = Paths_types.Identifier.field_parent_pv
226 end
227
228 module UnboxedFieldParent = struct
229 type t = Paths_types.Identifier.unboxed_field_parent
230 type t_pv = Paths_types.Identifier.unboxed_field_parent_pv
231 end
232
233 module LabelParent = struct
234 type t = Id.label_parent
235 type t_pv = Id.label_parent_pv
236 let equal = equal
237 let hash = hash
238 let compare = compare
239 end
240
241 module RootModule = struct
242 type t = Id.root_module
243 type t_pv = Id.root_module_pv
244 let equal = equal
245 let hash = hash
246 let compare = compare
247 end
248
249 module Module = struct
250 type t = Id.module_
251 type t_pv = Id.module_pv
252 let equal = equal
253 let hash = hash
254 let compare = compare
255 end
256
257 module FunctorParameter = struct
258 type t = Id.functor_parameter
259 type t_pv = Id.functor_parameter_pv
260 let equal = equal
261 let hash = hash
262 let compare = compare
263
264 let functor_arg_pos { iv = `Parameter (p, _); _ } =
265 let rec inner_sig = function
266 | `Result { iv = p; _ } -> 1 + inner_sig p
267 | `Module _ | `ModuleType _ | `Root _ | `Parameter _ -> 1
268 in
269 inner_sig p.iv
270 end
271
272 module FunctorResult = struct
273 type t = Id.functor_result
274 type t_pv = Id.functor_result_pv
275 end
276
277 module ModuleType = struct
278 type t = Id.module_type
279 type t_pv = Id.module_type_pv
280 let equal = equal
281 let hash = hash
282 let compare = compare
283 end
284
285 module Type = struct
286 type t = Id.type_
287 type t_pv = Id.type_pv
288 let equal = equal
289 let hash = hash
290 let compare = compare
291 end
292
293 module Constructor = struct
294 type t = Id.constructor
295 type t_pv = Id.constructor_pv
296 end
297
298 module Field = struct
299 type t = Id.field
300 type t_pv = Id.field_pv
301 end
302
303 module UnboxedField = struct
304 type t = Id.unboxed_field
305 type t_pv = Id.unboxed_field_pv
306 end
307
308 module Extension = struct
309 type t = Id.extension
310 type t_pv = Id.extension_pv
311 end
312
313 module ExtensionDecl = struct
314 type t = Paths_types.Identifier.extension_decl
315
316 type t_pv = Paths_types.Identifier.extension_decl_pv
317
318 let equal = equal
319
320 let hash = hash
321
322 let compare = compare
323 end
324
325 module Exception = struct
326 type t = Id.exception_
327 type t_pv = Id.exception_pv
328 end
329
330 module Value = struct
331 type t = Id.value
332 type t_pv = Id.value_pv
333 end
334
335 module Class = struct
336 type t = Id.class_
337 type t_pv = Id.class_pv
338 let equal = equal
339 let hash = hash
340 let compare = compare
341 end
342
343 module ClassType = struct
344 type t = Id.class_type
345 type t_pv = Id.class_type_pv
346 let equal = equal
347 let hash = hash
348 let compare = compare
349 end
350
351 module Method = struct
352 type t = Id.method_
353 type t_pv = Id.method_pv
354 end
355
356 module InstanceVariable = struct
357 type t = Id.instance_variable
358 type t_pv = Id.instance_variable_pv
359 end
360
361 module Label = struct
362 type t = Paths_types.Identifier.label
363 type t_pv = Paths_types.Identifier.label_pv
364 let equal = equal
365 let hash = hash
366 let compare = compare
367 end
368
369 module Page = struct
370 type t = Id.page
371 type t_pv = Id.page_pv
372 end
373
374 module LeafPage = struct
375 type t = Id.leaf_page
376 type t_pv = Id.leaf_page_pv
377 let equal = equal
378 let hash = hash
379 end
380
381 module ContainerPage = struct
382 type t = Id.container_page
383 type t_pv = Id.container_page_pv
384 let equal = equal
385 let hash = hash
386 end
387
388 module NonSrc = struct
389 type t = Paths_types.Identifier.non_src
390 type t_pv = Paths_types.Identifier.non_src_pv
391
392 let equal x y = x.ihash = y.ihash && x.ikey = y.ikey
393
394 let hash x = x.ihash
395 end
396
397 module SourcePage = struct
398 type t = Id.source_page
399 type t_pv = Id.source_page_pv
400
401 let equal = equal
402 let hash = hash
403 end
404
405 module SourceLocation = struct
406 type t = Paths_types.Identifier.source_location
407 type t_pv = Paths_types.Identifier.source_location_pv
408 end
409
410 module AssetFile = struct
411 type t = Id.asset_file
412 type t_pv = Id.asset_file_pv
413 end
414
415 module OdocId = struct
416 type t = Id.odoc_id
417 type t_pv = Id.odoc_id_pv
418 end
419
420 module Path = struct
421 module Module = struct
422 type t = Id.path_module
423 type t_pv = Id.path_module_pv
424 let equal = equal
425 let hash = hash
426 let compare = compare
427 end
428
429 module ModuleType = struct
430 type t = Id.path_module_type
431 type t_pv = Id.module_type_pv
432 let equal = equal
433 let hash = hash
434 let compare = compare
435 end
436
437 module Type = struct
438 type t = Id.path_type
439 type t_pv = Id.path_type_pv
440 let equal = equal
441 let hash = hash
442 let compare = compare
443 end
444
445 module Value = struct
446 type t = Id.path_value
447 type t_pv = Id.value_pv
448 let equal = equal
449 let hash = hash
450 let compare = compare
451 end
452
453 module ClassType = struct
454 type t = Id.path_class_type
455 type t_pv = Id.path_class_type_pv
456 let equal = equal
457 let hash = hash
458 let compare = compare
459 end
460
461 type t = Id.path_any
462 end
463
464 module Maps = struct
465 module Any = Map.Make (Any)
466 module FunctorParameter = Map.Make (FunctorParameter)
467 module Module = Map.Make (Module)
468 module ModuleType = Map.Make (ModuleType)
469 module Type = Map.Make (Type)
470 module Class = Map.Make (Class)
471 module ClassType = Map.Make (ClassType)
472 module Label = Map.Make (Label)
473
474 module Path = struct
475 module Module = Map.Make (Path.Module)
476 module ModuleType = Map.Make (Path.ModuleType)
477 module Type = Map.Make (Path.Type)
478 module ClassType = Map.Make (Path.ClassType)
479 end
480 end
481
482 module Mk = struct
483 let mk_fresh to_str ty f x =
484 let ikey = Printf.sprintf "%s_%s" ty (to_str x) in
485 let ihash = Hashtbl.hash ikey in
486 { iv = f x; ihash; ikey }
487
488 let mk_parent to_str ty f (parent, x) =
489 let ikey = Printf.sprintf "%s_%s.%s" ty (to_str x) parent.ikey in
490 let ihash = Hashtbl.hash ikey in
491
492 { iv = f (parent, x); ihash; ikey }
493
494 let mk_parent_opt to_str ty f (parent_opt, x) =
495 let ikey =
496 match parent_opt with
497 | None -> Printf.sprintf "%s_%s" ty (to_str x)
498 | Some p -> Printf.sprintf "%s_%s.%s" ty (to_str x) p.ikey
499 in
500 let ihash = Hashtbl.hash ikey in
501 { iv = f (parent_opt, x); ihash; ikey }
502
503 let page :
504 ContainerPage.t option * PageName.t ->
505 [> `Page of ContainerPage.t option * PageName.t ] id =
506 mk_parent_opt PageName.to_string "p" (fun (p, n) -> `Page (p, n))
507
508 let leaf_page :
509 ContainerPage.t option * PageName.t ->
510 [> `LeafPage of ContainerPage.t option * PageName.t ] id =
511 mk_parent_opt PageName.to_string "lp" (fun (p, n) -> `LeafPage (p, n))
512
513 let asset_file : Page.t * AssetName.t -> AssetFile.t =
514 mk_parent AssetName.to_string "asset" (fun (p, n) -> `AssetFile (p, n))
515
516 let source_page (container_page, name) =
517 mk_parent
518 (fun x -> x)
519 "sp"
520 (fun (p, rp) -> `SourcePage (p, rp))
521 (container_page, name)
522
523 let root :
524 ContainerPage.t option * ModuleName.t ->
525 [> `Root of ContainerPage.t option * ModuleName.t ] id =
526 mk_parent_opt ModuleName.to_string "r" (fun (p, n) -> `Root (p, n))
527
528 let implementation =
529 mk_fresh
530 (fun s -> s)
531 "impl"
532 (fun s -> `Implementation (ModuleName.make_std s))
533
534 let module_ :
535 Signature.t * ModuleName.t ->
536 [> `Module of Signature.t * ModuleName.t ] id =
537 mk_parent ModuleName.to_string "m" (fun (p, n) -> `Module (p, n))
538
539 let parameter :
540 Signature.t * ModuleName.t ->
541 [> `Parameter of Signature.t * ModuleName.t ] id =
542 mk_parent ModuleName.to_string "p" (fun (p, n) -> `Parameter (p, n))
543
544 let result : Signature.t -> [> `Result of Signature.t ] id =
545 fun s ->
546 mk_parent (fun () -> "__result__") "" (fun (s, ()) -> `Result s) (s, ())
547
548 let module_type :
549 Signature.t * ModuleTypeName.t ->
550 [> `ModuleType of Signature.t * ModuleTypeName.t ] id =
551 mk_parent ModuleTypeName.to_string "mt" (fun (p, n) -> `ModuleType (p, n))
552
553 let class_ :
554 Signature.t * TypeName.t -> [> `Class of Signature.t * TypeName.t ] id =
555 mk_parent TypeName.to_string "c" (fun (p, n) -> `Class (p, n))
556
557 let class_type :
558 Signature.t * TypeName.t ->
559 [> `ClassType of Signature.t * TypeName.t ] id =
560 mk_parent TypeName.to_string "ct" (fun (p, n) -> `ClassType (p, n))
561
562 let type_ :
563 Signature.t * TypeName.t -> [> `Type of Signature.t * TypeName.t ] id =
564 mk_parent TypeName.to_string "t" (fun (p, n) -> `Type (p, n))
565
566 let core_type =
567 mk_fresh (fun s -> s) "coret" (fun s -> `CoreType (TypeName.make_std s))
568
569 let constructor :
570 DataType.t * ConstructorName.t ->
571 [> `Constructor of DataType.t * ConstructorName.t ] id =
572 mk_parent ConstructorName.to_string "ctor" (fun (p, n) ->
573 `Constructor (p, n))
574
575 let field :
576 FieldParent.t * FieldName.t ->
577 [> `Field of FieldParent.t * FieldName.t ] id =
578 mk_parent FieldName.to_string "fld" (fun (p, n) -> `Field (p, n))
579
580 let unboxed_field :
581 UnboxedFieldParent.t * UnboxedFieldName.t ->
582 [> `UnboxedField of UnboxedFieldParent.t * UnboxedFieldName.t ] id =
583 mk_parent UnboxedFieldName.to_string "unboxedfld" (fun (p, n) -> `UnboxedField (p, n))
584
585 let extension :
586 Signature.t * ExtensionName.t ->
587 [> `Extension of Signature.t * ExtensionName.t ] id =
588 mk_parent ExtensionName.to_string "extn" (fun (p, n) -> `Extension (p, n))
589
590 let extension_decl :
591 Signature.t * (ExtensionName.t * ExtensionName.t) ->
592 [> `ExtensionDecl of Signature.t * ExtensionName.t * ExtensionName.t ]
593 id =
594 mk_parent
595 (fun (n, m) ->
596 ExtensionName.to_string n ^ "." ^ ExtensionName.to_string m)
597 "extn-decl"
598 (fun (p, (n, m)) -> `ExtensionDecl (p, n, m))
599
600 let exception_ :
601 Signature.t * ExceptionName.t ->
602 [> `Exception of Signature.t * ExceptionName.t ] id =
603 mk_parent ExceptionName.to_string "exn" (fun (p, n) -> `Exception (p, n))
604
605 let value :
606 Signature.t * ValueName.t -> [> `Value of Signature.t * ValueName.t ] id
607 =
608 mk_parent ValueName.to_string "v" (fun (p, n) -> `Value (p, n))
609
610 let method_ :
611 ClassSignature.t * MethodName.t ->
612 [> `Method of ClassSignature.t * MethodName.t ] id =
613 mk_parent MethodName.to_string "m" (fun (p, n) -> `Method (p, n))
614
615 let instance_variable :
616 ClassSignature.t * InstanceVariableName.t ->
617 [> `InstanceVariable of ClassSignature.t * InstanceVariableName.t ] id =
618 mk_parent InstanceVariableName.to_string "iv" (fun (p, n) ->
619 `InstanceVariable (p, n))
620
621 let label :
622 LabelParent.t * LabelName.t ->
623 [> `Label of LabelParent.t * LabelName.t ] id =
624 mk_parent LabelName.to_string "l" (fun (p, n) -> `Label (p, n))
625
626 let source_location :
627 SourcePage.t * DefName.t ->
628 [> `SourceLocation of SourcePage.t * DefName.t ] id =
629 mk_parent DefName.to_string "sl" (fun (p, n) -> `SourceLocation (p, n))
630
631 let source_location_mod :
632 SourcePage.t -> [> `SourceLocationMod of SourcePage.t ] id =
633 fun s ->
634 mk_parent
635 (fun () -> "__slm__")
636 ""
637 (fun (s, ()) -> `SourceLocationMod s)
638 (s, ())
639
640 let source_location_int :
641 SourcePage.t * LocalName.t ->
642 [> `SourceLocationInternal of SourcePage.t * LocalName.t ] id =
643 mk_parent LocalName.to_string "sli" (fun (p, n) ->
644 `SourceLocationInternal (p, n))
645 end
646
647 (* Counter for generating unique synthetic parents for include expressions.
648 Items inside an include's module type expression need a different parent
649 to avoid identifier conflicts with items in the enclosing signature. *)
650 let include_parent_counter = ref 0
651
652 (* Create a synthetic parent identifier for items inside an include's module
653 type expression. Uses a lowercase module name (illegal in normal OCaml)
654 to ensure no clashes with real identifiers. *)
655 let fresh_include_parent (parent : Signature.t) : Signature.t =
656 incr include_parent_counter;
657 let name = Printf.sprintf "include%d_" !include_parent_counter in
658 (Mk.module_ (parent, ModuleName.make_std name) :> Signature.t)
659
660 module Hashtbl = struct
661 module Any = Hashtbl.Make (Any)
662 module ContainerPage = Hashtbl.Make (ContainerPage)
663 module LeafPage = Hashtbl.Make (LeafPage)
664 module RootModule = Hashtbl.Make (RootModule)
665 module SourcePage = Hashtbl.Make (SourcePage)
666 end
667end
668
669module Path = struct
670 type t = Paths_types.Path.any
671
672 let rec is_resolved_hidden :
673 weak_canonical_test:bool -> Paths_types.Resolved_path.any -> bool =
674 fun ~weak_canonical_test x ->
675 let open Paths_types.Resolved_path in
676 let rec inner : Paths_types.Resolved_path.any -> bool = function
677 | `Identifier { iv = `ModuleType (_, m); _ }
678 when Names.ModuleTypeName.is_hidden m ->
679 true
680 | `Identifier { iv = `Type (_, t); _ } when Names.TypeName.is_hidden t ->
681 true
682 | `Identifier { iv = `Module (_, m); _ } when Names.ModuleName.is_hidden m
683 ->
684 true
685 | `Identifier _ -> false
686 | `Canonical (_, `Resolved _) -> false
687 | `Canonical (x, _) ->
688 (not weak_canonical_test) && inner (x : module_ :> any)
689 | `Hidden _ -> true
690 | `Subst (p1, p2) ->
691 inner (p1 : module_type :> any) || inner (p2 : module_ :> any)
692 | `Module (p, _) -> inner (p : module_ :> any)
693 | `Apply (p, _) -> inner (p : module_ :> any)
694 | `ModuleType (_, m) when Names.ModuleTypeName.is_hidden m -> true
695 | `ModuleType (p, _) -> inner (p : module_ :> any)
696 | `Type (_, t) when Names.TypeName.is_hidden t -> true
697 | `CoreType t -> Names.TypeName.is_hidden t
698 | `Type (p, _) -> inner (p : module_ :> any)
699 | `Value (_, t) when Names.ValueName.is_hidden t -> true
700 | `Value (p, _) -> inner (p : module_ :> any)
701 | `Class (p, _) -> inner (p : module_ :> any)
702 | `ClassType (p, _) -> inner (p : module_ :> any)
703 | `Alias (dest, `Resolved src) ->
704 inner (dest : module_ :> any) && inner (src : module_ :> any)
705 | `Alias (dest, src) ->
706 inner (dest : module_ :> any)
707 && is_path_hidden (src :> Paths_types.Path.any)
708 | `AliasModuleType (p1, p2) ->
709 inner (p1 : module_type :> any) && inner (p2 : module_type :> any)
710 | `SubstT (p1, p2) -> inner (p1 :> any) || inner (p2 :> any)
711 | `Substituted m -> inner (m :> any)
712 | `SubstitutedMT m -> inner (m :> any)
713 | `SubstitutedT m -> inner (m :> any)
714 | `SubstitutedCT m -> inner (m :> any)
715 | `CanonicalModuleType (_, `Resolved _) -> false
716 | `CanonicalModuleType (x, _) -> inner (x : module_type :> any)
717 | `CanonicalType (_, `Resolved _) -> false
718 | `CanonicalType (x, _) -> inner (x : type_ :> any)
719 | `OpaqueModule m -> inner (m :> any)
720 | `OpaqueModuleType mt -> inner (mt :> any)
721 in
722 inner x
723
724 and is_path_hidden : Paths_types.Path.any -> bool =
725 let open Paths_types.Path in
726 function
727 | `Resolved r -> is_resolved_hidden ~weak_canonical_test:false r
728 | `Identifier (_, hidden) -> hidden
729 | `Substituted r -> is_path_hidden (r :> any)
730 | `SubstitutedMT r -> is_path_hidden (r :> any)
731 | `SubstitutedT r -> is_path_hidden (r :> any)
732 | `SubstitutedCT r -> is_path_hidden (r :> any)
733 | `Root s -> ModuleName.is_hidden s
734 | `Forward _ -> false
735 | `Dot (p, n) ->
736 ModuleName.is_hidden n || is_path_hidden (p : module_ :> any)
737 | `DotMT (p, n) ->
738 ModuleTypeName.is_hidden n || is_path_hidden (p : module_ :> any)
739 | `DotT (p, n) ->
740 TypeName.is_hidden n || is_path_hidden (p : module_ :> any)
741 | `DotV (p, n) ->
742 ValueName.is_hidden n || is_path_hidden (p : module_ :> any)
743 | `Apply (p1, p2) ->
744 is_path_hidden (p1 : module_ :> any)
745 || is_path_hidden (p2 : module_ :> any)
746
747 module Resolved = struct
748 type t = Paths_types.Resolved_path.any
749
750 let rec parent_module_type_identifier :
751 Paths_types.Resolved_path.module_type -> Identifier.ModuleType.t option
752 = function
753 | `Identifier id -> Some (id : Identifier.ModuleType.t)
754 | `ModuleType (m, n) -> (
755 match parent_module_identifier m with
756 | None -> None
757 | Some p -> Some (Identifier.Mk.module_type (p, n)))
758 | `SubstT (m, _n) -> parent_module_type_identifier m
759 | `CanonicalModuleType (_, `Resolved p) -> parent_module_type_identifier p
760 | `CanonicalModuleType (p, _) -> parent_module_type_identifier p
761 | `OpaqueModuleType mt -> parent_module_type_identifier mt
762 | `SubstitutedMT m -> parent_module_type_identifier m
763 | `AliasModuleType (sub, orig) ->
764 if is_resolved_hidden ~weak_canonical_test:false (sub :> t) then
765 parent_module_type_identifier orig
766 else parent_module_type_identifier sub
767
768 and parent_module_identifier :
769 Paths_types.Resolved_path.module_ -> Identifier.Signature.t option =
770 function
771 | `Identifier id ->
772 Some (id : Identifier.Path.Module.t :> Identifier.Signature.t)
773 | `Subst (sub, _) ->
774 (parent_module_type_identifier sub :> Identifier.Signature.t option)
775 | `Hidden _ -> None
776 | `Module (m, n) -> (
777 match parent_module_identifier m with
778 | None -> None
779 | Some p -> Some (Identifier.Mk.module_ (p, n)))
780 | `Canonical (_, `Resolved p) -> parent_module_identifier p
781 | `Canonical (p, _) -> parent_module_identifier p
782 | `Apply (m, _) -> parent_module_identifier m
783 | `Alias (dest, `Resolved src) ->
784 if is_resolved_hidden ~weak_canonical_test:false (dest :> t) then
785 parent_module_identifier src
786 else parent_module_identifier dest
787 | `Alias (dest, _src) -> parent_module_identifier dest
788 | `Substituted m -> parent_module_identifier m
789 | `OpaqueModule m -> parent_module_identifier m
790
791 module Module = struct
792 type t = Paths_types.Resolved_path.module_
793
794 let is_hidden m =
795 is_resolved_hidden (m : t :> Paths_types.Resolved_path.any)
796 end
797
798 module ModuleType = struct
799 type t = Paths_types.Resolved_path.module_type
800
801 let identifier : t -> Identifier.ModuleType.t option =
802 parent_module_type_identifier
803 end
804
805 module Type = struct
806 type t = Paths_types.Resolved_path.type_
807 end
808
809 module Value = struct
810 type t = Paths_types.Resolved_path.value
811 end
812
813 module ClassType = struct
814 type t = Paths_types.Resolved_path.class_type
815 end
816
817 let rec identifier : t -> Identifier.t option =
818 let parent p f =
819 match parent_module_identifier p with
820 | None -> None
821 | Some id -> Some (f id :> Identifier.t)
822 in
823 function
824 | `Identifier id -> Some id
825 | `CoreType _ -> None
826 | `Subst (sub, _) -> identifier (sub :> t)
827 | `Hidden _p -> None
828 | `Module (m, n) -> parent m (fun p -> Identifier.Mk.module_ (p, n))
829 | `Canonical (_, `Resolved p) -> identifier (p :> t)
830 | `Canonical (p, _) -> identifier (p :> t)
831 | `Apply (m, _) -> identifier (m :> t)
832 | `Type (m, n) -> parent m (fun p -> Identifier.Mk.type_ (p, n))
833 | `Value (m, n) -> parent m (fun p -> Identifier.Mk.value (p, n))
834 | `ModuleType (m, n) ->
835 parent m (fun p -> Identifier.Mk.module_type (p, n))
836 | `Class (m, n) -> parent m (fun p -> Identifier.Mk.class_ (p, n))
837 | `ClassType (m, n) -> parent m (fun p -> Identifier.Mk.class_type (p, n))
838 | `Alias (dest, `Resolved src) ->
839 if is_resolved_hidden ~weak_canonical_test:false (dest :> t) then
840 identifier (src :> t)
841 else identifier (dest :> t)
842 | `Alias (dest, _src) -> identifier (dest :> t)
843 | `AliasModuleType (sub, orig) ->
844 if is_resolved_hidden ~weak_canonical_test:false (sub :> t) then
845 identifier (orig :> t)
846 else identifier (sub :> t)
847 | `SubstT (p, _) -> identifier (p :> t)
848 | `CanonicalModuleType (_, `Resolved p) -> identifier (p :> t)
849 | `CanonicalModuleType (p, _) -> identifier (p :> t)
850 | `CanonicalType (_, `Resolved p) -> identifier (p :> t)
851 | `CanonicalType (p, _) -> identifier (p :> t)
852 | `OpaqueModule m -> identifier (m :> t)
853 | `OpaqueModuleType mt -> identifier (mt :> t)
854 | `Substituted m -> identifier (m :> t)
855 | `SubstitutedMT m -> identifier (m :> t)
856 | `SubstitutedCT m -> identifier (m :> t)
857 | `SubstitutedT m -> identifier (m :> t)
858
859 let is_hidden r = is_resolved_hidden ~weak_canonical_test:false r
860 end
861
862 module Module = struct
863 type t = Paths_types.Path.module_
864 end
865
866 module ModuleType = struct
867 type t = Paths_types.Path.module_type
868 end
869
870 module Type = struct
871 type t = Paths_types.Path.type_
872 end
873
874 module Value = struct
875 type t = Paths_types.Path.value
876 end
877
878 module ClassType = struct
879 type t = Paths_types.Path.class_type
880 end
881
882 let is_hidden = is_path_hidden
883end
884
885module Fragment = struct
886 module Resolved = struct
887 type t = Paths_types.Resolved_fragment.any
888
889 type root = Paths_types.Resolved_fragment.root
890
891 module Signature = struct
892 type t = Paths_types.Resolved_fragment.signature
893
894 let rec sgidentifier : t -> Identifier.Signature.t option = function
895 | `Root (`ModuleType i) ->
896 (Path.Resolved.parent_module_type_identifier i
897 :> Identifier.Signature.t option)
898 | `Root (`Module i) -> Path.Resolved.parent_module_identifier i
899 | `Subst (s, _) ->
900 (Path.Resolved.parent_module_type_identifier s
901 :> Identifier.Signature.t option)
902 | `Alias (i, _) -> Path.Resolved.parent_module_identifier i
903 | `Module (m, n) -> (
904 match sgidentifier m with
905 | None -> None
906 | Some p -> Some (Identifier.Mk.module_ (p, n)))
907 | `OpaqueModule m -> sgidentifier (m :> t)
908 end
909
910 module Module = struct
911 type t = Paths_types.Resolved_fragment.module_
912 end
913
914 module ModuleType = struct
915 type t = Paths_types.Resolved_fragment.module_type
916 end
917
918 module Type = struct
919 type t = Paths_types.Resolved_fragment.type_
920 end
921
922 type leaf = Paths_types.Resolved_fragment.leaf
923
924 let rec identifier : t -> Identifier.t option = function
925 | `Root (`ModuleType _r) -> assert false
926 | `Root (`Module _r) -> assert false
927 | `Subst (s, _) ->
928 (Path.Resolved.ModuleType.identifier s :> Identifier.t option)
929 | `Alias (p, _) ->
930 (Path.Resolved.parent_module_identifier p :> Identifier.t option)
931 | `Module (m, n) -> (
932 match Signature.sgidentifier m with
933 | None -> None
934 | Some p -> Some (Identifier.Mk.module_ (p, n)))
935 | `Module_type (m, n) -> (
936 match Signature.sgidentifier m with
937 | None -> None
938 | Some p -> Some (Identifier.Mk.module_type (p, n)))
939 | `Type (m, n) -> (
940 match Signature.sgidentifier m with
941 | None -> None
942 | Some p -> Some (Identifier.Mk.type_ (p, n)))
943 | `Class (m, n) -> (
944 match Signature.sgidentifier m with
945 | None -> None
946 | Some p -> Some (Identifier.Mk.class_ (p, n)))
947 | `ClassType (m, n) -> (
948 match Signature.sgidentifier m with
949 | None -> None
950 | Some p -> Some (Identifier.Mk.class_type (p, n)))
951 | `OpaqueModule m -> identifier (m :> t)
952
953 let rec is_hidden : t -> bool = function
954 | `Root (`ModuleType r) -> Path.Resolved.(is_hidden (r :> t))
955 | `Root (`Module r) -> Path.Resolved.(is_hidden (r :> t))
956 | `Subst (s, _) -> Path.Resolved.(is_hidden (s :> t))
957 | `Alias (s, _) -> Path.Resolved.(is_hidden (s :> t))
958 | `Module (m, _)
959 | `Module_type (m, _)
960 | `Type (m, _)
961 | `Class (m, _)
962 | `ClassType (m, _) ->
963 is_hidden (m :> t)
964 | `OpaqueModule m -> is_hidden (m :> t)
965 end
966
967 type t = Paths_types.Fragment.any
968
969 module Signature = struct
970 type t = Paths_types.Fragment.signature
971 end
972
973 module Module = struct
974 type t = Paths_types.Fragment.module_
975 end
976
977 module ModuleType = struct
978 type t = Paths_types.Fragment.module_type
979 end
980
981 module Type = struct
982 type t = Paths_types.Fragment.type_
983 end
984
985 type leaf = Paths_types.Fragment.leaf
986end
987
988module Reference = struct
989 module Resolved = struct
990 open Paths_types.Resolved_reference
991
992 type t = Paths_types.Resolved_reference.any
993
994 let rec parent_signature_identifier :
995 signature -> Identifier.Signature.t option = function
996 | `Identifier id -> Some id
997 | `Hidden _s -> None
998 | `Alias (sub, orig) ->
999 if Path.Resolved.(is_hidden (sub :> t)) then
1000 parent_signature_identifier (orig :> signature)
1001 else
1002 (Path.Resolved.parent_module_identifier sub
1003 :> Identifier.Signature.t option)
1004 | `AliasModuleType (sub, orig) ->
1005 if Path.Resolved.(is_hidden (sub :> t)) then
1006 parent_signature_identifier (orig :> signature)
1007 else
1008 (Path.Resolved.parent_module_type_identifier sub
1009 :> Identifier.Signature.t option)
1010 | `Module (m, n) -> (
1011 match parent_signature_identifier m with
1012 | None -> None
1013 | Some p -> Some (Identifier.Mk.module_ (p, n)))
1014 | `ModuleType (m, n) -> (
1015 match parent_signature_identifier m with
1016 | None -> None
1017 | Some p -> Some (Identifier.Mk.module_type (p, n)))
1018
1019 and parent_type_identifier : datatype -> Identifier.DataType.t option =
1020 function
1021 | `Identifier id -> Some id
1022 | `Type (sg, s) -> (
1023 match parent_signature_identifier sg with
1024 | None -> None
1025 | Some p -> Some (Identifier.Mk.type_ (p, s)))
1026
1027 and parent_class_signature_identifier :
1028 class_signature -> Identifier.ClassSignature.t option = function
1029 | `Identifier id -> Some id
1030 | `Class (sg, s) -> (
1031 match parent_signature_identifier sg with
1032 | None -> None
1033 | Some p -> Some (Identifier.Mk.class_ (p, s)))
1034 | `ClassType (sg, s) -> (
1035 match parent_signature_identifier sg with
1036 | None -> None
1037 | Some p -> Some (Identifier.Mk.class_type (p, s)))
1038
1039 and field_parent_identifier :
1040 field_parent -> Identifier.FieldParent.t option = function
1041 | `Identifier id -> Some id
1042 | (`Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `ModuleType _)
1043 as sg ->
1044 (parent_signature_identifier sg :> Identifier.FieldParent.t option)
1045 | `Type _ as t ->
1046 (parent_type_identifier t :> Identifier.FieldParent.t option)
1047
1048 and unboxed_field_parent_identifier : unboxed_field_parent -> Identifier.UnboxedFieldParent.t option =
1049 function
1050 | `Identifier id -> Some id
1051 | `Type _ as t -> (parent_type_identifier t :> Identifier.UnboxedFieldParent.t option)
1052
1053 and label_parent_identifier :
1054 label_parent -> Identifier.LabelParent.t option = function
1055 | `Identifier id -> Some id
1056 | (`Class _ | `ClassType _) as c ->
1057 (parent_class_signature_identifier c
1058 :> Identifier.LabelParent.t option)
1059 | ( `Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `ModuleType _
1060 | `Type _ ) as r ->
1061 (field_parent_identifier r :> Identifier.LabelParent.t option)
1062
1063 and identifier : t -> Identifier.t option = function
1064 | `Identifier id -> Some id
1065 | `UnboxedField (p, n) -> (
1066 match unboxed_field_parent_identifier p with
1067 | None -> None
1068 | Some p -> Some (Identifier.Mk.unboxed_field (p, n)))
1069 | ( `Alias _ | `AliasModuleType _ | `Module _ | `Hidden _ | `Type _
1070 | `Class _ | `ClassType _ | `ModuleType _ ) as r ->
1071 (label_parent_identifier r :> Identifier.t option)
1072 | `Field (p, n) -> (
1073 match field_parent_identifier p with
1074 | None -> None
1075 | Some p -> Some (Identifier.Mk.field (p, n)))
1076 | `PolyConstructor (s, n) -> (
1077 (* Uses an identifier for constructor even though it is not
1078 one. Document must make the links correspond. *)
1079 match parent_type_identifier s with
1080 | None -> None
1081 | Some p -> Some (Identifier.Mk.constructor (p, n)))
1082 | `Constructor (s, n) -> (
1083 match parent_type_identifier s with
1084 | None -> None
1085 | Some p -> Some (Identifier.Mk.constructor (p, n)))
1086 | `Extension (p, q) -> (
1087 match parent_signature_identifier p with
1088 | None -> None
1089 | Some p -> Some (Identifier.Mk.extension (p, q)))
1090 | `ExtensionDecl (p, q, r) -> (
1091 match parent_signature_identifier p with
1092 | None -> None
1093 | Some p -> Some (Identifier.Mk.extension_decl (p, (q, r))))
1094 | `Exception (p, q) -> (
1095 match parent_signature_identifier p with
1096 | None -> None
1097 | Some p -> Some (Identifier.Mk.exception_ (p, q)))
1098 | `Value (p, q) -> (
1099 match parent_signature_identifier p with
1100 | None -> None
1101 | Some p -> Some (Identifier.Mk.value (p, q)))
1102 | `Method (p, q) -> (
1103 match parent_class_signature_identifier p with
1104 | None -> None
1105 | Some p -> Some (Identifier.Mk.method_ (p, q)))
1106 | `InstanceVariable (p, q) -> (
1107 match parent_class_signature_identifier p with
1108 | None -> None
1109 | Some p -> Some (Identifier.Mk.instance_variable (p, q)))
1110 | `Label (p, q) -> (
1111 match label_parent_identifier p with
1112 | None -> None
1113 | Some p -> Some (Identifier.Mk.label (p, q)))
1114
1115 module Signature = struct
1116 type t = Paths_types.Resolved_reference.signature
1117 end
1118
1119 module ClassSignature = struct
1120 type t = Paths_types.Resolved_reference.class_signature
1121 end
1122
1123 module DataType = struct
1124 type t = Paths_types.Resolved_reference.datatype
1125 end
1126
1127 module FieldParent = struct
1128 type t = Paths_types.Resolved_reference.field_parent
1129 end
1130
1131 module UnboxedFieldParent = struct
1132 type t = Paths_types.Resolved_reference.unboxed_field_parent
1133 end
1134
1135 module LabelParent = struct
1136 type t = Paths_types.Resolved_reference.label_parent
1137 end
1138
1139 module Module = struct
1140 type t = Paths_types.Resolved_reference.module_
1141 end
1142
1143 module ModuleType = struct
1144 type t = Paths_types.Resolved_reference.module_type
1145 end
1146
1147 module Type = struct
1148 type t = Paths_types.Resolved_reference.type_
1149 end
1150
1151 module Constructor = struct
1152 type t = Paths_types.Resolved_reference.constructor
1153 end
1154
1155 module Field = struct
1156 type t = Paths_types.Resolved_reference.field
1157 end
1158
1159 module UnboxedField = struct
1160 type t = Paths_types.Resolved_reference.unboxed_field
1161 end
1162
1163 module Extension = struct
1164 type t = Paths_types.Resolved_reference.extension
1165 end
1166
1167 module ExtensionDecl = struct
1168 type t = Paths_types.Resolved_reference.extension_decl
1169 end
1170
1171 module Exception = struct
1172 type t = Paths_types.Resolved_reference.exception_
1173 end
1174
1175 module Value = struct
1176 type t = Paths_types.Resolved_reference.value
1177 end
1178
1179 module Class = struct
1180 type t = Paths_types.Resolved_reference.class_
1181 end
1182
1183 module ClassType = struct
1184 type t = Paths_types.Resolved_reference.class_type
1185 end
1186
1187 module Method = struct
1188 type t = Paths_types.Resolved_reference.method_
1189 end
1190
1191 module InstanceVariable = struct
1192 type t = Paths_types.Resolved_reference.instance_variable
1193 end
1194
1195 module Label = struct
1196 type t = Paths_types.Resolved_reference.label
1197 end
1198
1199 module Page = struct
1200 type t = Paths_types.Resolved_reference.page
1201 end
1202
1203 module Asset = struct
1204 let identifier = function `Identifier id -> id
1205
1206 type t = Paths_types.Resolved_reference.asset
1207 end
1208 end
1209
1210 type t = Paths_types.Reference.any
1211
1212 type tag_any = Paths_types.Reference.tag_any
1213 type tag_hierarchy = Paths_types.Reference.tag_hierarchy
1214
1215 module Signature = struct
1216 type t = Paths_types.Reference.signature
1217 end
1218
1219 module ClassSignature = struct
1220 type t = Paths_types.Reference.class_signature
1221 end
1222
1223 module DataType = struct
1224 type t = Paths_types.Reference.datatype
1225 end
1226
1227 module FragmentTypeParent = struct
1228 type t = Paths_types.Reference.fragment_type_parent
1229 end
1230
1231 module LabelParent = struct
1232 type t = Paths_types.Reference.label_parent
1233 end
1234
1235 module Module = struct
1236 type t = Paths_types.Reference.module_
1237 end
1238
1239 module ModuleType = struct
1240 type t = Paths_types.Reference.module_type
1241 end
1242
1243 module Type = struct
1244 type t = Paths_types.Reference.type_
1245 end
1246
1247 module Constructor = struct
1248 type t = Paths_types.Reference.constructor
1249 end
1250
1251 module Field = struct
1252 type t = Paths_types.Reference.field
1253 end
1254
1255 module UnboxedField = struct
1256 type t = Paths_types.Reference.unboxed_field
1257 end
1258
1259 module Extension = struct
1260 type t = Paths_types.Reference.extension
1261 end
1262
1263 module ExtensionDecl = struct
1264 type t = Paths_types.Reference.extension_decl
1265 end
1266
1267 module Exception = struct
1268 type t = Paths_types.Reference.exception_
1269 end
1270
1271 module Value = struct
1272 type t = Paths_types.Reference.value
1273 end
1274
1275 module Class = struct
1276 type t = Paths_types.Reference.class_
1277 end
1278
1279 module ClassType = struct
1280 type t = Paths_types.Reference.class_type
1281 end
1282
1283 module Method = struct
1284 type t = Paths_types.Reference.method_
1285 end
1286
1287 module InstanceVariable = struct
1288 type t = Paths_types.Reference.instance_variable
1289 end
1290
1291 module Label = struct
1292 type t = Paths_types.Reference.label
1293 end
1294
1295 module Page = struct
1296 type t = Paths_types.Reference.page
1297 end
1298
1299 module Asset = struct
1300 type t = Paths_types.Reference.asset
1301 end
1302
1303 module Hierarchy = struct
1304 type t = Paths_types.Reference.hierarchy
1305 end
1306end