jon.recoil.org
this repo has no description
1open Odoc_model.Paths
2open Odoc_model.Names
3
4module rec Resolved : sig
5 type parent =
6 [ `Module of module_ | `ModuleType of module_type | `FragmentRoot ]
7
8 and module_ =
9 [ `Local of Ident.module_
10 | `Gpath of Path.Resolved.Module.t
11 | `Substituted of module_
12 | `Subst of module_type * module_
13 | `Hidden of module_
14 | `Module of parent * ModuleName.t
15 | `Canonical of module_ * Path.Module.t
16 | `Apply of module_ * module_
17 | `Alias of module_ * Cpath.module_ * module_ option
18 | `OpaqueModule of module_ ]
19
20 and module_type =
21 [ `Local of Ident.module_type
22 | `Substituted of module_type
23 | `Gpath of Path.Resolved.ModuleType.t
24 | `ModuleType of parent * ModuleTypeName.t
25 | `SubstT of module_type * module_type
26 | `AliasModuleType of module_type * module_type
27 | `CanonicalModuleType of module_type * Path.ModuleType.t
28 | `OpaqueModuleType of module_type ]
29
30 and type_ =
31 [ `Local of Ident.type_
32 | `Gpath of Path.Resolved.Type.t
33 | `Substituted of type_
34 | `CanonicalType of type_ * Path.Type.t
35 | `CoreType of TypeName.t
36 | `Type of parent * TypeName.t
37 | `Class of parent * TypeName.t
38 | `ClassType of parent * TypeName.t ]
39
40 and value =
41 [ `Value of parent * ValueName.t | `Gpath of Path.Resolved.Value.t ]
42
43 and class_type =
44 [ `Local of Ident.type_
45 | `Substituted of class_type
46 | `Gpath of Path.Resolved.ClassType.t
47 | `Class of parent * TypeName.t
48 | `ClassType of parent * TypeName.t ]
49end =
50 Resolved
51
52and Cpath : sig
53 type module_ =
54 [ `Resolved of Resolved.module_
55 | `Substituted of module_
56 | `Local of Ident.module_ * bool
57 | `Identifier of Identifier.Path.Module.t * bool
58 | `Root of ModuleName.t
59 | `Forward of string
60 | `Dot of module_ * ModuleName.t
61 | `Module of Resolved.parent * ModuleName.t (* Like dot, but typed *)
62 | `Apply of module_ * module_ ]
63
64 and module_type =
65 [ `Resolved of Resolved.module_type
66 | `Substituted of module_type
67 | `Local of Ident.module_type * bool
68 | `Identifier of Identifier.ModuleType.t * bool
69 | `DotMT of module_ * ModuleTypeName.t
70 | `ModuleType of Resolved.parent * ModuleTypeName.t ]
71
72 and type_ =
73 [ `Resolved of Resolved.type_
74 | `Substituted of type_
75 | `Local of Ident.type_ * bool
76 | `Identifier of Odoc_model.Paths.Identifier.Path.Type.t * bool
77 | `DotT of module_ * TypeName.t
78 | `Type of Resolved.parent * TypeName.t
79 | `Class of Resolved.parent * TypeName.t
80 | `ClassType of Resolved.parent * TypeName.t ]
81
82 and value =
83 [ `Resolved of Resolved.value
84 | `DotV of module_ * ValueName.t
85 | `Value of Resolved.parent * ValueName.t
86 | `Identifier of Identifier.Value.t * bool ]
87
88 and class_type =
89 [ `Resolved of Resolved.class_type
90 | `Substituted of class_type
91 | `Local of Ident.type_ * bool
92 | `Identifier of Odoc_model.Paths.Identifier.Path.ClassType.t * bool
93 | `DotT of module_ * TypeName.t
94 | `Class of Resolved.parent * TypeName.t
95 | `ClassType of Resolved.parent * TypeName.t ]
96end =
97 Cpath
98
99include Cpath
100
101let rec is_resolved_module_substituted : Resolved.module_ -> bool = function
102 | `Local _ -> false
103 | `Substituted _ -> true
104 | `Gpath _ -> false
105 | `Subst (_a, _) -> false (* is_resolved_module_type_substituted a*)
106 | `Hidden a | `Apply (a, _) | `Alias (a, _, _) | `Canonical (a, _) ->
107 is_resolved_module_substituted a
108 | `Module (a, _) -> is_resolved_parent_substituted a
109 | `OpaqueModule a -> is_resolved_module_substituted a
110
111and is_resolved_parent_substituted = function
112 | `Module m -> is_resolved_module_substituted m
113 | `ModuleType m -> is_resolved_module_type_substituted m
114 | `FragmentRoot -> false
115
116and is_resolved_module_type_substituted : Resolved.module_type -> bool =
117 function
118 | `Local _ -> false
119 | `Substituted _ -> true
120 | `Gpath _ -> false
121 | `ModuleType (a, _) -> is_resolved_parent_substituted a
122 | `SubstT _ -> false
123 | `AliasModuleType (m1, _) -> is_resolved_module_type_substituted m1
124 | `CanonicalModuleType (m, _) | `OpaqueModuleType m ->
125 is_resolved_module_type_substituted m
126
127and is_resolved_type_substituted : Resolved.type_ -> bool = function
128 | `Local _ -> false
129 | `CoreType _ -> false
130 | `Substituted _ -> true
131 | `Gpath _ -> false
132 | `CanonicalType (t, _) -> is_resolved_type_substituted t
133 | `Type (a, _) | `Class (a, _) | `ClassType (a, _) ->
134 is_resolved_parent_substituted a
135
136and is_resolved_class_type_substituted : Resolved.class_type -> bool = function
137 | `Local _ -> false
138 | `Substituted _ -> true
139 | `Gpath _ -> false
140 | `Class (a, _) | `ClassType (a, _) -> is_resolved_parent_substituted a
141
142let rec is_module_substituted : module_ -> bool = function
143 | `Resolved a -> is_resolved_module_substituted a
144 | `Identifier _ -> false
145 | `Local _ -> false
146 | `Substituted _ -> true
147 | `Dot (a, _) | `Apply (a, _) -> is_module_substituted a
148 | `Forward _ -> false
149 | `Root _ -> false
150 | `Module (a, _) -> is_resolved_parent_substituted a
151
152let is_module_type_substituted : module_type -> bool = function
153 | `Resolved a -> is_resolved_module_type_substituted a
154 | `Identifier _ -> false
155 | `Local _ -> false
156 | `Substituted _ -> true
157 | `DotMT (a, _) -> is_module_substituted a
158 | `ModuleType (a, _) -> is_resolved_parent_substituted a
159
160let is_type_substituted : type_ -> bool = function
161 | `Resolved a -> is_resolved_type_substituted a
162 | `Identifier _ -> false
163 | `Local _ -> false
164 | `Substituted _ -> true
165 | `DotT (a, _) -> is_module_substituted a
166 | `Type (a, _) | `Class (a, _) | `ClassType (a, _) ->
167 is_resolved_parent_substituted a
168
169let is_class_type_substituted : class_type -> bool = function
170 | `Resolved a -> is_resolved_class_type_substituted a
171 | `Identifier _ -> false
172 | `Local _ -> false
173 | `Substituted _ -> true
174 | `DotT (a, _) -> is_module_substituted a
175 | `Class (a, _) | `ClassType (a, _) -> is_resolved_parent_substituted a
176
177let rec is_module_forward : module_ -> bool = function
178 | `Forward _ -> true
179 | `Resolved _ -> false
180 | `Root _ -> false
181 | `Identifier _ -> false
182 | `Local _ -> false
183 | `Substituted p | `Dot (p, _) | `Apply (p, _) -> is_module_forward p
184 | `Module (_, _) -> false
185
186let rec is_module_hidden : module_ -> bool = function
187 | `Resolved r -> is_resolved_module_hidden ~weak_canonical_test:false r
188 | `Substituted p | `Dot (p, _) | `Apply (p, _) -> is_module_hidden p
189 | `Identifier (_, b) -> b
190 | `Local (_, b) -> b
191 | `Forward _ -> false
192 | `Root _ -> false
193 | `Module (p, _) -> is_resolved_parent_hidden ~weak_canonical_test:false p
194
195and is_resolved_module_hidden :
196 weak_canonical_test:bool -> Resolved.module_ -> bool =
197 fun ~weak_canonical_test ->
198 let rec inner = function
199 | `Local _ -> false
200 | `Gpath p ->
201 Odoc_model.Paths.Path.Resolved.Module.is_hidden ~weak_canonical_test p
202 | `Hidden _ -> true
203 | `Canonical (_, `Resolved _) -> false
204 | `Canonical (p, _) -> (not weak_canonical_test) && inner p
205 | `Substituted p -> inner p
206 | `Module (p, _) -> is_resolved_parent_hidden ~weak_canonical_test p
207 | `Subst (p1, p2) -> is_resolved_module_type_hidden p1 || inner p2
208 | `Alias (p1, `Resolved p2, _) -> inner p1 && inner p2
209 | `Alias (p1, _p2, _) -> inner p1
210 | `Apply (p1, p2) -> inner p1 || inner p2
211 | `OpaqueModule m -> inner m
212 in
213 inner
214
215and is_resolved_parent_hidden :
216 weak_canonical_test:bool -> Resolved.parent -> bool =
217 fun ~weak_canonical_test -> function
218 | `Module m -> is_resolved_module_hidden ~weak_canonical_test m
219 | `ModuleType m -> is_resolved_module_type_hidden m
220 | `FragmentRoot -> false
221
222and is_module_type_hidden : module_type -> bool = function
223 | `Resolved r -> is_resolved_module_type_hidden r
224 | `Identifier ({ iv = `ModuleType (_, t); _ }, b) ->
225 b || ModuleTypeName.is_hidden t
226 | `Local (_, b) -> b
227 | `Substituted p -> is_module_type_hidden p
228 | `DotMT (p, _) -> is_module_hidden p
229 | `ModuleType (p, _) -> is_resolved_parent_hidden ~weak_canonical_test:false p
230
231and is_resolved_module_type_hidden : Resolved.module_type -> bool = function
232 | `Local _ -> false
233 | `Gpath p -> Odoc_model.Paths.Path.Resolved.(is_hidden (p :> t))
234 | `Substituted p -> is_resolved_module_type_hidden p
235 | `ModuleType (p, _) -> is_resolved_parent_hidden ~weak_canonical_test:false p
236 | `SubstT (p1, p2) ->
237 is_resolved_module_type_hidden p1 || is_resolved_module_type_hidden p2
238 | `AliasModuleType (p1, p2) ->
239 is_resolved_module_type_hidden p1 || is_resolved_module_type_hidden p2
240 | `CanonicalModuleType (_, `Resolved _) -> false
241 | `CanonicalModuleType (p, _) -> is_resolved_module_type_hidden p
242 | `OpaqueModuleType m -> is_resolved_module_type_substituted m
243
244and is_type_hidden : type_ -> bool = function
245 | `Resolved r -> is_resolved_type_hidden r
246 | `Identifier ({ iv = `Type (_, t); _ }, b) -> b || TypeName.is_hidden t
247 | `Identifier ({ iv = `ClassType (_, t); _ }, b) -> b || TypeName.is_hidden t
248 | `Identifier ({ iv = `Class (_, t); _ }, b) -> b || TypeName.is_hidden t
249 | `Local (_, b) -> b
250 | `Substituted p -> is_type_hidden (p :> type_)
251 | `DotT (p, _) -> is_module_hidden p
252 | `Type (p, _) | `Class (p, _) | `ClassType (p, _) ->
253 is_resolved_parent_hidden ~weak_canonical_test:false p
254
255and is_resolved_type_hidden : Resolved.type_ -> bool = function
256 | `CoreType n -> TypeName.is_hidden n
257 | `Local _ -> false
258 | `Gpath p -> Odoc_model.Paths.Path.Resolved.(is_hidden (p :> t))
259 | `Substituted p -> is_resolved_type_hidden p
260 | `CanonicalType (_, `Resolved _) -> false
261 | `CanonicalType (p, _) -> is_resolved_type_hidden p
262 | `Type (p, _) | `Class (p, _) | `ClassType (p, _) ->
263 is_resolved_parent_hidden ~weak_canonical_test:false p
264
265and is_resolved_class_type_hidden : Resolved.class_type -> bool = function
266 | `Local _ -> false
267 | `Gpath p -> Odoc_model.Paths.Path.Resolved.(is_hidden (p :> t))
268 | `Substituted p -> is_resolved_class_type_hidden p
269 | `Class (p, _) | `ClassType (p, _) ->
270 is_resolved_parent_hidden ~weak_canonical_test:false p
271
272and is_class_type_hidden : class_type -> bool = function
273 | `Resolved r -> is_resolved_class_type_hidden r
274 | `Identifier (_, b) -> b
275 | `Local (_, b) -> b
276 | `Substituted p -> is_class_type_hidden p
277 | `DotT (p, _) -> is_module_hidden p
278 | `Class (p, _) | `ClassType (p, _) ->
279 is_resolved_parent_hidden ~weak_canonical_test:false p
280
281let rec resolved_module_of_resolved_module_reference :
282 Reference.Resolved.Module.t -> Resolved.module_ = function
283 | `Module (parent, name) ->
284 `Module
285 (`Module (resolved_module_of_resolved_signature_reference parent), name)
286 | `Identifier x -> `Gpath (`Identifier x)
287 | `Alias (_m1, _m2) -> failwith "gah"
288 | `Hidden s -> `Hidden (resolved_module_of_resolved_module_reference s)
289
290and resolved_module_of_resolved_signature_reference :
291 Reference.Resolved.Signature.t -> Resolved.module_ = function
292 | `Identifier ({ iv = #Identifier.Module.t_pv; _ } as i) ->
293 `Gpath (`Identifier i)
294 | (`Alias _ | `Module _ | `Hidden _) as r' ->
295 resolved_module_of_resolved_module_reference r'
296 | `ModuleType (_, n) ->
297 failwith ("Not a module reference: " ^ ModuleTypeName.to_string n)
298 | `AliasModuleType _ -> failwith "Not a module reference: aliasmoduletype"
299 | `Identifier _ -> failwith "Not a module reference : identifier"
300
301and module_of_module_reference : Reference.Module.t -> module_ = function
302 | `Resolved r -> `Resolved (resolved_module_of_resolved_module_reference r)
303 | `Root (_, _) -> failwith "unhandled"
304 | `Dot
305 ( (( `Resolved (`Identifier { iv = #Identifier.Module.t_pv; _ })
306 | `Dot (_, _)
307 | `Module (_, _) ) as parent),
308 name ) ->
309 `Dot (module_of_module_reference parent, ModuleName.make_std name)
310 | `Module
311 ( (( `Resolved (`Identifier { iv = #Identifier.Module.t_pv; _ })
312 | `Dot (_, _)
313 | `Module (_, _) ) as parent),
314 name ) ->
315 `Dot (module_of_module_reference parent, name)
316 | _ -> failwith "Not a module reference"
317
318let rec unresolve_resolved_module_path : Resolved.module_ -> module_ = function
319 | `Hidden (`Gpath (`Identifier x)) -> `Identifier (x, true)
320 | `Gpath (`Identifier x) ->
321 let hidden =
322 match x.iv with
323 | `Module (_, n) -> Odoc_model.Names.ModuleName.is_hidden n
324 | _ -> false
325 in
326 `Identifier (x, hidden)
327 | `Gpath _ as x -> `Resolved x
328 | `Hidden (`Local x) -> `Local (x, true)
329 | `Local x -> `Local (x, false)
330 | `Substituted x -> unresolve_resolved_module_path x
331 | `Subst (_, x) -> unresolve_resolved_module_path x
332 | `Hidden x -> unresolve_resolved_module_path x (* should assert false here *)
333 | `Module (p, m) -> `Dot (unresolve_resolved_parent_path p, m)
334 | `Canonical (m, _) -> unresolve_resolved_module_path m
335 | `Apply (m, a) ->
336 `Apply (unresolve_resolved_module_path m, unresolve_resolved_module_path a)
337 | `Alias (_, `Resolved m, _) -> unresolve_resolved_module_path m
338 | `Alias (_, m, _) -> m
339 | `OpaqueModule m -> unresolve_resolved_module_path m
340
341and unresolve_module_path : module_ -> module_ = function
342 | `Resolved x -> unresolve_resolved_module_path x
343 | `Substituted x -> unresolve_module_path x
344 | `Local (_, _) as x -> x
345 | `Identifier _ as x -> x
346 | `Root _ as x -> x
347 | `Forward _ as x -> x
348 | `Dot (p, x) -> `Dot (unresolve_module_path p, x)
349 | `Module (p, x) -> `Dot (unresolve_resolved_parent_path p, x)
350 | `Apply (x, y) -> `Apply (unresolve_module_path x, unresolve_module_path y)
351
352and unresolve_resolved_module_type_path : Resolved.module_type -> module_type =
353 function
354 | (`Local _ | `Gpath _) as p -> `Resolved p
355 | `Substituted x -> unresolve_resolved_module_type_path x
356 | `ModuleType (p, n) -> `DotMT (unresolve_resolved_parent_path p, n)
357 | `SubstT (_, m) -> unresolve_resolved_module_type_path m
358 | `AliasModuleType (_, m2) -> unresolve_resolved_module_type_path m2
359 | `CanonicalModuleType (p, _) -> unresolve_resolved_module_type_path p
360 | `OpaqueModuleType m -> unresolve_resolved_module_type_path m
361
362and unresolve_resolved_parent_path : Resolved.parent -> module_ = function
363 | `Module m -> unresolve_resolved_module_path m
364 | `FragmentRoot | `ModuleType _ -> assert false
365
366and unresolve_resolved_type_path : Resolved.type_ -> type_ = function
367 | (`Gpath _ | `Local _ | `CoreType _) as p -> `Resolved p
368 | `Substituted x -> unresolve_resolved_type_path x
369 | `CanonicalType (t1, _) -> unresolve_resolved_type_path t1
370 | `Type (p, n) -> `DotT (unresolve_resolved_parent_path p, n)
371 | `Class (p, n) -> `DotT (unresolve_resolved_parent_path p, n)
372 | `ClassType (p, n) -> `DotT (unresolve_resolved_parent_path p, n)
373
374and unresolve_resolved_class_type_path : Resolved.class_type -> class_type =
375 function
376 | (`Local _ | `Gpath _) as p -> `Resolved p
377 | `Substituted x -> unresolve_resolved_class_type_path x
378 | `Class (p, n) -> `DotT (unresolve_resolved_parent_path p, n)
379 | `ClassType (p, n) -> `DotT (unresolve_resolved_parent_path p, n)
380
381and unresolve_module_type_path : module_type -> module_type = function
382 | `Resolved m -> unresolve_resolved_module_type_path m
383 | y -> y
384
385and unresolve_type_path : type_ -> type_ = function
386 | `Resolved m -> (unresolve_resolved_type_path m :> type_)
387 | y -> y
388
389and unresolve_class_type_path : class_type -> class_type = function
390 | `Resolved m -> unresolve_resolved_class_type_path m
391 | y -> y
392
393(*
394These are left here for later. The idea is to alter a resolved path
395such that all the identifiers in it are turned into fully-qualified
396resolved paths. This is intended to be used to turn the 'original
397path' of `module type of` expressions that was resolved in the
398original context into a path that is valid in _all_ contexts.
399
400let rec original_path_cpath : module_ -> module_ option = function
401 | `Resolved p ->
402 original_path_cpath (unresolve_resolved_module_path p)
403 | `Root name -> Some (`Root name)
404 | `Forward _ -> None
405 | `Dot (p, s) -> (
406 match original_path_cpath p with
407 | Some p -> Some (`Dot (p, s))
408 | None -> None)
409 | `Apply (p1, p2) -> (
410 match (original_path_cpath p1, original_path_cpath p2) with
411 | Some p1', Some p2' -> Some (`Apply (p1', p2'))
412 | _ -> None)
413 | `Identifier (i, _) -> (
414 match original_path_module_identifier i with
415 | Some i -> Some (`Resolved i)
416 | None -> None)
417 | `Substituted p -> original_path_cpath p
418 | `Local _ ->
419 None
420 | `Module _ ->
421 None
422
423
424and original_path_module_identifier :
425 Odoc_model.Paths.Identifier.Path.Module.t -> Resolved.module_ option =
426 fun id ->
427 match id.iv with
428 | `Module (sg, name) -> (
429 match original_path_parent_identifier sg with
430 | Some sg' -> Some (`Module (sg', name))
431 | None -> None)
432 | `Root _ -> Some (`Gpath (`Identifier id))
433 | _ ->
434 None
435
436and original_path_parent_identifier :
437 Odoc_model.Paths.Identifier.Signature.t -> Resolved.parent option =
438 fun id ->
439 match id with
440 | { iv = `Module _ | `Root _ | `Parameter _ | `Result _; _ } as mid -> (
441 match original_path_module_identifier mid with
442 | Some m -> Some (`Module m)
443 | None -> None)
444 | { iv = `ModuleType _; _ } as mtid -> (
445 match original_path_module_type_identifier mtid with
446 | Some m -> Some (`ModuleType m)
447 | None -> None)
448
449and original_path_module_type_identifier :
450 Odoc_model.Paths.Identifier.ModuleType.t -> Resolved.module_type option =
451 fun id ->
452 match id.iv with
453 | `ModuleType (sg, name) -> (
454 match original_path_parent_identifier sg with
455 | Some sg' -> Some (`ModuleType (sg', name))
456 | None -> None)
457*)