jon.recoil.org
this repo has no description
1open Odoc_model
2open Names
3module Tools_error = struct
4 open Paths
5 (** Errors raised by Tools *)
6
7 type handle_subs_error =
8 [ `UnresolvedPath of [ `Module of Cpath.module_ ]
9 (* Failed to resolve a module path when applying a fragment item *) ]
10
11 type reference_kind =
12 [ `S
13 | `T
14 | `C
15 | `CT
16 | `Page
17 | `Cons
18 | `Field
19 | `UnboxedField
20 | `Label
21 | `Page_path
22 | `Module_path
23 | `Asset_path
24 | `Any_path ]
25
26 type path_kind = [ `Page | `Unit ]
27
28 type expansion_of_module_error =
29 [ `OpaqueModule (* The module does not have an expansion *)
30 | `UnresolvedForwardPath
31 (* The module signature depends upon a forward path *)
32 | `UnresolvedPath of
33 [ `Module of Cpath.module_ * simple_module_lookup_error
34 | `ModuleType of Cpath.module_type * simple_module_type_lookup_error ]
35 (* The path to the module or module type could not be resolved *)
36 | `UnresolvedOriginalPath of Cpath.module_ * simple_module_lookup_error ]
37
38 and simple_module_lookup_error =
39 [ `Local of Env.t * Ident.module_
40 (* Internal error: Found local path during lookup *)
41 | `Find_failure
42 | (* Internal error: the module was not found in the parent signature *)
43 `Lookup_failure of Identifier.Path.Module.t
44 (* Could not find the module in the environment *)
45 | `Lookup_failure_root of ModuleName.t (* Could not find the root module *)
46 | `Parent of parent_lookup_error ]
47
48 and simple_module_type_expr_of_module_error =
49 [ `ApplyNotFunctor
50 (* Internal error: attempt made to apply a module that's not a functor *)
51 | `OpaqueModule (* The module does not have an expansion *)
52 | `UnresolvedForwardPath
53 (* The module signature depends upon a forward path *)
54 | `UnresolvedPath of
55 [ `Module of Cpath.module_ * simple_module_lookup_error
56 | `ModuleType of Cpath.module_type * simple_module_type_lookup_error ]
57 | `Parent of parent_lookup_error ]
58
59 and simple_module_type_lookup_error =
60 [ `LocalMT of Env.t * Ident.module_type
61 (* Internal error: Found local path during lookup *)
62 | `Find_failure
63 (* Internal error: the module was not found in the parent signature *)
64 | `Lookup_failureMT of Identifier.ModuleType.t
65 (* Could not find the module in the environment *)
66 | `Parent of parent_lookup_error ]
67
68 and simple_type_lookup_error =
69 [ `LocalType of Env.t * Ident.type_
70 (* Internal error: Found local path during lookup *)
71 | `Class_replaced
72 (* Class was replaced with a destructive substitution and we're not sure
73 what to do now *)
74 | `OpaqueClass (* Couldn't resolve class signature. *)
75 | `Find_failure
76 (* Internal error: the type was not found in the parent signature *)
77 | `Lookup_failureT of Identifier.Path.Type.t
78 (* Could not find the module in the environment *)
79 | `Parent of parent_lookup_error ]
80
81 and simple_value_lookup_error =
82 [ `LocalValue of Env.t * Ident.value
83 (* Internal error: Found local path during lookup *)
84 | `Find_failure
85 (* Internal error: the type was not found in the parent signature *)
86 | `Lookup_failureV of Identifier.Path.Value.t
87 (* Could not find the module in the environment *)
88 | `Parent of parent_lookup_error ]
89
90 and parent_lookup_error =
91 [ `Parent_sig of expansion_of_module_error
92 (* Error found while calculating the parent signature *)
93 | `Parent_module_type of simple_module_type_lookup_error
94 (* Error found while looking up parent module type *)
95 | `Parent_expr of simple_module_type_expr_of_module_error
96 (* Error found while evaluating parent module expression *)
97 | `Parent_module of simple_module_lookup_error
98 (* Error found while looking up parent module *)
99 | `Parent_type of simple_type_lookup_error
100 | `Fragment_root (* Encountered unexpected fragment root *)
101 | `Parent of parent_lookup_error
102 | `Reference of reference_lookup_error ]
103
104 and reference_lookup_error =
105 [ `Wrong_kind of reference_kind list * reference_kind (* Expected, got *)
106 | `Lookup_by_name of [ reference_kind | `Any ] * string
107 | `Find_by_name of [ reference_kind | `Any ] * string
108 | `Path_error of
109 [ `Not_found | `Is_directory | `Wrong_kind of path_kind list * path_kind ]
110 * Reference.tag_hierarchy
111 * string list
112 | `Parent of parent_lookup_error ]
113
114 type any =
115 [ simple_type_lookup_error
116 | simple_value_lookup_error
117 | simple_module_type_lookup_error
118 | simple_module_type_expr_of_module_error
119 | simple_module_lookup_error
120 | expansion_of_module_error
121 | parent_lookup_error ]
122
123 let pp_reference_kind fmt k =
124 let k =
125 match k with
126 | `S -> "signature"
127 | `T -> "type"
128 | `C -> "class"
129 | `CT -> "class type"
130 | `Page -> "page"
131 | `Cons -> "constructor"
132 | `Field -> "field"
133 | `UnboxedField -> "unboxed field"
134 | `Label -> "label"
135 | `Page_path -> "path to a page"
136 | `Module_path -> "path to a module"
137 | `Asset_path -> "path to an asset"
138 | `Any_path -> "path"
139 in
140 Format.pp_print_string fmt k
141
142 let fpf = Format.fprintf
143
144 let pp_human_list pp_a fmt lst =
145 match List.rev lst with
146 | [] -> ()
147 | [ one ] -> pp_a fmt one
148 | last :: rev_tl ->
149 let pp_sep fmt () = fpf fmt ", " in
150 fpf fmt "%a and %a" (Format.pp_print_list ~pp_sep pp_a) rev_tl pp_a last
151
152 let pp_path fmt (tag, p) =
153 let tag =
154 match tag with
155 | `TRelativePath -> ""
156 | `TAbsolutePath -> "/"
157 | `TCurrentPackage -> "//"
158 in
159 let pp_sep fmt () = fpf fmt "/" in
160 fpf fmt "%s%a" tag (Format.pp_print_list ~pp_sep Format.pp_print_string) p
161
162 let pp_path_kind fmt = function
163 | `Unit -> fpf fmt "module"
164 | `Page -> fpf fmt "page"
165
166 let pp_path_error fmt err tag path =
167 match err with
168 | `Not_found -> fpf fmt "Path '%a' not found" pp_path (tag, path)
169 | `Is_directory ->
170 fpf fmt "Path '%a' points to directory" pp_path (tag, path)
171 | `Wrong_kind (expected, got) ->
172 fpf fmt "Path '%a' is of kind %a but was expected %a" pp_path
173 (tag, path) pp_path_kind got
174 (pp_human_list pp_path_kind)
175 expected
176
177 let rec pp : Format.formatter -> any -> unit =
178 fun fmt err ->
179 let open Component.Fmt in
180 let c = default in
181 match err with
182 | `OpaqueModule -> Format.fprintf fmt "OpaqueModule"
183 | `OpaqueClass -> Format.fprintf fmt "Class is abstract"
184 | `UnresolvedForwardPath -> Format.fprintf fmt "Unresolved forward path"
185 | `UnresolvedPath (`Module (p, e)) ->
186 Format.fprintf fmt "Unresolved module path %a (%a)" (module_path c) p pp
187 (e :> any)
188 | `UnresolvedPath (`ModuleType (p, e)) ->
189 Format.fprintf fmt "Unresolved module type path %a (%a)"
190 (module_type_path c) p pp
191 (e :> any)
192 | `UnresolvedOriginalPath (p, e) ->
193 Format.fprintf fmt "Unresolved original module path %a (%a)"
194 Component.Fmt.(module_path default)
195 p pp
196 (e :> any)
197 | `LocalMT (_, id) -> Format.fprintf fmt "Local id found: %a" Ident.fmt id
198 | `Local (_, id) -> Format.fprintf fmt "Local id found: %a" Ident.fmt id
199 | `LocalType (_, id) -> Format.fprintf fmt "Local id found: %a" Ident.fmt id
200 | `LocalValue (_, id) ->
201 Format.fprintf fmt "Local id found: %a" Ident.fmt id
202 | `Find_failure -> Format.fprintf fmt "Find failure"
203 | `Lookup_failure m ->
204 Format.fprintf fmt "Lookup failure (module): %a" (model_identifier c)
205 (m :> Odoc_model.Paths.Identifier.t)
206 | `Lookup_failure_root r ->
207 Format.fprintf fmt "Lookup failure (root module): %a" ModuleName.fmt r
208 | `Lookup_failureMT m ->
209 Format.fprintf fmt "Lookup failure (module type): %a"
210 (model_identifier c)
211 (m :> Odoc_model.Paths.Identifier.t)
212 | `Lookup_failureT m ->
213 Format.fprintf fmt "Lookup failure (type): %a" (model_identifier c)
214 (m :> Odoc_model.Paths.Identifier.t)
215 | `Lookup_failureV m ->
216 Format.fprintf fmt "Lookup failure (value): %a" (model_identifier c)
217 (m :> Odoc_model.Paths.Identifier.t)
218 | `ApplyNotFunctor -> Format.fprintf fmt "Apply module is not a functor"
219 | `Class_replaced -> Format.fprintf fmt "Class replaced"
220 | `Parent p -> pp fmt (p :> any)
221 | `Parent_sig e -> Format.fprintf fmt "Parent_sig: %a" pp (e :> any)
222 | `Parent_module_type e ->
223 Format.fprintf fmt "Parent_module_type: %a" pp (e :> any)
224 | `Parent_expr e -> Format.fprintf fmt "Parent_expr: %a" pp (e :> any)
225 | `Parent_module e -> Format.fprintf fmt "Parent_module: %a" pp (e :> any)
226 | `Fragment_root -> Format.fprintf fmt "Fragment root"
227 | `Parent_type e -> Format.fprintf fmt "Parent_type: %a" pp (e :> any)
228 | `Reference e -> pp_reference_lookup_error fmt e
229
230 and pp_reference_lookup_error fmt = function
231 | `Wrong_kind (expected, got) ->
232 let pp_sep fmt () = Format.fprintf fmt " or " in
233 Format.fprintf fmt "is of kind %a but expected %a" pp_reference_kind got
234 (Format.pp_print_list ~pp_sep pp_reference_kind)
235 expected
236 | `Lookup_by_name (kind, name) | `Find_by_name (kind, name) -> (
237 match kind with
238 | `Any -> Format.fprintf fmt "Couldn't find %S" name
239 | #reference_kind as kind ->
240 Format.fprintf fmt "Couldn't find %a %S" pp_reference_kind kind name
241 )
242 | `Path_error (err, tag, path) -> pp_path_error fmt err tag path
243 | `Parent e -> pp fmt (e :> any)
244end
245
246type kind = [ `OpaqueModule | `Root of string ]
247
248let rec kind_of_module_cpath = function
249 | `Root name -> Some (`Root (ModuleName.to_string name))
250 | `Substituted p' | `Dot (p', _) -> kind_of_module_cpath p'
251 | `Apply (a, b) -> (
252 match kind_of_module_cpath a with
253 | Some _ as a -> a
254 | None -> kind_of_module_cpath b)
255 | _ -> None
256
257let rec kind_of_module_type_cpath = function
258 | `Substituted p' -> kind_of_module_type_cpath p'
259 | `DotMT (p', _) -> kind_of_module_cpath p'
260 | _ -> None
261
262(** [Some (`Root _)] for errors during lookup of root modules or [None] for
263 other errors. *)
264let rec kind_of_error : Tools_error.any -> kind option = function
265 | `UnresolvedPath (`Module (cp, e)) -> (
266 match kind_of_module_cpath cp with
267 | None -> kind_of_error (e :> Tools_error.any)
268 | x -> x)
269 | `UnresolvedPath (`ModuleType (cp, e)) -> (
270 match kind_of_module_type_cpath cp with
271 | None -> kind_of_error (e :> Tools_error.any)
272 | x -> x)
273 | `Lookup_failure { iv = `Root (_, name); _ } ->
274 Some (`Root (ModuleName.to_string name))
275 | `Lookup_failure_root name -> Some (`Root (ModuleName.to_string name))
276 | `Parent (`Parent_sig e) -> kind_of_error (e :> Tools_error.any)
277 | `Parent (`Parent_module_type e) -> kind_of_error (e :> Tools_error.any)
278 | `Parent (`Parent_expr e) -> kind_of_error (e :> Tools_error.any)
279 | `Parent (`Parent_module e) -> kind_of_error (e :> Tools_error.any)
280 | `Parent (`Parent _ as e) -> kind_of_error (e :> Tools_error.any)
281 | `OpaqueModule ->
282 (* Don't turn OpaqueModule warnings into errors *)
283 Some `OpaqueModule
284 | _ -> None
285
286and kind_of_type_of_desc : Component.ModuleType.type_of_desc -> kind option =
287 function
288 | ModPath cp -> kind_of_module_cpath cp
289 | StructInclude cp -> kind_of_module_cpath cp
290
291let kind_of_error ~what = function
292 | Some e -> kind_of_error (e :> Tools_error.any)
293 | None -> (
294 match what with
295 | `Include (Component.Include.Alias cp) -> kind_of_module_cpath cp
296 | `Module { Odoc_model.Paths.Identifier.iv = `Root (_, name); _ } ->
297 Some (`Root (ModuleName.to_string name))
298 | _ -> None)
299
300open Paths
301
302type what =
303 [ `Functor_parameter of Identifier.FunctorParameter.t
304 | `Value of Identifier.Value.t
305 | `Value_path of Cpath.value
306 | `Class of Identifier.Class.t
307 | `Class_type of Identifier.ClassType.t
308 | `Module of Identifier.Module.t
309 | `Module_type of Identifier.Signature.t
310 | `Module_path of Cpath.module_
311 | `Module_type_path of Cpath.module_type
312 | `Module_type_U of Component.ModuleType.U.expr
313 | `Include of Component.Include.decl
314 | `Package of Cpath.module_type
315 | `Type of Cfrag.type_
316 | `Type_path of Cpath.type_
317 | `Class_type_path of Cpath.class_type
318 | `With_module of Cfrag.module_
319 | `With_module_type of Cfrag.module_type
320 | `With_type of Cfrag.type_
321 | `Module_type_expr of Component.ModuleType.expr
322 | `Module_type_u_expr of Component.ModuleType.U.expr
323 | `Child_module of string
324 | `Child_page of string
325 | `Reference of Reference.t ]
326
327let report ~(what : what) ?tools_error action =
328 let action =
329 match action with
330 | `Lookup -> "lookup"
331 | `Expand -> "compile expansion for"
332 | `Resolve_module_type -> "resolve type of"
333 | `Resolve -> "resolve"
334 | `Compile -> "compile"
335 in
336 let pp_tools_error fmt = function
337 | Some e -> Format.fprintf fmt " %a" Tools_error.pp (e :> Tools_error.any)
338 | None -> ()
339 in
340 let open Component.Fmt in
341 let report_error ~non_fatal =
342 let r subject pp_a a =
343 Lookup_failures.report ~non_fatal "Failed to %s %s %a%a" action subject
344 pp_a a pp_tools_error tools_error
345 in
346 let c = default in
347 let fmt_id fmt id = model_identifier c fmt (id :> Paths.Identifier.t) in
348 match what with
349 | `Functor_parameter id -> r "functor parameter" fmt_id id
350 | `Value id -> r "value" fmt_id id
351 | `Class id -> r "class" fmt_id id
352 | `Class_type id -> r "class type" fmt_id id
353 | `Module id -> r "module" fmt_id id
354 | `Module_type id -> r "module type" fmt_id id
355 | `Module_path path -> r "module path" (module_path c) path
356 | `Module_type_path path -> r "module type path" (module_type_path c) path
357 | `Module_type_U expr -> r "module type expr" (u_module_type_expr c) expr
358 | `Include decl -> r "include" (include_decl c) decl
359 | `Package path ->
360 r "module package" (module_type_path c) (path :> Cpath.module_type)
361 | `Type cfrag -> r "type" (type_fragment c) cfrag
362 | `Type_path path -> r "type" (type_path c) path
363 | `Value_path path -> r "value" (value_path c) path
364 | `Class_type_path path -> r "class_type" (class_type_path c) path
365 | `With_module frag -> r "module substitution" (module_fragment c) frag
366 | `With_module_type frag ->
367 r "module type substitution" (module_type_fragment c) frag
368 | `With_type frag -> r "type substitution" (type_fragment c) frag
369 | `Module_type_expr cexpr ->
370 r "module type expression" (module_type_expr c) cexpr
371 | `Module_type_u_expr cexpr ->
372 r "module type u expression" (u_module_type_expr c) cexpr
373 | `Child_module rf -> r "child module" Astring.String.pp rf
374 | `Child_page rf -> r "child page" Astring.String.pp rf
375 | `Reference ref -> r "reference" (model_reference c) ref
376 in
377 match kind_of_error ~what tools_error with
378 | Some (`Root name) -> Lookup_failures.report_root ~name
379 | Some `OpaqueModule -> report_error ~non_fatal:true
380 | None -> report_error ~non_fatal:false