jon.recoil.org
this repo has no description
1#if OCAML_VERSION >= (4, 14, 0)
2
3open Odoc_model.Paths
4open Odoc_model.Names
5module Kind = Shape.Sig_component_kind
6
7open Odoc_utils.OptionMonad
8
9type t = Shape.t * Odoc_model.Paths.Identifier.SourceLocation.t Shape.Uid.Map.t
10
11(** Project an identifier into a shape. *)
12let rec shape_of_id env :
13 [< Identifier.NonSrc.t_pv ] Identifier.id -> Shape.t option =
14 let proj parent kind name =
15 let item = Shape.Item.make name kind in
16 match shape_of_id env (parent :> Identifier.NonSrc.t) with
17 | Some shape -> Some (Shape.proj shape item)
18 | None -> None
19 in
20 fun id ->
21 if Identifier.is_hidden id then None else
22 match id.iv with
23 | `Root (_, name) -> (
24 match Env.lookup_impl (ModuleName.to_string_unsafe name) env with
25 | Some impl -> (
26 match impl.shape_info with
27 | Some (shape, _) -> Some shape
28 | None -> None)
29 | _ -> None)
30 | `Module (parent, name) ->
31 proj parent Kind.Module (ModuleName.to_string_unsafe name)
32 | `Result parent ->
33 (* Apply the functor to an empty signature. This doesn't seem to cause
34 any problem, as the shape would stop resolve on an item inside the
35 result of the function, which is what we want. *)
36 shape_of_id env (parent :> Identifier.NonSrc.t) >>= fun parent ->
37 Some (Shape.app parent ~arg:(Shape.str Shape.Item.Map.empty))
38 | `ModuleType (parent, name) ->
39 proj parent Kind.Module_type (ModuleTypeName.to_string_unsafe name)
40 | `Type (parent, name) -> proj parent Kind.Type (TypeName.to_string_unsafe name)
41 | `Value (parent, name) -> proj parent Kind.Value (ValueName.to_string_unsafe name)
42 | `Extension (parent, name) ->
43 proj parent Kind.Extension_constructor (ExtensionName.to_string name)
44 | `ExtensionDecl (parent, name, _) ->
45 proj parent Kind.Extension_constructor (ExtensionName.to_string name)
46 | `Exception (parent, name) ->
47 proj parent Kind.Extension_constructor (ExceptionName.to_string name)
48 | `Class (parent, name) -> proj parent Kind.Class (TypeName.to_string_unsafe name)
49 | `ClassType (parent, name) ->
50 proj parent Kind.Class_type (TypeName.to_string_unsafe name)
51 | `Page _ | `LeafPage _ | `Label _
52 | `Constructor _ | `Field _ | `UnboxedField _ | `Method _ | `InstanceVariable _ | `Parameter _
53 ->
54 (* Not represented in shapes. *)
55 None
56
57let rec shape_of_module_path env : _ -> Shape.t option =
58 let proj parent kind name =
59 let item = Shape.Item.make name kind in
60 match
61 shape_of_module_path env (parent :> Odoc_model.Paths.Path.Module.t)
62 with
63 | Some shape -> Some (Shape.proj shape item)
64 | None -> None
65 in
66 fun (path : Odoc_model.Paths.Path.Module.t) ->
67 match path with
68 | `Resolved _ -> None
69 | `Root name -> (
70 match Env.lookup_impl (ModuleName.to_string name) env with
71 | Some impl -> (
72 match impl.shape_info with
73 | Some (shape, _) -> Some shape
74 | None -> None)
75 | _ -> None)
76 | `Forward _ -> None
77 | `Dot (parent, name) ->
78 proj (parent :> Odoc_model.Paths.Path.Module.t) Kind.Module (ModuleName.to_string_unsafe name)
79 | `Apply (parent, arg) ->
80 shape_of_module_path env (parent :> Odoc_model.Paths.Path.Module.t)
81 >>= fun parent ->
82 shape_of_module_path env (arg :> Odoc_model.Paths.Path.Module.t)
83 >>= fun arg -> Some (Shape.app parent ~arg)
84 | `Identifier (id, _) ->
85 shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t)
86 | `Substituted m ->
87 shape_of_module_path env m
88
89let rec shape_of_kind_path env kind :
90 Odoc_model.Paths.Path.t -> Shape.t option =
91 let proj parent kind name =
92 let item = Shape.Item.make name kind in
93 match shape_of_module_path env parent with
94 | Some shape -> Some (Shape.proj shape item)
95 | None -> None
96 in
97 fun path ->
98 match path with
99 | `Resolved _ -> None
100 | `DotT (parent, name) -> proj parent kind (TypeName.to_string_unsafe name)
101 | `DotMT (parent, name) -> proj parent kind (ModuleTypeName.to_string_unsafe name)
102 | `DotV (parent, name) -> proj parent kind (ValueName.to_string_unsafe name)
103 | `SubstitutedT t -> shape_of_kind_path env kind (t :> Odoc_model.Paths.Path.t)
104 | `SubstitutedMT t -> shape_of_kind_path env kind (t :> Odoc_model.Paths.Path.t)
105 | `SubstitutedCT t -> shape_of_kind_path env kind (t :> Odoc_model.Paths.Path.t)
106 | `Identifier (id, _) -> shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t)
107 | `Substituted t -> shape_of_kind_path env kind (t :> Odoc_model.Paths.Path.t)
108 | `Forward _
109 | `Dot _
110 | `Root _
111 | `Apply _ -> None
112
113module MkId = Identifier.Mk
114
115let unit_of_uid uid =
116 match uid with
117 | Shape.Uid.Compilation_unit s -> Some s
118 | Item { comp_unit; _ } -> Some comp_unit
119 | Predef _ -> None
120 | Internal -> None
121#if defined OXCAML
122 | Unboxed_version _ -> None
123#endif
124
125#if OCAML_VERSION >= (5,2,0)
126let rec traverse_aliases = function
127 | Shape_reduce.Resolved uid -> Some uid
128 | Approximated id -> id
129 | Resolved_alias (_,x) -> traverse_aliases x
130 | _ -> None
131#endif
132
133let lookup_shape : Env.t -> Shape.t -> Identifier.SourceLocation.t option =
134 fun env query ->
135#if OCAML_VERSION < (5,2,0)
136 let module Reduce = Shape.Make_reduce (struct
137 type env = unit
138 let fuel = 10
139 let read_unit_shape ~unit_name =
140 match Env.lookup_impl unit_name env with
141 | Some impl -> (
142 match impl.shape_info with
143 | Some (shape, _) -> Some shape
144 | None -> None)
145 | _ -> None
146 let find_shape _ _ = raise Not_found
147 end) in
148 let result = try Some (Reduce.reduce () query) with Not_found -> None in
149 result >>= fun result ->
150 result.uid >>= fun uid ->
151#else
152 let module Reduce = Shape_reduce.Make(struct
153 let fuel = 10
154 let read_unit_shape ~unit_name =
155 match Env.lookup_impl unit_name env with
156 | Some impl -> (
157 match impl.shape_info with
158 | Some (shape, _) -> Some shape
159 | None -> None)
160 | _ -> None
161#if defined OXCAML
162 let fuel () = Misc.Maybe_bounded.of_int fuel
163 let projection_rules_for_merlin_enabled = false
164 let fuel_for_compilation_units = fuel
165 let max_shape_reduce_steps_per_variable = fuel
166 let max_compilation_unit_depth = fuel
167 let read_unit_shape ~diagnostics:_ ~unit_name = read_unit_shape ~unit_name
168#endif
169 end) in
170 let result = try Some (Reduce.reduce_for_uid Ocaml_env.empty query) with Not_found -> None in
171 result >>= traverse_aliases >>= fun uid ->
172#endif
173 unit_of_uid uid >>= fun unit_name ->
174 match Env.lookup_impl unit_name env with
175 | Some { shape_info ; id = Some id ; _} -> (
176 let uid_to_id =
177 match shape_info with
178 | Some (_, uid_to_id) -> uid_to_id
179 | None -> Odoc_model.Compat.empty_map
180 in
181 match Shape.Uid.Map.find_opt uid uid_to_id with
182 | Some x -> Some x
183 | None -> Some (MkId.source_location_mod id))
184 | None
185 | Some { id = None ; _} -> None
186
187let lookup_def :
188 Env.t -> Identifier.NonSrc.t -> Identifier.SourceLocation.t option =
189 fun env id ->
190 match shape_of_id env id with
191 | None -> None
192 | Some query -> lookup_shape env query
193
194let lookup_module_path env path =
195 match shape_of_module_path env path with
196 | None -> None
197 | Some query -> lookup_shape env query
198
199let lookup_kind_path kind env (path : Odoc_model.Paths.Path.t) =
200 match shape_of_kind_path env kind path with
201 | None -> None
202 | Some query -> lookup_shape env query
203
204let lookup_value_path env p = lookup_kind_path Kind.Value env (p : Odoc_model.Paths.Path.Value.t :> Odoc_model.Paths.Path.t)
205
206let lookup_type_path env p = lookup_kind_path Kind.Type env (p : Odoc_model.Paths.Path.Type.t :> Odoc_model.Paths.Path.t)
207
208let lookup_module_type_path env p = lookup_kind_path Kind.Module_type env (p : Odoc_model.Paths.Path.ModuleType.t :> Odoc_model.Paths.Path.t)
209
210let lookup_class_type_path env p = lookup_kind_path Kind.Class_type env (p : Odoc_model.Paths.Path.ClassType.t :> Odoc_model.Paths.Path.t)
211
212#else
213
214type t = unit
215
216let lookup_def _ _id = None
217
218let lookup_value_path _ _id = None
219
220let lookup_module_path _ _id = None
221
222let lookup_type_path _ _id = None
223
224let lookup_module_type_path _ _id = None
225
226let lookup_class_type_path _ _id = None
227
228#endif