jon.recoil.org
this repo has no description
1(* Packages *)
2
3type dep = string * Digest.t
4
5(* type id = Odoc.id *)
6
7type intf = { mif_hash : string; mif_path : Fpath.t; mif_deps : dep list }
8
9let pp_intf fmt (i : intf) =
10 Format.fprintf fmt "@[<hov>{@,mif_hash: %s;@,mif_path: %a;@,mif_deps: %a@,}@]"
11 i.mif_hash Fpath.pp i.mif_path
12 (Fmt.Dump.list (Fmt.Dump.pair Fmt.string Fmt.string))
13 i.mif_deps
14
15type src_info = { src_path : Fpath.t }
16
17let pp_src_info fmt i =
18 Format.fprintf fmt "@[<hov>{@,src_path: %a@,}@]" Fpath.pp i.src_path
19
20type impl = {
21 mip_path : Fpath.t;
22 mip_src_info : src_info option;
23 mip_deps : dep list;
24}
25
26let pp_impl fmt i =
27 Format.fprintf fmt
28 "@[<hov>{@,mip_path: %a;@,mip_src_info: %a;@,mip_deps: %a@,}@]" Fpath.pp
29 i.mip_path
30 (Fmt.Dump.option pp_src_info)
31 i.mip_src_info
32 (Fmt.Dump.list (Fmt.Dump.pair Fmt.string Fmt.string))
33 i.mip_deps
34
35type modulety = {
36 m_name : string;
37 m_intf : intf;
38 m_impl : impl option;
39 m_hidden : bool;
40}
41
42let pp_modulety fmt i =
43 Format.fprintf fmt
44 "@[<hov>{@,m_name: %s;@,m_intf: %a;@,m_impl: %a;@,m_hidden: %b@,}@]"
45 i.m_name pp_intf i.m_intf (Fmt.Dump.option pp_impl) i.m_impl i.m_hidden
46
47type mld = { mld_path : Fpath.t; mld_rel_path : Fpath.t }
48
49type md = { md_path : Fpath.t; md_rel_path : Fpath.t }
50
51let pp_mld fmt m =
52 Format.fprintf fmt "@[<hov>{@,mld_path: %a;@,mld_rel_path: %a@,}@]" Fpath.pp
53 m.mld_path Fpath.pp m.mld_rel_path
54
55let pp_md fmt m =
56 Format.fprintf fmt "@[<hov>{@,md_path: %a;@,md_rel_path: %a@,}@]" Fpath.pp
57 m.md_path Fpath.pp m.md_rel_path
58
59type asset = { asset_path : Fpath.t; asset_rel_path : Fpath.t }
60
61let pp_asset fmt m =
62 Format.fprintf fmt "@[<hov>{@,asset_path: %a;@,asset_rel_path: %a@,}@]"
63 Fpath.pp m.asset_path Fpath.pp m.asset_rel_path
64
65type libty = {
66 lib_name : string;
67 dir : Fpath.t;
68 archive_name : string option;
69 lib_deps : Util.StringSet.t;
70 modules : modulety list;
71 id_override : string option;
72}
73
74let pp_libty fmt l =
75 Format.fprintf fmt
76 "@[<hov>{@,\
77 lib_name: %s;@,\
78 dir: %a;@,\
79 archive_name: %a;@,\
80 lib_deps: %a;@,\
81 modules: %a@,\
82 id_override: %a@,\n\
83 \ }@]"
84 l.lib_name Fpath.pp l.dir
85 (Fmt.Dump.option Fmt.string)
86 l.archive_name
87 (Fmt.list ~sep:Fmt.comma Fmt.string)
88 (Util.StringSet.elements l.lib_deps)
89 (Fmt.Dump.list pp_modulety)
90 l.modules
91 Fmt.Dump.(option string)
92 l.id_override
93
94type t = {
95 name : string;
96 version : string;
97 libraries : libty list;
98 mlds : mld list;
99 assets : asset list;
100 selected : bool;
101 remaps : (string * string) list;
102 other_docs : md list;
103 pkg_dir : Fpath.t;
104 doc_dir : Fpath.t;
105 config : Global_config.t;
106}
107
108let pp fmt t =
109 Format.fprintf fmt
110 "@[<hov>{@,\
111 name: %s;@,\
112 version: %s;@,\
113 libraries: %a;@,\
114 mlds: %a;@,\
115 assets: %a;@,\
116 selected: %b;@,\
117 other_docs: %a;@,\
118 pkg_dir: %a@,\
119 }@]"
120 t.name t.version (Fmt.Dump.list pp_libty) t.libraries (Fmt.Dump.list pp_mld)
121 t.mlds (Fmt.Dump.list pp_asset) t.assets t.selected (Fmt.Dump.list pp_md)
122 t.other_docs Fpath.pp t.pkg_dir
123
124let maybe_prepend_top top_dir dir =
125 match top_dir with None -> dir | Some d -> Fpath.(d // dir)
126
127let pkg_dir top_dir pkg_name = maybe_prepend_top top_dir Fpath.(v pkg_name)
128
129module Module = struct
130 type t = modulety
131
132 let pp ppf (t : t) =
133 Fmt.pf ppf "name: %s@.intf: %a@.impl: %a@.hidden: %b@." t.m_name Fpath.pp
134 t.m_intf.mif_path (Fmt.option pp_impl) t.m_impl t.m_hidden
135
136 let is_hidden name = Astring.String.is_infix ~affix:"__" name
137
138 let vs libsdir cmtidir modules =
139 let dir = match cmtidir with None -> libsdir | Some dir -> dir in
140 let mk m_name =
141 let exists ext =
142 let p =
143 Fpath.(dir // add_ext ext (v (String.uncapitalize_ascii m_name)))
144 in
145 let upperP =
146 Fpath.(dir // add_ext ext (v (String.capitalize_ascii m_name)))
147 in
148 Logs.debug (fun m ->
149 m "Checking %a (then %a)" Fpath.pp p Fpath.pp upperP);
150 match Bos.OS.File.exists p with
151 | Ok true -> Some p
152 | _ -> (
153 match Bos.OS.File.exists upperP with
154 | Ok true -> Some upperP
155 | _ -> None)
156 in
157 let mk_intf mif_path =
158 match Odoc.compile_deps mif_path with
159 | Ok { digest; deps } ->
160 { mif_hash = digest; mif_path; mif_deps = deps }
161 | Error _ -> failwith "bad deps"
162 in
163 let mk_impl mip_path =
164 (* Directories in which we should look for source files *)
165 let src_dirs =
166 match cmtidir with None -> [ libsdir ] | Some d2 -> [ libsdir; d2 ]
167 in
168
169 let mip_src_info =
170 match Ocamlobjinfo.get_source mip_path src_dirs with
171 | None ->
172 Logs.debug (fun m -> m "No source found for module %s" m_name);
173 None
174 | Some src_path ->
175 Logs.debug (fun m ->
176 m "Found source file %a for %s" Fpath.pp src_path m_name);
177 Some { src_path }
178 in
179 let mip_deps =
180 match Odoc.compile_deps mip_path with
181 | Ok { digest = _; deps } -> deps
182 | Error _ -> failwith "bad deps"
183 in
184 { mip_src_info; mip_path; mip_deps }
185 in
186 let state = (exists "cmt", exists "cmti") in
187
188 let m_hidden = is_hidden m_name in
189 try
190 let r (m_intf, m_impl) = Some { m_name; m_intf; m_impl; m_hidden } in
191 match state with
192 | Some cmt, Some cmti -> r (mk_intf cmti, Some (mk_impl cmt))
193 | Some cmt, None -> r (mk_intf cmt, Some (mk_impl cmt))
194 | None, Some cmti -> r (mk_intf cmti, None)
195 | None, None ->
196 Logs.info (fun m -> m "No files for module: %s" m_name);
197 None
198 with _ ->
199 Logs.err (fun m -> m "Error processing module %s. Ignoring." m_name);
200 None
201 in
202
203 Eio.Fiber.List.filter_map mk modules
204end
205
206module Lib = struct
207 let handle_virtual_lib ~dir ~id_override ~lib_name ~all_lib_deps =
208 let modules =
209 match
210 Bos.OS.Dir.fold_contents
211 (fun p acc ->
212 if Fpath.has_ext "cmti" p then
213 let m_name = Fpath.rem_ext p |> Fpath.basename in
214 m_name :: acc
215 else acc)
216 [] dir
217 with
218 | Ok x -> x
219 | Error (`Msg e) ->
220 Logs.err (fun m -> m "Error reading dir %a: %s" Fpath.pp dir e);
221 []
222 in
223 let modules = Module.vs dir None modules in
224 let lib_deps =
225 try Util.StringMap.find lib_name all_lib_deps
226 with _ -> Util.StringSet.empty
227 in
228 [ { lib_name; archive_name = None; modules; lib_deps; dir; id_override } ]
229
230 let v ~libname_of_archive ~pkg_name ~dir ~cmtidir ~all_lib_deps ~cmi_only_libs
231 ~id_override =
232 Logs.debug (fun m ->
233 m "Classifying dir %a for package %s" Fpath.pp dir pkg_name);
234 let dirs =
235 match cmtidir with None -> [ dir ] | Some dir2 -> [ dir; dir2 ]
236 in
237 let results = Odoc.classify dirs in
238 match List.length results with
239 | 0 -> (
240 match
241 List.find_opt (fun dir -> List.mem_assoc dir cmi_only_libs) dirs
242 with
243 | None -> []
244 | Some dir ->
245 let lib_name = List.assoc dir cmi_only_libs in
246 handle_virtual_lib ~dir ~lib_name ~all_lib_deps ~id_override)
247 | _ ->
248 Logs.debug (fun m -> m "Got %d lines" (List.length results));
249 List.filter_map
250 (fun (archive_name, modules) ->
251 match
252 Fpath.Map.find Fpath.(dir / archive_name) libname_of_archive
253 with
254 | Some lib_name ->
255 let modules = Module.vs dir cmtidir modules in
256 let lib_deps =
257 try Util.StringMap.find lib_name all_lib_deps
258 with _ -> Util.StringSet.empty
259 in
260 Some
261 {
262 lib_name;
263 archive_name = Some archive_name;
264 modules;
265 lib_deps;
266 dir;
267 id_override;
268 }
269 | None ->
270 Logs.info (fun m ->
271 m "No entry for '%a' in libname_of_archive" Fpath.pp
272 Fpath.(dir / archive_name));
273 Logs.info (fun m ->
274 m "Unable to determine library of archive %s: Ignoring."
275 archive_name);
276 None)
277 results
278
279 let pp ppf t =
280 Fmt.pf ppf "archive: %a modules: [@[<hov 2>@,%a@]@,]"
281 Fmt.(option string)
282 t.archive_name
283 Fmt.(list ~sep:sp Module.pp)
284 t.modules
285end
286
287(* Construct the list of mlds and assets from a package name and its list of pages *)
288let mk_mlds docs =
289 List.fold_left
290 (fun (mlds, assets, others) (doc : Opam.doc_file) ->
291 match doc.kind with
292 | `Mld ->
293 ( { mld_path = doc.file; mld_rel_path = doc.rel_path } :: mlds,
294 assets,
295 others )
296 | `Asset ->
297 ( mlds,
298 { asset_path = doc.file; asset_rel_path = doc.rel_path } :: assets,
299 others )
300 | `Other ->
301 ( mlds,
302 assets,
303 { md_path = doc.file; md_rel_path = doc.rel_path } :: others ))
304 ([], [], []) docs
305
306let fix_missing_deps pkgs =
307 let lib_name_by_hash =
308 List.fold_right
309 (fun pkg acc ->
310 List.fold_left
311 (fun acc lib ->
312 List.fold_left
313 (fun acc m ->
314 Util.StringMap.update m.m_intf.mif_hash
315 (function
316 | None -> Some [ lib.lib_name ]
317 | Some l -> Some (lib.lib_name :: l))
318 acc)
319 acc lib.modules)
320 acc pkg.libraries)
321 pkgs Util.StringMap.empty
322 in
323 List.map
324 (fun pkg ->
325 let libraries =
326 List.map
327 (fun lib ->
328 let lib_deps = lib.lib_deps in
329 let new_lib_deps =
330 List.fold_left
331 (fun acc m ->
332 let if_deps =
333 Util.StringSet.of_list (List.map snd m.m_intf.mif_deps)
334 in
335 let impl_deps =
336 match m.m_impl with
337 | Some i -> Util.StringSet.of_list (List.map snd i.mip_deps)
338 | None -> Util.StringSet.empty
339 in
340 let deps = Util.StringSet.union if_deps impl_deps in
341 Util.StringSet.fold
342 (fun hash acc ->
343 match Util.StringMap.find hash lib_name_by_hash with
344 | exception Not_found -> acc
345 | deps ->
346 if
347 List.mem lib.lib_name deps
348 || List.exists
349 (fun d -> Util.StringSet.mem d lib_deps)
350 deps
351 then acc
352 else Util.StringSet.add (List.hd deps) acc)
353 deps acc)
354 Util.StringSet.empty lib.modules
355 in
356 if Util.StringSet.cardinal new_lib_deps > 0 then
357 Logs.debug (fun m ->
358 m "Adding missing deps to %s: %a" lib.lib_name
359 Fmt.(list string)
360 (Util.StringSet.elements new_lib_deps));
361 { lib with lib_deps = Util.StringSet.union new_lib_deps lib_deps })
362 pkg.libraries
363 in
364 { pkg with libraries })
365 pkgs
366
367let of_libs ~packages_dir libs =
368 let Ocamlfind.Db.
369 { archives_by_dir; libname_of_archive; cmi_only_libs; all_lib_deps; _ }
370 =
371 Ocamlfind.Db.create libs
372 in
373
374 (* Opam gives us a map of packages to directories, and vice-versa *)
375 let opam_map, opam_rmap = Opam.pkg_to_dir_map () in
376
377 (* Now we can construct the packages *)
378 let packages =
379 Fpath.Map.fold
380 (fun dir archives acc ->
381 match Fpath.Map.find dir opam_rmap with
382 | None ->
383 Logs.debug (fun m -> m "No package for dir %a\n%!" Fpath.pp dir);
384 acc
385 | Some pkg ->
386 let libraries =
387 Lib.v ~libname_of_archive ~pkg_name:pkg.name ~dir ~cmtidir:None
388 ~all_lib_deps ~cmi_only_libs ~id_override:None
389 in
390 let libraries =
391 List.filter
392 (fun l ->
393 match l.archive_name with
394 | None -> true
395 | Some a -> Util.StringSet.mem a archives)
396 libraries
397 in
398 Util.StringMap.update pkg.name
399 (function
400 | Some pkg ->
401 let libraries = libraries @ pkg.libraries in
402 Some { pkg with libraries }
403 | None ->
404 let pkg_dir = pkg_dir packages_dir pkg.name in
405
406 let _, { Opam.docs; odoc_config; _ } =
407 List.find
408 (fun (pkg', _) ->
409 (* Logs.debug (fun m ->
410 m "Checking %s against %s" pkg.Opam.name pkg'.Opam.name); *)
411 pkg = pkg')
412 opam_map
413 in
414
415 let config =
416 match odoc_config with
417 | None -> Global_config.empty
418 | Some f -> Global_config.load f
419 in
420
421 let mlds, assets, _ = mk_mlds docs in
422 Some
423 {
424 name = pkg.name;
425 version = pkg.version;
426 libraries;
427 mlds;
428 assets;
429 selected = false;
430 remaps = [];
431 other_docs = [];
432 pkg_dir;
433 doc_dir = pkg_dir;
434 config;
435 })
436 acc)
437 archives_by_dir Util.StringMap.empty
438 in
439 let packages = Util.StringMap.bindings packages |> List.map snd in
440 fix_missing_deps packages
441
442let of_packages ~packages_dir packages =
443 Logs.app (fun m -> m "Deciding which packages to build...");
444 let deps =
445 if packages = [] then Opam.all_opam_packages () else Opam.deps packages
446 in
447
448 let Ocamlfind.Db.{ libname_of_archive; cmi_only_libs; all_lib_deps; _ } =
449 Ocamlfind.Db.create (Ocamlfind.all () |> Util.StringSet.of_list)
450 in
451
452 let opam_map, _opam_rmap = Opam.pkg_to_dir_map () in
453
454 let ps =
455 List.filter_map
456 (fun pkg ->
457 match
458 List.find_opt
459 (fun (pkg', _) -> pkg.Opam.name = pkg'.Opam.name)
460 opam_map
461 with
462 | None ->
463 Logs.warn (fun m ->
464 m "Didn't find package %a in opam_map" Opam.pp pkg);
465 None
466 | x -> x)
467 deps
468 in
469
470 let orig =
471 List.filter_map
472 (fun pkg ->
473 List.find_opt (fun (pkg', _) -> pkg = pkg'.Opam.name) opam_map)
474 packages
475 in
476
477 let all = orig @ ps in
478 let all =
479 List.sort_uniq
480 (fun (a, _) (b, _) -> String.compare a.Opam.name b.Opam.name)
481 all
482 in
483
484 Logs.app (fun m -> m "Performing module-level dependency analysis...");
485
486 let packages =
487 List.map
488 (fun (pkg, files) ->
489 let libraries =
490 List.fold_left
491 (fun acc dir ->
492 Lib.v ~libname_of_archive ~pkg_name:pkg.Opam.name ~dir
493 ~cmtidir:None ~all_lib_deps ~cmi_only_libs ~id_override:None
494 @ acc)
495 []
496 (files.Opam.libs |> Fpath.Set.to_list)
497 in
498 let pkg_dir = pkg_dir packages_dir pkg.name in
499 let config =
500 match files.odoc_config with
501 | None -> Global_config.empty
502 | Some f -> Global_config.load f
503 in
504 let mlds, assets, _ = mk_mlds files.docs in
505 let selected = List.mem pkg.name packages in
506 let remaps =
507 if selected then []
508 else
509 let local_pkg_path = Fpath.to_string (Fpath.to_dir_path pkg_dir) in
510 let pkg_path =
511 Printf.sprintf "https://ocaml.org/p/%s/%s/doc/" pkg.name
512 pkg.version
513 in
514 let lib_paths =
515 List.map
516 (fun libty ->
517 let lib_name = libty.lib_name in
518 let local_lib_path =
519 Printf.sprintf "%s%s/" local_pkg_path lib_name
520 in
521 let lib_path = pkg_path in
522 (local_lib_path, lib_path))
523 libraries
524 in
525 (local_pkg_path, pkg_path) :: lib_paths
526 in
527
528 {
529 name = pkg.name;
530 version = pkg.version;
531 libraries;
532 mlds;
533 assets;
534 selected;
535 remaps;
536 other_docs = [];
537 pkg_dir;
538 doc_dir = pkg_dir;
539 config;
540 })
541 all
542 in
543 let res = fix_missing_deps packages in
544 Logs.debug (fun m -> m "Packages: %a" Fmt.Dump.(list pp) res);
545 res
546
547let remap_virtual_interfaces duplicate_hashes pkgs =
548 List.map
549 (fun pkg ->
550 {
551 pkg with
552 libraries =
553 pkg.libraries
554 |> List.map (fun lib ->
555 {
556 lib with
557 modules =
558 lib.modules
559 |> List.map (fun m ->
560 let m_intf =
561 if
562 Util.StringMap.mem m.m_intf.mif_hash
563 duplicate_hashes
564 && Fpath.has_ext "cmt" m.m_intf.mif_path
565 then
566 match
567 List.filter
568 (fun intf ->
569 Fpath.has_ext "cmti" intf.mif_path)
570 (Util.StringMap.find m.m_intf.mif_hash
571 duplicate_hashes)
572 with
573 | [ x ] -> x
574 | _ -> m.m_intf
575 else m.m_intf
576 in
577 { m with m_intf });
578 });
579 })
580 pkgs
581
582let remap_virtual all =
583 let virtual_check =
584 let hashes =
585 List.fold_left
586 (fun acc pkg ->
587 List.fold_left
588 (fun acc lib ->
589 List.fold_left
590 (fun acc m ->
591 let hash = m.m_intf.mif_hash in
592 Util.StringMap.update hash
593 (function
594 | None -> Some [ m.m_intf ]
595 | Some l -> Some (m.m_intf :: l))
596 acc)
597 acc lib.modules)
598 acc pkg.libraries)
599 Util.StringMap.empty all
600 in
601 Util.StringMap.filter (fun _hash intfs -> List.length intfs > 1) hashes
602 in
603
604 remap_virtual_interfaces virtual_check all