jon.recoil.org
this repo has no description
1open Odoc_model.Names
2open Component
3
4type module_ = [ `FModule of ModuleName.t * Module.t ]
5
6type module_type = [ `FModuleType of ModuleTypeName.t * ModuleType.t ]
7
8type datatype = [ `FType of TypeName.t * TypeDecl.t ]
9
10type core_type = [ `CoreType of TypeName.t ]
11
12type class_ =
13 [ `FClass of TypeName.t * Class.t | `FClassType of TypeName.t * ClassType.t ]
14
15type value = [ `FValue of ValueName.t * Value.t ]
16
17type label = [ `FLabel of Label.t ]
18
19type exception_ = [ `FExn of ExceptionName.t * Exception.t ]
20
21type extension = [ `FExt of Extension.t * Extension.Constructor.t ]
22
23type substitution =
24 [ `FModule_subst of ModuleSubstitution.t
25 | `FType_subst of TypeDecl.t
26 | `FModuleType_subst of ModuleTypeSubstitution.t ]
27
28type signature = [ module_ | module_type ]
29
30type type_ = [ datatype | class_ ]
31
32type label_parent = [ signature | type_ ]
33
34type constructor = [ `FConstructor of TypeDecl.Constructor.t ]
35
36type polymorphic_constructor =
37 [ `FPoly of TypeExpr.Polymorphic_variant.Constructor.t ]
38
39type field = [ `FField of TypeDecl.Field.t ]
40
41type unboxed_field = [ `FUnboxedField of TypeDecl.UnboxedField.t ]
42
43type any_in_type = [ constructor | field | unboxed_field | polymorphic_constructor ]
44
45type any_in_type_in_sig =
46 [ `In_type of Odoc_model.Names.TypeName.t * TypeDecl.t * any_in_type ]
47
48type any_in_sig =
49 [ label_parent
50 | value
51 | label
52 | exception_
53 | extension
54 | substitution
55 | any_in_type_in_sig ]
56
57type instance_variable =
58 [ `FInstance_variable of InstanceVariableName.t * InstanceVariable.t ]
59
60type method_ = [ `FMethod of MethodName.t * Method.t ]
61
62type any_in_class_sig = [ instance_variable | method_ ]
63
64module N = Ident.Name
65
66let rec find_map f = function
67 | hd :: tl -> ( match f hd with Some _ as x -> x | None -> find_map f tl)
68 | [] -> None
69
70let find_in_sig sg f =
71 let rec inner f = function
72 | Signature.Include i :: tl -> (
73 match inner f i.Include.expansion_.items with
74 | Some _ as x -> x
75 | None -> inner f tl)
76 | hd :: tl -> ( match f hd with Some _ as x -> x | None -> inner f tl)
77 | [] -> None
78 in
79 inner f sg.Signature.items
80
81let filter_in_sig sg f =
82 let rec inner f = function
83 | Signature.Include i :: tl ->
84 inner f i.Include.expansion_.items @ inner f tl
85 | hd :: tl -> (
86 match f hd with Some x -> x :: inner f tl | None -> inner f tl)
87 | [] -> []
88 in
89 inner f sg.Signature.items
90
91(** Returns the last element of a list. Used to implement [_unambiguous]
92 functions. *)
93let rec disambiguate = function
94 | [ x ] -> Some x
95 | [] -> None
96 | _ :: tl -> disambiguate tl
97
98let module_in_sig sg name =
99 find_in_sig sg (function
100 | Signature.Module (id, _, m)
101 when ModuleName.equal_modulo_shadowing (N.typed_module id) name ->
102 Some (`FModule (N.typed_module id, Delayed.get m))
103 | _ -> None)
104
105let module_type_in_sig sg name =
106 find_in_sig sg (function
107 | Signature.ModuleType (id, mt)
108 when ModuleTypeName.equal_modulo_shadowing (N.typed_module_type id) name
109 ->
110 Some (`FModuleType (N.typed_module_type id, Delayed.get mt))
111 | _ -> None)
112
113let type_in_sig sg name =
114 find_in_sig sg (function
115 | Signature.Type (id, _, m)
116 when TypeName.equal_modulo_shadowing (N.typed_type id) name ->
117 Some (`FType (N.typed_type id, Delayed.get m))
118 | Class (id, _, c)
119 when TypeName.equal_modulo_shadowing (N.typed_type id) name ->
120 Some (`FClass (N.typed_type id, c))
121 | ClassType (id, _, c)
122 when TypeName.equal_modulo_shadowing (N.typed_type id) name ->
123 Some (`FClassType (N.typed_type id, c))
124 | _ -> None)
125
126type removed_type =
127 [ `FType_removed of TypeName.t * TypeExpr.t * TypeDecl.Equation.t ]
128
129type careful_module = [ module_ | `FModule_removed of Cpath.module_ ]
130
131type careful_module_type =
132 [ module_type | `FModuleType_removed of ModuleType.expr ]
133
134type careful_type = [ type_ | removed_type | core_type ]
135
136type careful_class = [ class_ | removed_type ]
137
138let careful_module_in_sig sg name =
139 let removed_module = function
140 | Signature.RModule (id, p) when ModuleName.equal_modulo_shadowing id name
141 ->
142 Some (`FModule_removed p)
143 | _ -> None
144 in
145 match module_in_sig sg name with
146 | Some _ as x -> x
147 | None -> find_map removed_module sg.Signature.removed
148
149let careful_module_type_in_sig sg name =
150 let removed_module_type = function
151 | Signature.RModuleType (id, p)
152 when ModuleTypeName.equal_modulo_shadowing id name ->
153 Some (`FModuleType_removed p)
154 | _ -> None
155 in
156 match module_type_in_sig sg name with
157 | Some _ as x -> x
158 | None -> find_map removed_module_type sg.Signature.removed
159
160let removed_type_in_sig sg name =
161 let removed_type = function
162 | Signature.RType (id, p, eq) when id = name ->
163 Some (`FType_removed (id, p, eq))
164 | _ -> None
165 in
166 find_map removed_type sg.Signature.removed
167
168let careful_type_in_sig sg name =
169 match type_in_sig sg name with
170 | Some _ as x -> x
171 | None -> removed_type_in_sig sg name
172
173let datatype_in_sig sg name =
174 find_in_sig sg (function
175 | Signature.Type (id, _, t)
176 when TypeName.equal_modulo_shadowing (N.typed_type id) name ->
177 Some (`FType (N.typed_type id, Component.Delayed.get t))
178 | _ -> None)
179
180let class_in_sig sg name =
181 filter_in_sig sg (function
182 | Signature.Class (id, _, c)
183 when TypeName.equal_modulo_shadowing (N.typed_type id) name ->
184 Some (`FClass (N.typed_type id, c))
185 | Signature.ClassType (id, _, c)
186 when TypeName.equal_modulo_shadowing (N.typed_type id) name ->
187 Some (`FClassType (N.typed_type id, c))
188 | _ -> None)
189
190let class_in_sig_unambiguous sg name = disambiguate (class_in_sig sg name)
191
192let careful_class_in_sig sg name =
193 match class_in_sig_unambiguous sg name with
194 | Some _ as x -> x
195 | None -> removed_type_in_sig sg name
196
197let any_in_type (typ : TypeDecl.t) name =
198 let rec find_cons = function
199 | ({ TypeDecl.Constructor.name = name'; _ } as cons) :: _ when name' = name
200 ->
201 Some (`FConstructor cons)
202 | _ :: tl -> find_cons tl
203 | [] -> None
204 in
205 let rec find_field = function
206 | ({ TypeDecl.Field.name = name'; _ } as field) :: _ when name' = name ->
207 Some (`FField field)
208 | _ :: tl -> find_field tl
209 | [] -> None
210 in
211 let rec find_unboxed_field = function
212 | ({ TypeDecl.UnboxedField.name = name'; _ } as field) :: _ when name' = name ->
213 Some (`FUnboxedField field)
214 | _ :: tl -> find_unboxed_field tl
215 | [] -> None
216 in
217 let rec find_poly = function
218 | TypeExpr.Polymorphic_variant.Constructor
219 ({ TypeExpr.Polymorphic_variant.Constructor.name = name'; _ } as cons)
220 :: _
221 when name' = name || name = "`" ^ name' ->
222 Some (`FPoly cons)
223 | _ :: tl -> find_poly tl
224 | [] -> None
225 in
226 match typ.representation with
227 | Some (Variant cons) -> find_cons cons
228 | Some (Record fields) -> find_field fields
229 | Some (Record_unboxed_product fields) -> find_unboxed_field fields
230 | Some Extensible -> None
231 | None -> (
232 match typ.equation.manifest with
233 | Some (Polymorphic_variant pv) -> find_poly pv.elements
234 | Some _ | None -> None)
235
236let any_in_typext (typext : Extension.t) name =
237 let rec inner = function
238 | ({ Extension.Constructor.name = name'; _ } as cons) :: _ when name' = name
239 ->
240 Some (`FExt (typext, cons))
241 | _ :: tl -> inner tl
242 | [] -> None
243 in
244 inner typext.constructors
245
246let any_in_comment d name =
247 let rec inner xs =
248 match xs with
249 | elt :: rest -> (
250 match elt.Odoc_model.Location_.value with
251 | `Heading lbl when Ident.Name.typed_label lbl.Label.label = name ->
252 Some (`FLabel lbl)
253 | _ -> inner rest)
254 | [] -> None
255 in
256 inner d
257
258let any_in_sig sg name =
259 filter_in_sig sg (function
260 | Signature.Module (id, _, m) when N.module_ id = name ->
261 Some (`FModule (N.typed_module id, Delayed.get m))
262 | ModuleSubstitution (id, ms) when N.module_ id = name ->
263 Some (`FModule_subst ms)
264 | ModuleType (id, mt) when N.module_type id = name ->
265 Some (`FModuleType (N.typed_module_type id, Delayed.get mt))
266 | Type (id, _, t) when N.type_ id = name ->
267 Some (`FType (N.typed_type id, Delayed.get t))
268 | TypeSubstitution (id, ts) when N.type_ id = name -> Some (`FType_subst ts)
269 | Exception (id, exc) when N.exception_ id = name ->
270 Some (`FExn (N.typed_exception id, exc))
271 | Value (id, v) when N.value id = name ->
272 Some (`FValue (N.typed_value id, Delayed.get v))
273 | Class (id, _, c) when N.type_ id = name ->
274 Some (`FClass (N.typed_type id, c))
275 | ClassType (id, _, ct) when N.type_ id = name ->
276 Some (`FClassType (N.typed_type id, ct))
277 | Type (id, _, t) -> (
278 let typ = Delayed.get t in
279 match any_in_type typ name with
280 | Some r -> Some (`In_type (N.typed_type id, typ, r))
281 | None -> None)
282 | TypExt typext -> any_in_typext typext name
283 | Comment (`Docs d) -> any_in_comment d.elements (LabelName.make_std name)
284 | _ -> None)
285
286let signature_in_sig sg name =
287 filter_in_sig sg (function
288 | Signature.Module (id, _, m) when N.module_ id = name ->
289 Some (`FModule (N.typed_module id, Delayed.get m))
290 | ModuleType (id, mt) when N.module_type id = name ->
291 Some (`FModuleType (N.typed_module_type id, Delayed.get mt))
292 | _ -> None)
293
294let module_type_in_sig sg name =
295 find_in_sig sg (function
296 | Signature.ModuleType (id, m)
297 when ModuleTypeName.equal_modulo_shadowing (N.typed_module_type id) name
298 ->
299 Some (`FModuleType (N.typed_module_type id, Delayed.get m))
300 | _ -> None)
301
302let value_in_sig sg name =
303 find_in_sig sg (function
304 | Signature.Value (id, m)
305 when ValueName.equal_modulo_shadowing (N.typed_value id) name
306 || ValueName.to_string (N.typed_value id)
307 = "(" ^ ValueName.to_string name ^ ")" ->
308 (* For operator, the value will have name [(<op>)]. We match that even
309 with name [<op>]. *)
310 Some (`FValue (N.typed_value id, Delayed.get m))
311 | _ -> None)
312
313let label_in_sig sg name =
314 filter_in_sig sg (function
315 | Signature.Comment (`Docs d) -> any_in_comment d.elements name
316 | _ -> None)
317
318let exception_in_sig sg name =
319 find_in_sig sg (function
320 | Signature.Exception (id, e) when N.typed_exception id = name ->
321 Some (`FExn (N.typed_exception id, e))
322 | _ -> None)
323
324let extension_in_sig sg name =
325 let rec inner t = function
326 | ec :: _ when ec.Extension.Constructor.name = ExtensionName.to_string name
327 ->
328 Some (`FExt (t, ec))
329 | _ :: tl -> inner t tl
330 | [] -> None
331 in
332 find_in_sig sg (function
333 | Signature.TypExt t -> inner t t.Extension.constructors
334 | _ -> None)
335
336let label_parent_in_sig sg name =
337 filter_in_sig sg (function
338 | Signature.Module (id, _, m) when N.module_ id = name ->
339 Some (`FModule (N.typed_module id, Component.Delayed.get m))
340 | ModuleType (id, mt) when N.module_type id = name ->
341 Some (`FModuleType (N.typed_module_type id, Component.Delayed.get mt))
342 | Type (id, _, t) when N.type_ id = name ->
343 Some (`FType (N.typed_type id, Component.Delayed.get t))
344 | Class (id, _, c) when N.type_ id = name ->
345 Some (`FClass (N.typed_type id, c))
346 | ClassType (id, _, c) when N.type_ id = name ->
347 Some (`FClassType (N.typed_type id, c))
348 | _ -> None)
349
350let any_in_type_in_sig sg name =
351 filter_in_sig sg (function
352 | Signature.Type (id, _, t) -> (
353 let t = Delayed.get t in
354 match any_in_type t name with
355 | Some x -> Some (`In_type (N.typed_type id, t, x))
356 | None -> None)
357 | _ -> None)
358
359let filter_in_class_signature cs f =
360 let rec inner = function
361 | ClassSignature.Inherit { expr; _ } :: tl -> inner_inherit expr @ inner tl
362 | it :: tl -> (
363 match f it with Some x -> x :: inner tl | None -> inner tl)
364 | [] -> []
365 and inner_inherit = function
366 | Constr _ -> []
367 | Signature cs -> inner cs.items
368 in
369 inner cs.ClassSignature.items
370
371let find_in_class_signature cs f =
372 match filter_in_class_signature cs f with [] -> None | x :: _ -> Some x
373
374let any_in_class_signature cs name =
375 filter_in_class_signature cs (function
376 | ClassSignature.Method (id, m) when N.method_ id = name ->
377 Some (`FMethod (N.typed_method id, m))
378 | InstanceVariable (id, iv) when N.instance_variable id = name ->
379 Some (`FInstance_variable (N.typed_instance_variable id, iv))
380 | _ -> None)
381
382let method_in_class_signature cs name =
383 find_in_class_signature cs (function
384 | ClassSignature.Method (id, m) when N.typed_method id = name ->
385 Some (`FMethod (name, m))
386 | _ -> None)
387
388let instance_variable_in_class_signature cs name =
389 find_in_class_signature cs (function
390 | ClassSignature.InstanceVariable (id, iv)
391 when N.typed_instance_variable id = name ->
392 Some (`FInstance_variable (name, iv))
393 | _ -> None)