jon.recoil.org
this repo has no description
1open Result
2module Error = Odoc_model.Error
3
4let read_string parent_definition filename text =
5 let location =
6 let pos =
7 Lexing.{ pos_fname = filename; pos_lnum = 1; pos_cnum = 0; pos_bol = 0 }
8 in
9 Location.{ loc_start = pos; loc_end = pos; loc_ghost = true }
10 in
11 Error.catch_errors_and_warnings (fun () ->
12 Doc_attr.page parent_definition location text)
13
14let corrupted file =
15 Error.raise_exception (Error.filename_only "corrupted" file)
16
17let not_a_typedtree file =
18 Error.raise_exception (Error.filename_only "not a Typedtree" file)
19
20let not_an_implementation file =
21 Error.raise_exception (Error.filename_only "not an implementation" file)
22
23let not_an_interface file =
24 Error.raise_exception (Error.filename_only "not an interface" file)
25
26let wrong_version file =
27 Error.raise_exception (Error.filename_only "wrong OCaml version" file)
28
29let error_msg file (msg : string) =
30 Error.raise_exception (Error.filename_only "%s" msg file)
31
32type make_root =
33 module_name:string ->
34 digest:Digest.t ->
35 (Odoc_model.Root.t, [ `Msg of string ]) result
36
37exception Corrupted
38
39exception Not_an_implementation
40
41exception Not_an_interface
42
43exception Make_root_error of string
44
45let read_cmt_infos source_id ~filename root digest imports () =
46 match Cmt_format.read_cmt filename with
47 | exception Cmi_format.Error _ -> raise Corrupted
48 | cmt_info -> (
49 match cmt_info.cmt_annots with
50 | Implementation impl ->
51 let shape_infos =
52 Odoc_model.Compat.shape_info_of_cmt_infos cmt_info
53 in
54 Implementation.read_cmt_infos source_id shape_infos impl digest root
55 imports
56 | _ -> raise Not_an_implementation)
57
58let make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id
59 ?canonical content =
60 let open Odoc_model.Lang.Compilation_unit in
61 let interface, digest =
62 match interface with
63 | Some digest -> (true, digest)
64 | None -> (
65 match List.assoc name imports with
66 | Some digest -> (false, digest)
67 | None -> raise Corrupted
68 | exception Not_found -> raise Corrupted)
69 in
70 let root =
71 match make_root ~module_name:name ~digest with
72 | Ok root -> root
73 | Error (`Msg m) -> raise (Make_root_error m)
74 in
75 let imports = List.filter (fun (name', _) -> name <> name') imports in
76 let imports = List.map (fun (s, d) -> Import.Unresolved (s, d)) imports in
77 let source =
78 match sourcefile with
79 | Some (Some file, Some digest, build_dir) ->
80 Some { Source.file; digest; build_dir }
81 | _ -> None
82 in
83 let source_loc_jane =
84 match sourcefile with
85 | Some (Some file, _, build_dir) ->
86 Some {Odoc_model.Lang.Source_loc_jane.filename = build_dir ^ "/" ^ file ; line_number = 1}
87 | _ -> None
88 in
89 {
90 id;
91 root;
92 digest;
93 imports;
94 source;
95 interface;
96 hidden = Odoc_model.Names.contains_double_underscore name;
97 content;
98 expansion = None;
99 linked = false;
100 canonical;
101 source_loc = None;
102 source_loc_jane
103 }
104
105let compilation_unit_of_sig ~make_root ~imports ~interface ?sourcefile ~name ~id
106 ?canonical sg =
107 let content = Odoc_model.Lang.Compilation_unit.Module sg in
108 make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id
109 ?canonical content
110
111#if defined OXCAML
112let unit_name_as_string = Compilation_unit.name_as_string
113let name_to_string = Compilation_unit.Name.to_string
114#else
115let unit_name_as_string x = x
116let name_to_string x = x
117#endif
118
119let read_cmti ~make_root ~parent ~filename ~warnings_tag () =
120 let cmt_info = Cmt_format.read_cmt filename in
121 match cmt_info.cmt_annots with
122 | Interface intf -> (
123 match cmt_info.cmt_interface_digest with
124 | None -> raise Corrupted
125 | Some digest as interface ->
126 let _ =
127 try Odoc_model.Names.set_unique_ident (Digest.to_hex digest)
128 with _ -> ()
129 in
130 let name = cmt_info.cmt_modname |> unit_name_as_string in
131 let sourcefile =
132 ( cmt_info.cmt_sourcefile,
133 cmt_info.cmt_source_digest,
134 cmt_info.cmt_builddir )
135 in
136 Cmti.cmti_builddir := cmt_info.cmt_builddir;
137 let id, sg, canonical =
138 Cmti.read_interface parent name ~warnings_tag intf
139 in
140#if defined OXCAML
141 let imports =
142 cmt_info.cmt_imports
143 |> Array.map (fun import ->
144 Import_info.name import |> Compilation_unit.Name.to_string,
145 Import_info.crc import)
146 |> Array.to_list
147 in
148#else
149 let imports = cmt_info.cmt_imports in
150#endif
151 compilation_unit_of_sig ~make_root ~imports
152 ~interface ~sourcefile ~name ~id ?canonical sg)
153 | _ -> raise Not_an_interface
154
155let read_cmt ~make_root ~parent ~filename ~warnings_tag () =
156 match Cmt_format.read_cmt filename with
157 | exception Cmi_format.Error (Not_an_interface _) ->
158 raise Not_an_implementation
159 | cmt_info -> (
160 let name = cmt_info.cmt_modname |> unit_name_as_string in
161 let sourcefile =
162 ( cmt_info.cmt_sourcefile,
163 cmt_info.cmt_source_digest,
164 cmt_info.cmt_builddir )
165 in
166 let interface = cmt_info.cmt_interface_digest in
167 (match cmt_info.cmt_interface_digest with
168 | None -> (
169 match cmt_info.cmt_source_digest with
170 | Some x -> (
171 try Odoc_model.Names.set_unique_ident (Digest.to_hex x)
172 with _ -> ())
173 | None -> ( try Odoc_model.Names.set_unique_ident name with _ -> ()))
174 | Some digest -> (
175 try Odoc_model.Names.set_unique_ident (Digest.to_hex digest)
176 with _ -> ()));
177#if defined OXCAML
178 let imports =
179 cmt_info.cmt_imports
180 |> Array.map (fun import ->
181 Import_info.name import |> Compilation_unit.Name.to_string,
182 Import_info.crc import)
183 |> Array.to_list
184 in
185#else
186 let imports = cmt_info.cmt_imports in
187#endif
188 match cmt_info.cmt_annots with
189 | Packed (_, files) ->
190 let id =
191 Odoc_model.Paths.Identifier.Mk.root
192 (parent, Odoc_model.Names.ModuleName.make_std name)
193 in
194 let items =
195 List.map
196 (fun file ->
197 let pref = Misc.chop_extensions file in
198 Astring.String.Ascii.capitalize (Filename.basename pref))
199 files
200 in
201 let items = List.sort String.compare items in
202 let items =
203 List.map
204 (fun name ->
205 let id =
206 Odoc_model.Paths.Identifier.Mk.module_
207 (id, Odoc_model.Names.ModuleName.make_std name)
208 in
209 let path = `Root (Odoc_model.Names.ModuleName.make_std name) in
210 { Odoc_model.Lang.Compilation_unit.Packed.id; path })
211 items
212 in
213 let content = Odoc_model.Lang.Compilation_unit.Pack items in
214 make_compilation_unit ~make_root ~imports ~interface ~sourcefile ~name
215 ~id content
216 | Implementation impl ->
217 Cmt.cmt_builddir := cmt_info.cmt_builddir;
218 Cmti.cmti_builddir := cmt_info.cmt_builddir;
219 let id, sg, canonical =
220 Cmt.read_implementation parent name ~warnings_tag impl
221 in
222 compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile
223 ~name ~id ?canonical sg
224 | _ -> raise Not_an_implementation)
225
226#if defined OXCAML
227let compilation_unit_of_import_info (info : Import_info.Intf.Nonalias.t option) =
228 match info with
229 | None -> None
230 | Some (Parameter, _) -> None
231 | Some (Normal cu, _) -> Some (cu |> Compilation_unit.full_path_as_string)
232#else
233let compilation_unit_of_import_info info =
234 Option.map snd info
235#endif
236
237#if defined OXCAML
238let cmi_crcs cmi_info =
239 List.map (fun import -> Import_info.name import, Import_info.Intf.info import)
240 (Array.to_list cmi_info.Cmi_format.cmi_crcs)
241#else
242let cmi_crcs cmi_info = cmi_info.Cmi_format.cmi_crcs
243#endif
244
245let read_cmi ~make_root ~parent ~filename ~warnings_tag () =
246 let cmi_info = Cmi_format.read_cmi filename in
247 let cmi_crcs = cmi_crcs cmi_info in
248 match cmi_crcs with
249 | (name, (Some _ as interface)) :: imports when name = cmi_info.cmi_name ->
250 let name = name |> name_to_string in
251 let id, sg =
252 Cmi.read_interface parent name ~warnings_tag
253 (Odoc_model.Compat.signature cmi_info.cmi_sign)
254 in
255#if defined OXCAML
256 let imports =
257 imports
258 |> List.map (fun (name, info_opt) ->
259 name |> Compilation_unit.Name.to_string,
260 compilation_unit_of_import_info info_opt)
261 in
262 let interface = interface |> Option.map snd in
263#endif
264 compilation_unit_of_sig ~make_root ~imports ~interface ~name ~id sg
265 | _ -> raise Corrupted
266
267let read_impl ~make_root ~filename ~source_id () =
268 match Cmt_format.read_cmt filename with
269 | exception Cmi_format.Error (Not_an_interface _) ->
270 raise Not_an_implementation
271 | cmt_info -> (
272 let name = cmt_info.cmt_modname |> unit_name_as_string in
273 let _sourcefile =
274 ( cmt_info.cmt_sourcefile,
275 cmt_info.cmt_source_digest,
276 cmt_info.cmt_builddir )
277 in
278 let interface = cmt_info.cmt_interface_digest in
279 let imports = cmt_info.cmt_imports in
280#if defined OXCAML
281 let imports =
282 imports
283 |> Array.map (fun import ->
284 Import_info.name import |> Compilation_unit.Name.to_string,
285 Import_info.crc import)
286 |> Array.to_list
287 in
288#endif
289 match cmt_info.cmt_annots with
290 | Implementation _impl ->
291 let digest =
292 match interface with
293 | Some digest -> digest
294 | None -> (
295 match List.assoc name imports with
296 | Some digest -> digest
297 | None -> raise Corrupted
298 | exception Not_found -> raise Corrupted)
299 in
300 let () =
301 match source_id with
302 | None -> Odoc_model.Names.set_unique_ident filename
303 | Some source_id ->
304 Odoc_model.Names.set_unique_ident
305 (Odoc_model.Paths.Identifier.fullname source_id
306 |> String.concat "-")
307 in
308 let root =
309 match make_root ~module_name:name ~digest with
310 | Ok root -> root
311 | Error (`Msg m) -> raise (Make_root_error m)
312 in
313 let imports = List.filter (fun (name', _) -> name <> name') imports in
314 let imports =
315 List.map
316 (fun (s, d) ->
317 Odoc_model.Lang.Compilation_unit.Import.Unresolved (s, d))
318 imports
319 in
320 read_cmt_infos source_id ~filename root digest imports ()
321 | _ -> raise Not_an_implementation)
322
323(** Catch errors from reading the object files and some internal errors *)
324let wrap_errors ~filename f =
325 Odoc_model.Error.catch_errors_and_warnings (fun () ->
326 try f () with
327 | Cmi_format.Error (Not_an_interface _) -> not_an_interface filename
328 | Cmt_format.Error (Not_a_typedtree _) -> not_a_typedtree filename
329 | Cmi_format.Error (Wrong_version_interface _) -> wrong_version filename
330 | Cmi_format.Error (Corrupted_interface _) -> corrupted filename
331 | Corrupted -> corrupted filename
332 | Not_an_implementation -> not_an_implementation filename
333 | Not_an_interface -> not_an_interface filename
334 | Make_root_error m -> error_msg filename m)
335
336let read_cmti ~make_root ~parent ~filename ~warnings_tag =
337 wrap_errors ~filename (read_cmti ~make_root ~parent ~filename ~warnings_tag)
338
339let read_cmt ~make_root ~parent ~filename ~warnings_tag =
340 wrap_errors ~filename (read_cmt ~make_root ~parent ~filename ~warnings_tag)
341
342let read_impl ~make_root ~filename ~source_id =
343 wrap_errors ~filename (read_impl ~make_root ~source_id ~filename)
344
345let read_cmi ~make_root ~parent ~filename ~warnings_tag =
346 wrap_errors ~filename (read_cmi ~make_root ~parent ~filename ~warnings_tag)
347
348let read_location = Doc_attr.read_location
349
350let parse_attribute = Doc_attr.parse_attribute