patrick.sirref.org
forked from
jon.recoil.org/odd
Odoc docs
Vendor the opam-mode odoc driver under driver/
Make odd self-contained: import odoc_driver_lib and the opam-mode entry point
from odoc-drivermod (src/driver) into driver/, built as a private library plus
the `odoc_driver_opam` binary installed alongside `odd`. `odd sync` invokes it
as before. Warnings are silenced for the vendored code so odd's strict dev
profile builds it as-is. Adds its dependency cone (eio, progress, yojson,
ocamlfind, logs, sexplib, ppx_sexp_conv, odoc-md) to the package.
Temporary, pending upstreaming of the driver changes into odoc-driver.
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
author
Jon Ludlam's Agent
co-author
Claude Opus 4.8 (1M context)
committer
Jon Ludlam
date
(Jun 23, 2026, 2:30 PM +0100)
commit
987bb981
987bb98100abd81b6991095b00760be58f8659af
parent
4030b148
4030b148b3be36fc10c728a76af25a9a1b926a18
+5282
-15
+13
-8
DESIGN.md
+13
-8
DESIGN.md
···
27
27
28
28
## The generator: `odoc_driver_opam`
29
29
30
-
A variant of `odoc_driver` (source: `~/devel/odoc-drivermod`,
31
-
`src/driver/bin/odoc_driver_opam.ml`) designed for exactly this job. Per
32
-
invocation it documents **one package installed in the current switch**:
30
+
A variant of `odoc_driver` (opam mode) designed for exactly this job. It is
31
+
**vendored** into this repo under `driver/` (the whole `odoc_driver_lib` plus
32
+
the opam-mode entry point, built and installed as the `odoc_driver_opam` binary
33
+
alongside `odd`) — a temporary measure pending upstreaming of the changes into
34
+
`odoc-driver`; until then `odd` carries its own copy so it is self-contained.
35
+
Per invocation it documents **one package installed in the current switch**:
33
36
34
37
- Package file lists come from opam's own record,
35
38
`<prefix>/.opam-switch/install/<pkg>.changes` — no prepared input tree,
···
217
220
hooks, so they never depend on odd being installed.
218
221
219
222
Dependencies: `opam-format` (opam file parsing), `bos`, `fpath`,
220
-
`cmdliner`; `odoc_driver_opam` is invoked as an external binary so its
221
-
(large) dependency cone stays out of the tool. `odoc_driver_opam` itself
222
-
should be installed per-switch (it links against the switch's odoc), found
223
-
via the switch `PATH`.
223
+
`cmdliner`. The vendored driver (`driver/`) pulls in its own cone (eio,
224
+
progress, yojson, ocamlfind, logs, sexplib, ppx_sexp_conv, and the `odoc` /
225
+
`odoc-md` / `sherlodoc` binaries it drives); `odd sync` still invokes
226
+
`odoc_driver_opam` as a subprocess, so the driver's runtime cost stays in a separate
227
+
process. `odoc_driver_opam` is built and installed by this package, so it is always
228
+
on `PATH` next to `odd` (overridable with `--driver` / `$ODD_DRIVER`).
224
229
225
230
Distribution: an opamrc adding the three `*-commands` fields for
226
231
`opam init --config`; `odd setup` for retrofitting existing roots.
···
233
238
| odd not installed in the switch | post-install/post-remove still work (coreutils); markers accumulate, drained by the next session that has odd — deferred, never lost |
234
239
| doc build fails for one package | logged; its marker is re-created; later packages still attempted (their deps' docs may be stale — accepted, fixed on retry) |
235
240
| sync interrupted | markers intact (a marker is only cleared by a successful build); next session resumes |
236
-
| `odoc_driver_opam` missing from switch | sync logs and exits 0; markers survive until the driver is installed |
241
+
| `odoc_driver_opam` not found (only if `--driver` points elsewhere; it ships with `odd`) | sync logs and exits 0; markers survive until the driver is available |
237
242
| docs failure overall | `sync` exits 0 regardless; opam reports its own success untouched |
238
243
239
244
## Open questions
+4
-2
README.md
+4
-2
README.md
···
24
24
$ odd setup --apply # add it to ~/.opam/config via `opam option`
25
25
```
26
26
27
-
`odoc_driver_opam` must be installed in each switch you want documented
28
-
(it links against the switch's odoc).
27
+
The odoc driver (`odoc_driver_opam`) is bundled with `odd` (vendored under
28
+
`driver/`, built and installed alongside the `odd` binary), so there's nothing
29
+
else to install. It drives the `odoc`, `odoc-md` and `sherlodoc` binaries,
30
+
which must be present in the switch.
29
31
30
32
## Commands
31
33
+4
-3
bin/main.ml
+4
-3
bin/main.ml
···
20
20
(* --driver: the per-package documentation generator *)
21
21
let driver_t =
22
22
let doc =
23
-
"The odoc driver run once per package. Resolved in $(b,PATH) unless it \
24
-
contains a directory separator, in which case it is taken relative to the \
25
-
current directory."
23
+
"The odoc driver run once per package (default: $(b,odoc_driver_opam), the \
24
+
driver bundled with odd). Resolved in $(b,PATH) unless it contains a \
25
+
directory separator, in which case it is taken relative to the current \
26
+
directory."
26
27
in
27
28
let arg =
28
29
Arg.(
+14
driver/bin/dune
+14
driver/bin/dune
···
1
+
; The opam-mode driver, vendored and installed as part of the odd package as
2
+
; `odoc_driver_opam`. `odd sync` invokes it once per package.
3
+
(executable
4
+
(name odoc_driver_opam)
5
+
(public_name odoc_driver_opam)
6
+
(package odd)
7
+
(modules odoc_driver_opam)
8
+
(flags
9
+
(:standard -w -a))
10
+
(link_deps
11
+
(package odoc)
12
+
(package odoc-md)
13
+
%{bin:sherlodoc})
14
+
(libraries odoc_driver_lib))
+168
driver/bin/odoc_driver_opam.ml
+168
driver/bin/odoc_driver_opam.ml
···
1
+
(* Opam-mode driver
2
+
3
+
- Must be run package-by-package, like the voodoo driver
4
+
- Documents packages installed in the current opam switch, using opam's
5
+
.changes file to determine which files belong to each package
6
+
*)
7
+
8
+
open Odoc_driver_lib
9
+
10
+
type action_mode = CompileOnly | LinkAndGen | All
11
+
12
+
(* Output always uses the flat layout, with each package's docs directly
13
+
under <package>/ as in the default odoc_driver. *)
14
+
let flat = true
15
+
16
+
let run package_name actions odoc_dir odocl_dir
17
+
{ Common_args.verbose; html_dir; nb_workers; odoc_bin; odoc_md_bin; _ } =
18
+
Option.iter (fun odoc_bin -> Odoc.odoc := Bos.Cmd.v odoc_bin) odoc_bin;
19
+
Option.iter
20
+
(fun odoc_md_bin -> Odoc.odoc_md := Bos.Cmd.v odoc_md_bin)
21
+
odoc_md_bin;
22
+
let switch_odoc_dir = Fpath.(v (Opam.prefix ()) / "odoc") in
23
+
let odoc_dir = Option.value odoc_dir ~default:switch_odoc_dir in
24
+
let odocl_dir = Option.value odocl_dir ~default:odoc_dir in
25
+
let html_dir = Option.value html_dir ~default:switch_odoc_dir in
26
+
let index_dir = Fpath.v "_index" in
27
+
let mld_dir = Fpath.v "_mld" in
28
+
Eio_main.run @@ fun env ->
29
+
Eio.Switch.run @@ fun sw ->
30
+
if verbose then Logs.set_level (Some Logs.Debug);
31
+
Logs.set_reporter (Logs_fmt.reporter ());
32
+
Stats.init_nprocs nb_workers;
33
+
let () = Worker_pool.start_workers env sw nb_workers in
34
+
35
+
let all, extra_paths, actions, generate_json, occurrence_file, odocl_dirs =
36
+
let pkg =
37
+
let pkg_opt = Voodoo.find_opam_pkg package_name in
38
+
match pkg_opt with Some pkg -> pkg | None -> exit 1
39
+
in
40
+
let all = Voodoo.of_voodoo ~flat pkg in
41
+
let odocl_dirs =
42
+
List.map
43
+
(fun l -> Fpath.(odocl_dir // Odoc_unit.lib_dir all l))
44
+
all.libraries
45
+
in
46
+
let occurrence_file =
47
+
Fpath.(odocl_dir // Voodoo.occurrence_file_of_pkg ~flat pkg)
48
+
in
49
+
let extra_paths = Voodoo.extra_paths ~flat odoc_dir in
50
+
(all, extra_paths, actions, true, occurrence_file, odocl_dirs)
51
+
in
52
+
53
+
let all = Packages.remap_virtual [ all ] in
54
+
55
+
let partial =
56
+
match all with
57
+
| [ p ] ->
58
+
let output_path = Fpath.(odoc_dir // p.pkg_dir) in
59
+
Some output_path
60
+
| _ -> failwith "Error, expecting singleton library in opam mode"
61
+
in
62
+
let units =
63
+
let dirs = { Odoc_unit.odoc_dir; odocl_dir; index_dir; mld_dir } in
64
+
Odoc_units_of.packages ~dirs ~indices_style:Voodoo ~extra_paths ~remap:false
65
+
all
66
+
in
67
+
Compile.init_stats units;
68
+
let compiled =
69
+
match actions with
70
+
| LinkAndGen -> units
71
+
| CompileOnly | All -> Compile.compile ?partial ~partial_dir:odoc_dir units
72
+
in
73
+
let () = Voodoo.write_lib_markers odoc_dir all in
74
+
let () =
75
+
match actions with
76
+
| CompileOnly -> ()
77
+
| LinkAndGen | All ->
78
+
let linked =
79
+
Compile.link ~warnings_tags:[ package_name ] ~custom_layout:false
80
+
compiled
81
+
in
82
+
let () =
83
+
Odoc.count_occurrences ~input:odocl_dirs ~output:occurrence_file
84
+
in
85
+
let () =
86
+
Compile.html_generate ~occurrence_file ~remaps:[] ~generate_json
87
+
~simplified_search_output:true ~search_dbs:[ `js; `marshal ]
88
+
html_dir linked
89
+
in
90
+
let _ = Odoc.support_files html_dir in
91
+
()
92
+
in
93
+
94
+
List.iter
95
+
(fun { Cmd_outputs.log_dest; prefix; run } ->
96
+
match log_dest with
97
+
| `Link ->
98
+
[ run.Run.output; run.Run.errors ]
99
+
|> List.iter @@ fun content ->
100
+
if String.length content = 0 then ()
101
+
else
102
+
let lines = String.split_on_char '\n' content in
103
+
List.iter (fun l -> Format.printf "%s: %s\n" prefix l) lines
104
+
| _ -> ())
105
+
!Cmd_outputs.outputs
106
+
107
+
open Cmdliner
108
+
109
+
let run package_name actions = run package_name actions
110
+
111
+
let package_name =
112
+
let doc = "Name of package to process" in
113
+
Arg.(value & pos 0 string "" & info [] ~doc ~docv:"PACKAGE")
114
+
115
+
let action_conv =
116
+
Arg.enum
117
+
[
118
+
("compile-only", CompileOnly); ("link-and-gen", LinkAndGen); ("all", All);
119
+
]
120
+
121
+
let actions =
122
+
let doc =
123
+
"Actions to perform. Valid values are 'compile-only', 'link-and-gen' and \
124
+
'all'."
125
+
in
126
+
Arg.(value & opt action_conv All & info [ "actions" ] ~doc)
127
+
128
+
let switch_odoc_dir_doc = "the odoc directory of the current opam switch"
129
+
130
+
let odoc_dir =
131
+
let doc =
132
+
Printf.sprintf
133
+
"Directory in which the intermediate odoc files go (default: %s)"
134
+
switch_odoc_dir_doc
135
+
in
136
+
Arg.(
137
+
value & opt (some Common_args.fpath_arg) None & info [ "odoc-dir" ] ~doc)
138
+
139
+
let odocl_dir =
140
+
let doc =
141
+
"Directory in which the intermediate odocl files go (default: the value \
142
+
of --odoc-dir)"
143
+
in
144
+
Arg.(
145
+
value & opt (some Common_args.fpath_arg) None & info [ "odocl-dir" ] ~doc)
146
+
147
+
let cmd =
148
+
let doc =
149
+
"Generate documentation for a single package installed in the current \
150
+
opam switch, using opam's .changes file to determine which files belong \
151
+
to the package. Designed to be run package-by-package, with the \
152
+
intermediate files of a package's dependencies available in the \
153
+
directory given by --odoc-dir."
154
+
in
155
+
let info = Cmd.info "odoc_driver_opam" ~doc in
156
+
let common =
157
+
Common_args.term
158
+
~html_dir_doc:
159
+
(Printf.sprintf
160
+
"Directory in which the generated HTML files go (default: %s)"
161
+
switch_odoc_dir_doc)
162
+
()
163
+
in
164
+
Cmd.v info
165
+
Term.(
166
+
const run $ package_name $ actions $ odoc_dir $ odocl_dir $ common)
167
+
168
+
let _ = exit (Cmd.eval cmd)
+35
driver/cmd_outputs.ml
+35
driver/cmd_outputs.ml
···
1
+
type log_dest =
2
+
[ `Compile
3
+
| `Compile_src
4
+
| `Link
5
+
| `Count_occurrences
6
+
| `Generate
7
+
| `Index
8
+
| `Sherlodoc
9
+
| `Classify ]
10
+
11
+
type log_line = { log_dest : log_dest; prefix : string; run : Run.t }
12
+
13
+
let outputs : log_line list ref = ref []
14
+
15
+
let maybe_log log_dest run =
16
+
match log_dest with
17
+
| Some (log_dest, prefix) ->
18
+
outputs := !outputs @ [ { log_dest; run; prefix } ]
19
+
| None -> ()
20
+
21
+
let submit log_dest desc cmd output_file =
22
+
match Worker_pool.submit desc cmd output_file with
23
+
| Ok x ->
24
+
maybe_log log_dest x;
25
+
String.split_on_char '\n' x.output
26
+
| Error exn -> raise exn
27
+
28
+
let submit_ignore_failures log_dest desc cmd output_file =
29
+
match Worker_pool.submit desc cmd output_file with
30
+
| Ok x ->
31
+
maybe_log log_dest x;
32
+
()
33
+
| Error exn ->
34
+
Logs.err (fun m -> m "Error: %s" (Printexc.to_string exn));
35
+
()
+112
driver/common_args.ml
+112
driver/common_args.ml
···
1
+
open Cmdliner
2
+
3
+
let fpath_arg =
4
+
let print ppf v = Fpath.pp ppf v in
5
+
Arg.conv (Fpath.of_string, print)
6
+
7
+
let html_dir ~doc =
8
+
Arg.(
9
+
value
10
+
& opt (some fpath_arg) None
11
+
& info [ "html-dir" ] ~doc ~docs:Manpage.s_common_options)
12
+
13
+
let verbose =
14
+
let doc = "Enable verbose output" in
15
+
Arg.(
16
+
value & flag & info [ "v"; "verbose" ] ~doc ~docs:Manpage.s_common_options)
17
+
18
+
let stats =
19
+
let doc = "Produce 'driver-benchmarks.json' with run stats" in
20
+
Arg.(value & flag & info [ "stats" ] ~doc ~docs:Manpage.s_common_options)
21
+
22
+
let nb_workers =
23
+
let doc = "Number of workers." in
24
+
Arg.(
25
+
value
26
+
& opt int (Domain.recommended_domain_count () - 1)
27
+
& info [ "j" ] ~doc ~docs:Manpage.s_common_options)
28
+
29
+
let odoc_bin =
30
+
let doc = "Odoc binary to use" in
31
+
Arg.(
32
+
value
33
+
& opt (some string) None
34
+
& info [ "odoc" ] ~doc ~docs:Manpage.s_common_options)
35
+
36
+
let odoc_md_bin =
37
+
let doc = "Odoc-md binary to use" in
38
+
Arg.(
39
+
value
40
+
& opt (some string) None
41
+
& info [ "odoc-md" ] ~doc ~docs:Manpage.s_common_options)
42
+
43
+
let generate_json =
44
+
let doc = "Also generate json output" in
45
+
Arg.(
46
+
value & flag & info [ "json-output" ] ~doc ~docs:Manpage.s_common_options)
47
+
48
+
let odoc_dir =
49
+
let doc = "Directory in which the intermediate odoc files go" in
50
+
Arg.(value & opt (some fpath_arg) None & info [ "odoc-dir" ] ~doc)
51
+
52
+
let odocl_dir =
53
+
let doc = "Directory in which the intermediate odocl files go" in
54
+
Arg.(value & opt (some fpath_arg) None & info [ "odocl-dir" ] ~doc)
55
+
56
+
let index_dir =
57
+
let doc = "Directory in which the intermediate index files go" in
58
+
Arg.(value & opt (some fpath_arg) None & info [ "index-dir" ] ~doc)
59
+
60
+
let mld_dir =
61
+
let doc = "Directory in which the auto-generated mld files go" in
62
+
Arg.(value & opt (some fpath_arg) None & info [ "mld-dir" ] ~doc)
63
+
64
+
type t = {
65
+
verbose : bool;
66
+
html_dir : Fpath.t option;
67
+
stats : bool;
68
+
nb_workers : int;
69
+
odoc_bin : string option;
70
+
odoc_md_bin : string option;
71
+
generate_json : bool;
72
+
}
73
+
74
+
type dirs = {
75
+
odoc_dir : Fpath.t option;
76
+
odocl_dir : Fpath.t option;
77
+
mld_dir : Fpath.t option;
78
+
index_dir : Fpath.t option;
79
+
}
80
+
81
+
let with_dirs dirs fn : unit =
82
+
let with_dir = Util.with_dir in
83
+
let { odoc_dir; odocl_dir; mld_dir; index_dir } = dirs in
84
+
with_dir odoc_dir "odoc-%s" @@ fun odoc_dir () ->
85
+
with_dir odocl_dir "odocl-%s" @@ fun odocl_dir () ->
86
+
with_dir index_dir "index-%s" @@ fun index_dir () ->
87
+
with_dir mld_dir "mld-%s" @@ fun mld_dir () ->
88
+
fn ~odoc_dir ~odocl_dir ~index_dir ~mld_dir ()
89
+
90
+
open Term
91
+
92
+
let ( let+ ) t f = const f $ t
93
+
let ( and+ ) a b = const (fun x y -> (x, y)) $ a $ b
94
+
95
+
let dirs_term =
96
+
let+ odoc_dir = odoc_dir
97
+
and+ odocl_dir = odocl_dir
98
+
and+ mld_dir = mld_dir
99
+
and+ index_dir = index_dir in
100
+
{ odoc_dir; odocl_dir; mld_dir; index_dir }
101
+
102
+
let term
103
+
?(html_dir_doc =
104
+
"Directory in which the generated HTML files go (default: _html/)") () =
105
+
let+ verbose = verbose
106
+
and+ html_dir = html_dir ~doc:html_dir_doc
107
+
and+ stats = stats
108
+
and+ nb_workers = nb_workers
109
+
and+ odoc_bin = odoc_bin
110
+
and+ odoc_md_bin = odoc_md_bin
111
+
and+ generate_json = generate_json in
112
+
{ verbose; html_dir; stats; nb_workers; odoc_bin; odoc_md_bin; generate_json }
+368
driver/compile.ml
+368
driver/compile.ml
···
1
+
(* compile *)
2
+
3
+
open Bos
4
+
5
+
type compiled = Odoc_unit.any
6
+
7
+
let odoc_partial_filename = "__odoc_partial.m"
8
+
9
+
let mk_byhash (pkgs : Odoc_unit.any list) =
10
+
List.fold_left
11
+
(fun acc (u : Odoc_unit.any) ->
12
+
match u.Odoc_unit.kind with
13
+
| `Intf { hash; _ } as kind ->
14
+
let elt = { u with kind } in
15
+
Util.StringMap.update hash
16
+
(function None -> Some [ elt ] | Some x -> Some (elt :: x))
17
+
acc
18
+
| _ -> acc)
19
+
Util.StringMap.empty pkgs
20
+
21
+
let init_stats (units : Odoc_unit.any list) =
22
+
let total, total_impl, non_hidden, mlds, assets, indexes =
23
+
List.fold_left
24
+
(fun (total, total_impl, non_hidden, mlds, assets, indexes)
25
+
(unit : Odoc_unit.any) ->
26
+
let total = match unit.kind with `Intf _ -> total + 1 | _ -> total in
27
+
let total_impl =
28
+
match unit.kind with `Impl _ -> total_impl + 1 | _ -> total_impl
29
+
in
30
+
let assets =
31
+
match unit.kind with `Asset -> assets + 1 | _ -> assets
32
+
in
33
+
let indexes =
34
+
match unit.index with
35
+
| None -> indexes
36
+
| Some index -> Fpath.Set.add index.output_file indexes
37
+
in
38
+
let non_hidden =
39
+
match unit.kind with
40
+
| `Intf { hidden = false; _ } -> non_hidden + 1
41
+
| _ -> non_hidden
42
+
in
43
+
let mlds = match unit.kind with `Mld | `Md -> mlds + 1 | _ -> mlds in
44
+
(total, total_impl, non_hidden, mlds, assets, indexes))
45
+
(0, 0, 0, 0, 0, Fpath.Set.empty)
46
+
units
47
+
in
48
+
49
+
Atomic.set Stats.stats.total_units total;
50
+
Atomic.set Stats.stats.total_impls total_impl;
51
+
Atomic.set Stats.stats.non_hidden_units non_hidden;
52
+
Atomic.set Stats.stats.total_mlds mlds;
53
+
Atomic.set Stats.stats.total_assets assets;
54
+
Atomic.set Stats.stats.total_indexes (Fpath.Set.cardinal indexes)
55
+
56
+
open Eio.Std
57
+
58
+
type partial = Odoc_unit.intf Odoc_unit.t list Util.StringMap.t
59
+
60
+
let unmarshal filename : partial =
61
+
let ic = open_in_bin (Fpath.to_string filename) in
62
+
Fun.protect
63
+
~finally:(fun () -> close_in ic)
64
+
(fun () -> Marshal.from_channel ic)
65
+
66
+
let marshal (v : partial) filename =
67
+
let _ = OS.Dir.create (Fpath.parent filename) |> Result.get_ok in
68
+
let oc = open_out_bin (Fpath.to_string filename) in
69
+
Fun.protect
70
+
~finally:(fun () -> close_out oc)
71
+
(fun () -> Marshal.to_channel oc v [])
72
+
73
+
let find_partials odoc_dir :
74
+
Odoc_unit.intf Odoc_unit.t list Util.StringMap.t * _ =
75
+
let tbl = Hashtbl.create 1000 in
76
+
let hashes_result =
77
+
OS.Dir.fold_contents ~dotfiles:false ~elements:`Dirs
78
+
(fun p hashes ->
79
+
let index_m = Fpath.( / ) p odoc_partial_filename in
80
+
match OS.File.exists index_m with
81
+
| Ok true ->
82
+
let hashes' = unmarshal index_m in
83
+
Util.StringMap.iter
84
+
(fun h units ->
85
+
List.iter
86
+
(fun u ->
87
+
Hashtbl.replace tbl
88
+
(h, Odoc.Id.to_string u.Odoc_unit.parent_id)
89
+
(Promise.create_resolved ()))
90
+
units)
91
+
hashes';
92
+
Util.StringMap.union (fun _x o1 _o2 -> Some o1) hashes hashes'
93
+
| _ -> hashes)
94
+
Util.StringMap.empty odoc_dir
95
+
in
96
+
match hashes_result with
97
+
| Ok h -> (h, tbl)
98
+
| Error _ -> (* odoc_dir doesn't exist...? *) (Util.StringMap.empty, tbl)
99
+
100
+
let compile ?partial ~partial_dir (all : Odoc_unit.any list) =
101
+
let hashes = mk_byhash all in
102
+
let compile_mod =
103
+
(* Modules have a more complicated compilation because:
104
+
- They have dependencies and must be compiled in the right order
105
+
- In Voodoo mode, there might exists already compiled parts *)
106
+
let other_hashes, tbl =
107
+
match partial with
108
+
| Some _ -> find_partials partial_dir
109
+
| None -> (Util.StringMap.empty, Hashtbl.create 10)
110
+
in
111
+
let hashes =
112
+
Odoc_unit.fix_virtual ~precompiled_units:other_hashes ~units:hashes
113
+
in
114
+
let all_hashes =
115
+
Util.StringMap.union (fun _x o1 o2 -> Some (o1 @ o2)) hashes other_hashes
116
+
in
117
+
let compile_one compile_other (unit : Odoc_unit.intf Odoc_unit.t) =
118
+
let (`Intf { Odoc_unit.deps; _ }) = unit.kind in
119
+
let _fibers =
120
+
Fiber.List.map
121
+
(fun (other_unit_name, other_unit_hash) ->
122
+
match compile_other other_unit_hash with
123
+
| Ok r -> Some r
124
+
| Error _exn ->
125
+
Logs.debug (fun m ->
126
+
m
127
+
"Error during compilation of module %s (hash %s, \
128
+
required by %s)"
129
+
other_unit_name other_unit_hash
130
+
(Fpath.filename unit.input_file));
131
+
None)
132
+
deps
133
+
in
134
+
let includes =
135
+
List.fold_left
136
+
(fun acc (_lib, path) -> Fpath.Set.add path acc)
137
+
Fpath.Set.empty
138
+
(Odoc_unit.Pkg_args.compiled_libs unit.pkg_args)
139
+
in
140
+
Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file
141
+
~includes ~warnings_tag:unit.pkgname ~parent_id:unit.parent_id
142
+
~ignore_output:(not unit.enable_warnings);
143
+
(match unit.input_copy with
144
+
| None -> ()
145
+
| Some p -> Util.cp (Fpath.to_string unit.input_file) (Fpath.to_string p));
146
+
Atomic.incr Stats.stats.compiled_units
147
+
in
148
+
let rec compile_mod : string -> ('a list, [> `Msg of string ]) Result.t =
149
+
fun hash ->
150
+
let map_units =
151
+
Fiber.List.map (fun unit ->
152
+
match
153
+
Hashtbl.find_opt tbl
154
+
(hash, Odoc.Id.to_string unit.Odoc_unit.parent_id)
155
+
with
156
+
| Some p ->
157
+
Promise.await p;
158
+
None
159
+
| None ->
160
+
let p, r = Promise.create () in
161
+
Hashtbl.add tbl (hash, Odoc.Id.to_string unit.parent_id) p;
162
+
let _result = compile_one compile_mod unit in
163
+
Promise.resolve r ();
164
+
Some unit)
165
+
in
166
+
try
167
+
let units = Util.StringMap.find hash all_hashes in
168
+
let r = map_units units in
169
+
Ok (List.filter_map Fun.id r)
170
+
with Not_found ->
171
+
Error (`Msg ("Module with hash " ^ hash ^ " not found"))
172
+
in
173
+
compile_mod
174
+
in
175
+
176
+
let compile (unit : Odoc_unit.any) =
177
+
match unit.kind with
178
+
| `Intf intf -> (compile_mod intf.hash :> (Odoc_unit.any list, _) Result.t)
179
+
| `Impl src ->
180
+
let includes =
181
+
List.fold_left
182
+
(fun acc (_lib, path) -> Fpath.Set.add path acc)
183
+
Fpath.Set.empty
184
+
(Odoc_unit.Pkg_args.compiled_libs unit.pkg_args)
185
+
in
186
+
let source_id = src.src_id in
187
+
Odoc.compile_impl ~output_dir:unit.output_dir
188
+
~input_file:unit.input_file ~includes ~parent_id:unit.parent_id
189
+
~source_id;
190
+
Atomic.incr Stats.stats.compiled_impls;
191
+
Ok [ unit ]
192
+
| `Asset ->
193
+
Odoc.compile_asset ~output_dir:unit.output_dir ~parent_id:unit.parent_id
194
+
~name:(Fpath.filename unit.input_file);
195
+
Atomic.incr Stats.stats.compiled_assets;
196
+
Ok [ unit ]
197
+
| `Mld ->
198
+
let includes = Fpath.Set.empty in
199
+
Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file
200
+
~includes ~warnings_tag:None ~parent_id:unit.parent_id
201
+
~ignore_output:(not unit.enable_warnings);
202
+
Atomic.incr Stats.stats.compiled_mlds;
203
+
Ok [ unit ]
204
+
| `Md ->
205
+
Odoc.compile_md ~output_dir:unit.output_dir ~input_file:unit.input_file
206
+
~parent_id:unit.parent_id;
207
+
Atomic.incr Stats.stats.compiled_mlds;
208
+
Ok [ unit ]
209
+
in
210
+
let _ = Fiber.List.map compile all in
211
+
(match partial with
212
+
| Some l -> marshal hashes Fpath.(l / odoc_partial_filename)
213
+
| None -> ());
214
+
215
+
all
216
+
217
+
type linked = Odoc_unit.any
218
+
219
+
let link : warnings_tags:string list -> custom_layout:bool -> compiled list -> _
220
+
=
221
+
fun ~warnings_tags ~custom_layout compiled ->
222
+
let link : compiled -> linked =
223
+
fun c ->
224
+
let link input_file output_file enable_warnings =
225
+
let libs = Odoc_unit.Pkg_args.compiled_libs c.pkg_args in
226
+
let pages = Odoc_unit.Pkg_args.compiled_pages c.pkg_args in
227
+
let includes = Odoc_unit.Pkg_args.includes c.pkg_args in
228
+
Odoc.link ~custom_layout ~input_file ~output_file ~libs ~docs:pages
229
+
~includes ~ignore_output:(not enable_warnings) ~warnings_tags
230
+
?current_package:c.pkgname ()
231
+
in
232
+
match c.kind with
233
+
| `Intf { hidden = true; _ } ->
234
+
Logs.debug (fun m -> m "not linking %a" Fpath.pp c.odoc_file);
235
+
c
236
+
| _ ->
237
+
Logs.debug (fun m -> m "linking %a" Fpath.pp c.odoc_file);
238
+
if c.to_output then link c.odoc_file c.odocl_file c.enable_warnings;
239
+
(match c.kind with
240
+
| `Intf _ -> Atomic.incr Stats.stats.linked_units
241
+
| `Mld -> Atomic.incr Stats.stats.linked_mlds
242
+
| `Asset -> ()
243
+
| `Impl _ -> Atomic.incr Stats.stats.linked_impls
244
+
| `Md -> Atomic.incr Stats.stats.linked_mlds);
245
+
c
246
+
in
247
+
Fiber.List.map link compiled
248
+
249
+
let sherlodoc_index_one ~output_dir ~format (index : Odoc_unit.index) =
250
+
let inputs = [ index.output_file ] in
251
+
let rel_path =
252
+
match format with
253
+
| `js -> Sherlodoc.db_js_file index.search_dir
254
+
| `marshal -> Sherlodoc.db_marshal_file index.search_dir
255
+
in
256
+
let dst = Fpath.(output_dir // rel_path) in
257
+
let dst_dir, _ = Fpath.split_base dst in
258
+
let _ = OS.Dir.create dst_dir |> Result.get_ok in
259
+
Sherlodoc.index ~format ~inputs ~dst ~pkg:index.pkg_name ();
260
+
rel_path
261
+
262
+
(* Build a sherlodoc db in each requested format, returning the path to the
263
+
javascript db (if any), which is the one referenced for in-browser search.
264
+
Marshal dbs are produced for server-side search and aren't wired into the
265
+
generated pages. *)
266
+
let sherlodoc_index ~output_dir ~search_dbs index =
267
+
List.fold_left
268
+
(fun js_db format ->
269
+
let rel_path = sherlodoc_index_one ~output_dir ~format index in
270
+
match format with `js -> Some rel_path | `marshal -> js_db)
271
+
None search_dbs
272
+
273
+
let html_generate ~occurrence_file ~remaps ~generate_json
274
+
~simplified_search_output ?(search_dbs = [ `js ]) output_dir linked =
275
+
let tbl = Hashtbl.create 10 in
276
+
let _ = OS.Dir.create output_dir |> Result.get_ok in
277
+
Sherlodoc.js Fpath.(output_dir // Sherlodoc.js_file);
278
+
let compile_index (index : Odoc_unit.index) =
279
+
let compile_index_one
280
+
({ roots; output_file; json; search_dir = _; sidebar } as index :
281
+
Odoc_unit.index) =
282
+
let () =
283
+
Odoc.compile_index ~json ~occurrence_file ~output_file ~roots
284
+
~simplified:false ~wrap:false ()
285
+
in
286
+
let sidebar =
287
+
match sidebar with
288
+
| None -> None
289
+
| Some { output_file; json; pkg_dir } ->
290
+
Odoc.sidebar_generate ~output_file ~json index.output_file ();
291
+
Odoc.sidebar_generate
292
+
~output_file:Fpath.(output_dir // pkg_dir / "sidebar.json")
293
+
~json:true index.output_file ();
294
+
if simplified_search_output then
295
+
Odoc.compile_index ~json:true ~occurrence_file
296
+
~output_file:Fpath.(output_dir // pkg_dir / "index.js")
297
+
~simplified:true ~wrap:true ~roots ();
298
+
299
+
Some output_file
300
+
in
301
+
(sherlodoc_index ~output_dir ~search_dbs index, sidebar)
302
+
in
303
+
match Hashtbl.find_opt tbl index.output_file with
304
+
| None ->
305
+
let p, r = Promise.create () in
306
+
Hashtbl.add tbl index.output_file p;
307
+
let rel_path = compile_index_one index in
308
+
Atomic.incr Stats.stats.generated_indexes;
309
+
Promise.resolve r rel_path;
310
+
rel_path
311
+
| Some p -> Promise.await p
312
+
in
313
+
let html_generate : Fpath.t option -> linked -> unit =
314
+
fun remap_file l ->
315
+
if l.to_output then
316
+
let output_dir = Fpath.to_string output_dir in
317
+
let home_breadcrumb = "Package index" in
318
+
let input_file = l.odocl_file in
319
+
match l.kind with
320
+
| `Intf { hidden = true; _ } -> ()
321
+
| `Impl { src_path; _ } ->
322
+
let search_uris, sidebar =
323
+
match l.index with
324
+
| None -> (None, None)
325
+
| Some index ->
326
+
let db_path, sidebar = compile_index index in
327
+
let search_uris =
328
+
Option.map (fun db -> [ db; Sherlodoc.js_file ]) db_path
329
+
in
330
+
(search_uris, sidebar)
331
+
in
332
+
Odoc.html_generate_source ?search_uris ?sidebar ~output_dir
333
+
~input_file ~home_breadcrumb ~source:src_path ();
334
+
Atomic.incr Stats.stats.generated_units;
335
+
if generate_json then (
336
+
Odoc.html_generate_source ?search_uris ?sidebar ~output_dir
337
+
~input_file ~source:src_path ~as_json:true ~home_breadcrumb ();
338
+
Atomic.incr Stats.stats.generated_units)
339
+
| `Asset ->
340
+
Odoc.html_generate_asset ~output_dir ~input_file:l.odoc_file
341
+
~asset_path:l.input_file ~home_breadcrumb ()
342
+
| _ ->
343
+
let search_uris, sidebar =
344
+
match l.index with
345
+
| None -> (None, None)
346
+
| Some index ->
347
+
let db_path, sidebar = compile_index index in
348
+
let search_uris =
349
+
Option.map (fun db -> [ db; Sherlodoc.js_file ]) db_path
350
+
in
351
+
(search_uris, sidebar)
352
+
in
353
+
Odoc.html_generate ?search_uris ?sidebar ?remap:remap_file ~output_dir
354
+
~input_file ~home_breadcrumb ();
355
+
Atomic.incr Stats.stats.generated_units;
356
+
if generate_json then (
357
+
Odoc.html_generate ?search_uris ?sidebar ~output_dir ~input_file
358
+
~as_json:true ~home_breadcrumb ();
359
+
Atomic.incr Stats.stats.generated_units)
360
+
in
361
+
if List.length remaps = 0 then Fiber.List.iter (html_generate None) linked
362
+
else
363
+
Bos.OS.File.with_tmp_oc "remap.%s.txt"
364
+
(fun fpath oc () ->
365
+
List.iter (fun (a, b) -> Printf.fprintf oc "%s:%s\n%!" a b) remaps;
366
+
Fiber.List.iter (html_generate (Some fpath)) linked)
367
+
()
368
+
|> ignore
+33
driver/compile.mli
+33
driver/compile.mli
···
1
+
type compiled = Odoc_unit.any
2
+
3
+
val init_stats : Odoc_unit.any list -> unit
4
+
5
+
val compile :
6
+
?partial:Fpath.t -> partial_dir:Fpath.t -> Odoc_unit.any list -> compiled list
7
+
(** Use [partial] to reuse the output of a previous call to [compile]. Useful in
8
+
the voodoo context.
9
+
10
+
[output_dir] is the directory for [odoc] file, [linked_dir] is the one for
11
+
[odocl] files (defaulting to [output_dir] when absent). *)
12
+
13
+
type linked
14
+
15
+
val link :
16
+
warnings_tags:string list ->
17
+
custom_layout:bool ->
18
+
compiled list ->
19
+
linked list
20
+
21
+
val html_generate :
22
+
occurrence_file:Fpath.t ->
23
+
remaps:(string * string) list ->
24
+
generate_json:bool ->
25
+
simplified_search_output:bool ->
26
+
?search_dbs:[ `js | `marshal ] list ->
27
+
Fpath.t ->
28
+
linked list ->
29
+
unit
30
+
(** [search_dbs] selects which sherlodoc database formats to generate per
31
+
package (default [[`js]]). Only a [`js] db is referenced from the generated
32
+
pages for in-browser search; a [`marshal] db is produced for server-side
33
+
search. *)
+10
driver/db.ml
+10
driver/db.ml
···
1
+
(* Db - a type to help determine which modules belong in which libraries *)
2
+
3
+
type t = {
4
+
all_libs : Util.StringSet.t;
5
+
all_lib_deps : Util.StringSet.t Util.StringMap.t;
6
+
lib_dirs_and_archives : (string * Fpath.t * Util.StringSet.t) list;
7
+
archives_by_dir : Util.StringSet.t Fpath.map;
8
+
libname_of_archive : string Fpath.map;
9
+
cmi_only_libs : (Fpath.t * string) list;
10
+
}
+23
driver/dune
+23
driver/dune
···
1
+
; Vendored from odoc-drivermod (src/driver). Temporary, pending upstreaming —
2
+
; see DESIGN.md. Built as a private library (no public_name) so it doesn't
3
+
; clash with an installed odoc-driver package.
4
+
(library
5
+
(name odoc_driver_lib)
6
+
; Vendored as-is: silence warnings so odd's strict dev profile doesn't reject
7
+
; (or spam about) upstream code.
8
+
(flags
9
+
(:standard -w -a))
10
+
(preprocess
11
+
(pps ppx_sexp_conv))
12
+
(libraries
13
+
cmdliner
14
+
bos
15
+
progress
16
+
fpath
17
+
yojson
18
+
findlib
19
+
opam-format
20
+
logs
21
+
logs.fmt
22
+
eio_main
23
+
sexplib))
+59
driver/global_config.ml
+59
driver/global_config.ml
···
1
+
open Sexplib0
2
+
3
+
type deps = { packages : string list; libraries : string list }
4
+
5
+
type t = { deps : deps }
6
+
7
+
let empty = { deps = { libraries = []; packages = [] } }
8
+
9
+
module Ast = struct
10
+
type item = Libraries of string list | Packages of string list
11
+
12
+
type t = item list
13
+
end
14
+
15
+
let parse_string_list sexps =
16
+
List.filter_map (function Sexp.Atom s -> Some s | _ -> None) sexps
17
+
18
+
let parse_entry (sexp : Sexp.t) =
19
+
match sexp with
20
+
| Atom _ -> None
21
+
| List (Atom "libraries" :: libraries) ->
22
+
Some (Ast.Libraries (parse_string_list libraries))
23
+
| List (Atom "packages" :: pkgs) ->
24
+
Some (Ast.Packages (parse_string_list pkgs))
25
+
| _ -> None
26
+
27
+
let of_ast (ast : Ast.t) =
28
+
let libs, pkgs =
29
+
List.fold_left
30
+
(fun (libs, pkgs) item ->
31
+
match item with
32
+
| Ast.Libraries l -> (l :: libs, pkgs)
33
+
| Ast.Packages l -> (libs, l :: pkgs))
34
+
([], []) ast
35
+
in
36
+
let libraries, packages =
37
+
let f x = x |> List.concat |> List.sort_uniq String.compare in
38
+
(f libs, f pkgs)
39
+
in
40
+
{ deps = { libraries; packages } }
41
+
42
+
let parse s =
43
+
let entries = Sexplib.Sexp.of_string_many s in
44
+
let ast = List.filter_map parse_entry entries in
45
+
of_ast ast
46
+
47
+
let load config_file =
48
+
match Bos.OS.File.read config_file with
49
+
| Error _ ->
50
+
Logs.err (fun m ->
51
+
m "Failed to read odoc-config file: %a" Fpath.pp config_file);
52
+
empty
53
+
| Ok s -> (
54
+
try parse s
55
+
with e ->
56
+
Logs.err (fun m ->
57
+
m "Failed to parse config file %a: %s" Fpath.pp config_file
58
+
(Printexc.to_string e));
59
+
empty)
+9
driver/global_config.mli
+9
driver/global_config.mli
+290
driver/landing_pages.ml
+290
driver/landing_pages.ml
···
1
+
open Odoc_unit
2
+
open Packages
3
+
4
+
let fpf = Format.fprintf
5
+
6
+
let make_index ~dirs ~rel_dir ~libs ~pkgs ~index ~enable_warnings ~content :
7
+
Odoc_unit.mld Odoc_unit.t =
8
+
let { odoc_dir; odocl_dir; mld_dir; _ } = dirs in
9
+
let input_file = Fpath.(mld_dir // rel_dir / "index.mld") in
10
+
let odoc_file = Fpath.(odoc_dir // rel_dir / "page-index.odoc") in
11
+
let odocl_file = Fpath.(odocl_dir // rel_dir / "page-index.odocl") in
12
+
let parent_id = rel_dir |> Odoc.Id.of_fpath in
13
+
let pages =
14
+
List.map (fun pkg -> (pkg.Packages.name, Odoc_unit.doc_dir pkg)) pkgs
15
+
in
16
+
let libs =
17
+
List.map
18
+
(fun (pkg, lib) -> (lib.Packages.lib_name, Odoc_unit.lib_dir pkg lib))
19
+
libs
20
+
in
21
+
let pkg_args = Pkg_args.v ~pages ~libs ~includes:[] ~odoc_dir ~odocl_dir in
22
+
Util.with_out_to input_file (fun oc ->
23
+
fpf (Format.formatter_of_out_channel oc) "%t@?" content)
24
+
|> Result.get_ok;
25
+
{
26
+
output_dir = dirs.odoc_dir;
27
+
pkgname = None;
28
+
pkg_args;
29
+
parent_id;
30
+
input_file;
31
+
input_copy = None;
32
+
odoc_file;
33
+
odocl_file;
34
+
enable_warnings;
35
+
to_output = true;
36
+
kind = `Mld;
37
+
index;
38
+
}
39
+
40
+
let module_list ppf lib =
41
+
let modules = List.filter (fun m -> not m.m_hidden) lib.modules in
42
+
match modules with
43
+
| [] -> fpf ppf "No module."
44
+
| _ :: _ ->
45
+
let modules =
46
+
List.sort (fun m m' -> String.compare m.m_name m'.m_name) modules
47
+
in
48
+
fpf ppf "{!modules:";
49
+
List.iter (fun m -> fpf ppf " %s" m.m_name) modules;
50
+
fpf ppf "}@\n"
51
+
52
+
let library ~dirs ~pkg ~index lib =
53
+
let content ppf =
54
+
fpf ppf "%@toc_status hidden\n";
55
+
fpf ppf "%@order_category libraries\n";
56
+
fpf ppf "{0 Library [%s]}@\n" lib.lib_name;
57
+
fpf ppf "%a@\n" module_list lib
58
+
in
59
+
let rel_dir = lib_dir pkg lib in
60
+
let libs = [ (pkg, lib) ] in
61
+
make_index ~dirs ~rel_dir ~libs ~pkgs:[] ~index:(Some index) ~content
62
+
~enable_warnings:false
63
+
64
+
let package ~dirs ~pkg ~index =
65
+
let library_list ppf pkg =
66
+
let print_lib lib =
67
+
fpf ppf "{2 Library %s}@\n%a@\n" lib.lib_name module_list lib
68
+
in
69
+
let libraries =
70
+
List.sort
71
+
(fun lib lib' -> String.compare lib.lib_name lib'.lib_name)
72
+
pkg.libraries
73
+
in
74
+
List.iter print_lib libraries
75
+
in
76
+
let content pkg ppf =
77
+
fpf ppf "{0 %s}@\n@\n@\n" pkg.name;
78
+
List.iter
79
+
(fun { mld_rel_path; _ } ->
80
+
let page = mld_rel_path |> Fpath.rem_ext |> Fpath.to_string in
81
+
fpf ppf "@\n{!/%s/%s}@\n" pkg.name page)
82
+
pkg.mlds;
83
+
if not (List.is_empty pkg.libraries) then
84
+
fpf ppf "{1 API}@\n@\n%a@\n" library_list pkg
85
+
in
86
+
let content = content pkg in
87
+
let rel_dir = doc_dir pkg in
88
+
let libs = List.map (fun lib -> (pkg, lib)) pkg.libraries in
89
+
make_index ~dirs ~rel_dir ~index:(Some index) ~content ~pkgs:[ pkg ] ~libs
90
+
~enable_warnings:false
91
+
92
+
let src ~dirs ~pkg ~index =
93
+
let content ppf =
94
+
fpf ppf "%@order_category source\n";
95
+
fpf ppf
96
+
"{0 Sources}@\n\
97
+
This contains the rendered source for [%s]. Use the sidebar to navigate \
98
+
them."
99
+
pkg.name
100
+
in
101
+
let rel_dir = src_dir pkg in
102
+
make_index ~dirs ~pkgs:[] ~libs:[] ~rel_dir ~index:(Some index) ~content
103
+
~enable_warnings:true
104
+
105
+
let package_list ~dirs ~remap all =
106
+
let content all ppf =
107
+
let sorted_packages =
108
+
all |> List.sort (fun n1 n2 -> String.compare n1.name n2.name)
109
+
in
110
+
fpf ppf "{0 List of all packages}@\n";
111
+
let print_pkg pkg =
112
+
if pkg.selected || not remap then
113
+
fpf ppf "- {{!/%s/page-index}%s}@\n" pkg.name pkg.name
114
+
in
115
+
List.iter print_pkg sorted_packages
116
+
in
117
+
let content = content all in
118
+
let rel_dir = Fpath.v "./" in
119
+
make_index ~dirs ~rel_dir ~pkgs:all ~libs:[] ~index:None ~content
120
+
~enable_warnings:true
121
+
122
+
let content dir _pkg libs _src subdirs all_libs pfp =
123
+
let is_root = Fpath.to_string dir = "./" in
124
+
fpf pfp "{0 Directory: %a}\n\n" Fpath.pp dir;
125
+
126
+
if is_root then (
127
+
fpf pfp "@short_title /\n";
128
+
fpf pfp "@children_order ";
129
+
Fpath.Set.iter
130
+
(fun x ->
131
+
if Fpath.basename x <> "opam_switch" then
132
+
fpf pfp "%s/ " (Fpath.basename x))
133
+
subdirs;
134
+
fpf pfp "opam_switch\n%!")
135
+
else fpf pfp "@short_title %s\n" (Fpath.basename dir);
136
+
137
+
if Fpath.Set.cardinal subdirs > 0 then (
138
+
fpf pfp "{1 Subdirectories}\n";
139
+
Fpath.Set.iter
140
+
(fun subdir ->
141
+
fpf pfp "- {{!/%s/%apage-index}%s}\n%!" Monorepo_style.monorepo_pkg_name
142
+
Fpath.pp subdir (Fpath.basename subdir))
143
+
subdirs);
144
+
145
+
if (not is_root) && List.length libs > 0 then
146
+
List.iter
147
+
(fun (_, lib) ->
148
+
fpf pfp "{1 Library %s}" lib.Packages.lib_name;
149
+
fpf pfp "%a@\n" module_list lib)
150
+
libs;
151
+
152
+
if is_root then (
153
+
fpf pfp "{1 Libraries index}\n";
154
+
List.iter
155
+
(fun lib ->
156
+
fpf pfp "- Library [%s]\n" lib.Packages.lib_name;
157
+
fpf pfp " %a@\n" module_list lib)
158
+
all_libs)
159
+
160
+
let make_custom dirs index_of (pkg : Packages.t) :
161
+
Odoc_unit.mld Odoc_unit.t list =
162
+
let pkgs = [ pkg ] in
163
+
let pkg_dirs =
164
+
List.fold_right
165
+
(fun pkg dirs ->
166
+
Fpath.Map.add (Fpath.to_dir_path pkg.Packages.pkg_dir) pkg dirs)
167
+
pkgs Fpath.Map.empty
168
+
in
169
+
let lib_dirs =
170
+
List.fold_right
171
+
(fun pkg dirs ->
172
+
let libs = pkg.libraries in
173
+
List.fold_left
174
+
(fun dirs lib ->
175
+
Fpath.Map.add
176
+
(Fpath.to_dir_path (Odoc_unit.lib_dir pkg lib))
177
+
(pkg, lib) dirs)
178
+
dirs libs)
179
+
pkgs Fpath.Map.empty
180
+
in
181
+
let src_dirs =
182
+
List.fold_right
183
+
(fun pkg dirs ->
184
+
let libs = pkg.libraries in
185
+
let x =
186
+
List.fold_right
187
+
(fun lib dirs ->
188
+
if
189
+
List.exists
190
+
(fun m ->
191
+
match m.Packages.m_impl with
192
+
| Some { mip_src_info = Some _; _ } -> true
193
+
| _ -> false)
194
+
lib.modules
195
+
then
196
+
Fpath.Map.add
197
+
(Fpath.to_dir_path (Odoc_unit.src_lib_dir pkg lib))
198
+
(pkg, lib) dirs
199
+
else dirs)
200
+
libs dirs
201
+
in
202
+
x)
203
+
pkgs Fpath.Map.empty
204
+
in
205
+
let pkg_src_dirs =
206
+
List.fold_left
207
+
(fun acc pkg ->
208
+
Fpath.Map.add (Odoc_unit.src_dir pkg |> Fpath.to_dir_path) pkg acc)
209
+
Fpath.Map.empty pkgs
210
+
in
211
+
let all_dirs =
212
+
Fpath.Set.union (Fpath.Map.dom pkg_dirs)
213
+
(Fpath.Set.union (Fpath.Map.dom lib_dirs) (Fpath.Map.dom src_dirs))
214
+
in
215
+
let rec all_parents path =
216
+
let parent, _ = Fpath.split_base path in
217
+
if
218
+
Fpath.compare parent (Fpath.v "./") = 0
219
+
|| Fpath.compare parent (Fpath.v "/") = 0
220
+
then [ path ]
221
+
else path :: all_parents parent
222
+
in
223
+
let all_dirs =
224
+
Fpath.Set.fold
225
+
(fun p acc ->
226
+
let parents = all_parents p in
227
+
List.fold_right Fpath.Set.add parents acc)
228
+
all_dirs all_dirs
229
+
in
230
+
231
+
let all_indexes =
232
+
List.fold_right
233
+
(fun pkg acc ->
234
+
let mlds = pkg.Packages.mlds in
235
+
let indexes =
236
+
List.filter
237
+
(fun mld -> Fpath.basename mld.mld_rel_path = "index.mld")
238
+
mlds
239
+
in
240
+
let index_paths =
241
+
List.map
242
+
(fun mld -> Fpath.(pkg.pkg_dir // mld.mld_rel_path |> parent))
243
+
indexes
244
+
|> Fpath.Set.of_list
245
+
in
246
+
Fpath.Set.union acc index_paths)
247
+
pkgs Fpath.Set.empty
248
+
in
249
+
250
+
Fpath.Set.fold
251
+
(fun p acc ->
252
+
if Fpath.Set.mem p all_indexes then (
253
+
Logs.debug (fun m -> m "Skipping predefined index.mld: %a" Fpath.pp p);
254
+
acc)
255
+
else
256
+
let libs =
257
+
let is_root = Fpath.to_string p = "./" in
258
+
Fpath.Map.fold
259
+
(fun p' lib libs -> if p = p' || is_root then lib :: libs else libs)
260
+
lib_dirs []
261
+
in
262
+
let src = Fpath.Map.find_opt p src_dirs in
263
+
let pkg_src = Fpath.Map.find_opt p pkg_src_dirs in
264
+
let subdirs =
265
+
Fpath.Set.filter (fun p' -> Fpath.parent p' = p) all_dirs
266
+
in
267
+
Logs.debug (fun x ->
268
+
x "dir: %a pkg: %a lib: %a src: %a pkg_src: %a subdirs: %a" Fpath.pp
269
+
p Fmt.string pkg.Packages.name (Fmt.Dump.list Fmt.string)
270
+
(List.map (fun (_, p) -> p.Packages.lib_name) libs)
271
+
(Fmt.Dump.option Fmt.string)
272
+
(Option.map (fun (_, p) -> p.Packages.lib_name) src)
273
+
(Fmt.Dump.option Fmt.string)
274
+
(Option.map (fun p -> p.Packages.name) pkg_src)
275
+
(Fmt.Dump.list Fpath.pp)
276
+
(Fpath.Set.elements subdirs));
277
+
let index = Some (index_of pkg) in
278
+
let pkgs = pkgs in
279
+
let all_libs = pkg.libraries in
280
+
Logs.debug (fun m ->
281
+
m "pkgs: %a"
282
+
Fmt.Dump.(list string)
283
+
(List.map (fun p -> p.Packages.name) pkgs));
284
+
let idx =
285
+
make_index ~dirs ~rel_dir:p ~libs ~pkgs
286
+
~content:(content p pkg libs src subdirs all_libs)
287
+
~index ~enable_warnings:false
288
+
in
289
+
idx :: acc)
290
+
all_dirs []
+23
driver/landing_pages.mli
+23
driver/landing_pages.mli
···
1
+
open Odoc_unit
2
+
3
+
val make_index :
4
+
dirs:dirs ->
5
+
rel_dir:Fpath.t ->
6
+
libs:(Packages.t * Packages.libty) list ->
7
+
pkgs:Packages.t list ->
8
+
index:index option ->
9
+
enable_warnings:bool ->
10
+
content:(Format.formatter -> unit) ->
11
+
mld Odoc_unit.t
12
+
13
+
val library :
14
+
dirs:dirs -> pkg:Packages.t -> index:index -> Packages.libty -> mld t
15
+
16
+
val package : dirs:dirs -> pkg:Packages.t -> index:index -> mld t
17
+
18
+
val src : dirs:dirs -> pkg:Packages.t -> index:index -> mld t
19
+
20
+
val package_list : dirs:dirs -> remap:bool -> Packages.t list -> mld t
21
+
22
+
val make_custom :
23
+
dirs -> (Packages.t -> Odoc_unit.index) -> Packages.t -> mld t list
+133
driver/library_names.ml
+133
driver/library_names.ml
···
1
+
open Bos
2
+
3
+
(** To extract the library names for a given package, without using dune, we
4
+
5
+
1. parse the META file of the package with ocamlfind to see which libraries
6
+
exist and what their archive name (.cma filename) is.
7
+
8
+
2. use ocamlobjinfo to get a list of all modules within the archives. EDIT:
9
+
it seems this step is now skipped.
10
+
11
+
This code assumes that the META file lists for every library an archive
12
+
[archive_name], and that for this cma archive exists a corresponsing
13
+
[archive_name].ocamlobjinfo file. *)
14
+
15
+
type library = {
16
+
name : string;
17
+
archive_name : string option;
18
+
dir : string option;
19
+
deps : string list;
20
+
}
21
+
22
+
type t = { meta_dir : Fpath.t; libraries : library list }
23
+
24
+
let read_libraries_from_pkg_defs ~library_name pkg_defs =
25
+
try
26
+
let archive_filename =
27
+
try Some (Fl_metascanner.lookup "archive" [ "byte" ] pkg_defs)
28
+
with _ -> (
29
+
try Some (Fl_metascanner.lookup "archive" [ "native" ] pkg_defs)
30
+
with _ -> None)
31
+
in
32
+
33
+
let deps =
34
+
try
35
+
let deps_str = Fl_metascanner.lookup "requires" [] pkg_defs in
36
+
(* The deps_str is a string of space-separated package names, e.g. "a b c" *)
37
+
(* We use Astring to split the string into a list of package names *)
38
+
Astring.String.fields ~empty:false deps_str
39
+
with _ -> []
40
+
in
41
+
42
+
let dir =
43
+
List.find_opt (fun d -> d.Fl_metascanner.def_var = "directory") pkg_defs
44
+
in
45
+
let dir = Option.map (fun d -> d.Fl_metascanner.def_value) dir in
46
+
let archive_name =
47
+
Option.bind archive_filename (fun a ->
48
+
let file_name_len = String.length a in
49
+
if file_name_len > 0 then Some (Filename.chop_extension a) else None)
50
+
in
51
+
[ { name = library_name; archive_name; dir; deps } ]
52
+
with Not_found -> []
53
+
54
+
let process_meta_file file =
55
+
let () = Format.eprintf "process_meta_file: %s\n%!" (Fpath.to_string file) in
56
+
let meta_dir = Fpath.parent file in
57
+
let meta =
58
+
OS.File.with_ic file (fun ic () -> Fl_metascanner.parse ic) ()
59
+
|> Result.get_ok
60
+
in
61
+
let base_library_name =
62
+
if Fpath.basename file = "META" then Fpath.parent file |> Fpath.basename
63
+
else Fpath.get_ext file
64
+
in
65
+
let rec extract_name_and_archive ~prefix
66
+
((name, pkg_expr) : string * Fl_metascanner.pkg_expr) =
67
+
let library_name = prefix ^ "." ^ name in
68
+
let libraries =
69
+
read_libraries_from_pkg_defs ~library_name pkg_expr.pkg_defs
70
+
in
71
+
let child_libraries =
72
+
pkg_expr.pkg_children
73
+
|> List.map (extract_name_and_archive ~prefix:library_name)
74
+
|> List.flatten
75
+
in
76
+
libraries @ child_libraries
77
+
in
78
+
let libraries =
79
+
read_libraries_from_pkg_defs ~library_name:base_library_name meta.pkg_defs
80
+
in
81
+
let is_not_private (lib : library) =
82
+
not
83
+
(String.split_on_char '.' lib.name
84
+
|> List.exists (fun x -> x = "__private__"))
85
+
in
86
+
let libraries =
87
+
libraries
88
+
@ (meta.pkg_children
89
+
|> List.map (extract_name_and_archive ~prefix:base_library_name)
90
+
|> List.flatten)
91
+
|> List.filter is_not_private
92
+
in
93
+
{ meta_dir; libraries }
94
+
95
+
let libname_of_archive v =
96
+
let { meta_dir; libraries } = v in
97
+
List.fold_left
98
+
(fun acc (x : library) ->
99
+
match x.archive_name with
100
+
| None -> acc
101
+
| Some archive_name ->
102
+
let dir =
103
+
match x.dir with
104
+
| None -> meta_dir
105
+
| Some x -> Fpath.(meta_dir // v x)
106
+
in
107
+
Fpath.Map.update
108
+
Fpath.(dir / archive_name)
109
+
(function
110
+
| None -> Some x.name
111
+
| Some y ->
112
+
Logs.err (fun m ->
113
+
m "Multiple libraries for archive %s: %s and %s."
114
+
archive_name x.name y);
115
+
Some y)
116
+
acc)
117
+
Fpath.Map.empty libraries
118
+
119
+
let directories v =
120
+
let { meta_dir; libraries } = v in
121
+
List.fold_left
122
+
(fun acc x ->
123
+
match x.dir with
124
+
| None | Some "" -> Fpath.Set.add meta_dir acc
125
+
| Some x -> (
126
+
let dir = Fpath.(meta_dir // v x) in
127
+
(* NB. topkg installs a META file that points to a ../topkg-care directory
128
+
that is installed by the topkg-care package. We filter that out here,
129
+
though I've not thought of a good way to sort out the `topkg-care` package *)
130
+
match OS.Dir.exists dir with
131
+
| Ok true -> Fpath.Set.add dir acc
132
+
| _ -> acc))
133
+
Fpath.Set.empty libraries
+23
driver/library_names.mli
+23
driver/library_names.mli
···
1
+
type library = {
2
+
name : string;
3
+
archive_name : string option;
4
+
dir : string option;
5
+
deps : string list;
6
+
}
7
+
8
+
type t = { meta_dir : Fpath.t; libraries : library list }
9
+
10
+
val process_meta_file : Fpath.t -> t
11
+
(** From a path to a [Meta] file, returns the list of libraries defined in this
12
+
file. *)
13
+
14
+
val libname_of_archive : t -> string Fpath.map
15
+
(** [libname_of_archive meta_dir libraries] computes a map from the
16
+
fully-qualified archive path to the name of the library. [meta_path] is the
17
+
path of the directory where the META file is found, and [libraries] are the
18
+
libraries defined in that META file. *)
19
+
20
+
val directories : t -> Fpath.set
21
+
(** [directories meta_dir libraries] computes a set of directories containing
22
+
the libraries in [libraries] defined in the META file found in [meta_path].
23
+
*)
+251
driver/monorepo_style.ml
+251
driver/monorepo_style.ml
···
1
+
(* Dune build tree *)
2
+
open Bos
3
+
open Sexplib.Std
4
+
[@@@warning "-69-30"]
5
+
6
+
let monorepo_pkg_name = "__pkg__"
7
+
8
+
let dune = ref (Cmd.v "dune")
9
+
10
+
type item = Library of library
11
+
12
+
and items = item list
13
+
14
+
and module_ = {
15
+
name : string;
16
+
impl : string option;
17
+
intf : string option;
18
+
cmt : string option;
19
+
cmti : string option;
20
+
}
21
+
22
+
and library = {
23
+
name : string;
24
+
uid : uid;
25
+
local : bool;
26
+
requires : uid list;
27
+
source_dir : string;
28
+
modules : module_ list;
29
+
include_dirs : string list;
30
+
}
31
+
32
+
and library_list = library list
33
+
34
+
and uid = string [@@deriving sexp]
35
+
36
+
(* Eurgh *)
37
+
let internal_name_of_library : library -> (string * Fpath.t) option =
38
+
fun l ->
39
+
match l.modules with
40
+
| [] -> None
41
+
| m :: _ -> (
42
+
let ps = List.filter_map (fun x -> x) [ m.cmt; m.cmti ] in
43
+
match ps with
44
+
| [] -> None
45
+
| p :: _ -> (
46
+
let p' = Fpath.relativize ~root:(Fpath.v l.source_dir) (Fpath.v p) in
47
+
match Option.map Fpath.segs p' with
48
+
| Some (objdir :: "byte" :: _) -> (
49
+
(* cmt files are expected to be in [library_path/.libname.objs/byte/name.cmt]. *)
50
+
match Astring.String.fields ~is_sep:(fun c -> c = '.') objdir with
51
+
| [ ""; libname; "objs" ] ->
52
+
Some (libname, Fpath.(parent (v p) |> rem_empty_seg))
53
+
| _ -> None)
54
+
| _ -> None))
55
+
56
+
let of_dune_describe txt =
57
+
let sexp = Sexplib.Sexp.of_string txt in
58
+
let open Sexplib0.Sexp in
59
+
match sexp with
60
+
| Atom _ -> []
61
+
| List ls ->
62
+
let libs =
63
+
List.filter_map (fun s -> try Some (item_of_sexp s) with _ -> None) ls
64
+
in
65
+
libs
66
+
let dune_describe dir =
67
+
let cmd = Cmd.(!dune % "describe" % "--root" % p dir) in
68
+
let out = Worker_pool.submit "dune describe" cmd None in
69
+
match out with Error _ -> [] | Ok out -> of_dune_describe out.Run.output
70
+
71
+
let of_dune_build dir ~extra_pkgs ~extra_libs =
72
+
let root = Fpath.(dir / "_build" / "default") in
73
+
let contents =
74
+
Bos.OS.Dir.fold_contents ~dotfiles:true (fun p acc -> p :: acc) [] root
75
+
in
76
+
match contents with
77
+
| Error _ -> []
78
+
| Ok c ->
79
+
let cset = Fpath.Set.of_list c in
80
+
let libs = dune_describe dir in
81
+
82
+
let local_libs, global_libs =
83
+
List.partition
84
+
(function l -> l.local)
85
+
(List.filter_map (function Library l -> Some l) libs)
86
+
in
87
+
88
+
List.iter
89
+
(fun (lib : library) ->
90
+
Logs.debug (fun m ->
91
+
m "lib %s internal name: (%a)" lib.name
92
+
Fmt.(option (pair string Fpath.pp))
93
+
(internal_name_of_library lib)))
94
+
local_libs;
95
+
96
+
let uid_to_libname =
97
+
List.fold_left
98
+
(fun acc l -> Util.StringMap.add l.uid l.name acc)
99
+
Util.StringMap.empty (local_libs @ global_libs)
100
+
in
101
+
102
+
let all_lib_deps =
103
+
List.fold_left
104
+
(fun acc (l : library) ->
105
+
let libs =
106
+
List.filter_map
107
+
(fun uid -> Util.StringMap.find_opt uid uid_to_libname)
108
+
l.requires
109
+
in
110
+
let libs = if l.name = "stdlib" then libs else "stdlib" :: libs in
111
+
Util.StringMap.add l.name (libs |> Util.StringSet.of_list) acc)
112
+
Util.StringMap.empty (local_libs @ global_libs)
113
+
in
114
+
115
+
let rec with_trans_deps =
116
+
let cache = Hashtbl.create (List.length libs) in
117
+
fun lib_name ->
118
+
try Hashtbl.find cache lib_name
119
+
with Not_found ->
120
+
let libs =
121
+
try Util.StringMap.find lib_name all_lib_deps
122
+
with Not_found ->
123
+
Logs.debug (fun m -> m "No lib deps for library %s" lib_name);
124
+
Util.StringSet.empty
125
+
in
126
+
let result =
127
+
Util.StringSet.fold
128
+
(fun l acc -> Util.StringSet.union (with_trans_deps l) acc)
129
+
libs libs
130
+
in
131
+
Hashtbl.add cache lib_name result;
132
+
result
133
+
in
134
+
135
+
let all_lib_deps =
136
+
Util.StringMap.mapi
137
+
(fun lib_name _ -> with_trans_deps lib_name)
138
+
all_lib_deps
139
+
in
140
+
141
+
let colon = Fmt.any ":" in
142
+
Format.eprintf "all_lib_deps: %a@."
143
+
Fmt.(list ~sep:comma (pair ~sep:colon string (list ~sep:semi string)))
144
+
(Util.StringMap.to_list all_lib_deps
145
+
|> List.map (fun (x, y) -> (x, Util.StringSet.elements y)));
146
+
147
+
(* Format.eprintf "libs: %s@." (Sexplib.Sexp.to_string_hum (sexp_of_library_list local_libs)); *)
148
+
let libname_of_archive =
149
+
List.fold_left
150
+
(fun acc item ->
151
+
match item with
152
+
| Library lib -> (
153
+
let libname_opt = internal_name_of_library lib in
154
+
match libname_opt with
155
+
| Some (libname, _) ->
156
+
let archive =
157
+
Fpath.(append dir (v lib.source_dir / libname))
158
+
in
159
+
Logs.debug (fun m ->
160
+
m "libname_of_archive: %a -> %s" Fpath.pp archive
161
+
lib.name);
162
+
Fpath.Map.add archive lib.name acc
163
+
| None -> acc))
164
+
Fpath.Map.empty libs
165
+
in
166
+
let libs =
167
+
List.filter_map
168
+
(fun lib ->
169
+
match internal_name_of_library lib with
170
+
| None -> None
171
+
| Some (libname, cmtidir) ->
172
+
let cmtidir = Fpath.(append dir cmtidir) in
173
+
let id_override =
174
+
Fpath.relativize
175
+
~root:Fpath.(v "_build/default")
176
+
Fpath.(v lib.source_dir)
177
+
|> Option.map Fpath.to_string
178
+
in
179
+
(match id_override with
180
+
| None ->
181
+
Logs.warn (fun m ->
182
+
m "Could not determine id_override for library '%s'"
183
+
libname)
184
+
| _ -> ());
185
+
if Fpath.Set.mem cmtidir cset then
186
+
Some
187
+
(Packages.Lib.v ~libname_of_archive ~pkg_name:lib.name
188
+
~dir:(Fpath.append dir (Fpath.v lib.source_dir))
189
+
~cmtidir:(Some cmtidir) ~all_lib_deps ~cmi_only_libs:[]
190
+
~id_override)
191
+
else None)
192
+
local_libs
193
+
in
194
+
let find_docs ext =
195
+
List.filter_map
196
+
(fun f ->
197
+
if Fpath.has_ext ext f then
198
+
let rel_path = Fpath.relativize ~root f |> Option.get in
199
+
Some (f, rel_path)
200
+
else None)
201
+
c
202
+
in
203
+
let other_docs =
204
+
find_docs ".md"
205
+
|> List.map (fun (p, r) -> { Packages.md_path = p; md_rel_path = r })
206
+
in
207
+
let mlds =
208
+
find_docs ".mld"
209
+
|> List.map (fun (p, r) -> { Packages.mld_path = p; mld_rel_path = r })
210
+
in
211
+
let assets =
212
+
find_docs ".jpg"
213
+
|> List.map (fun (p, r) ->
214
+
{ Packages.asset_path = p; asset_rel_path = r })
215
+
in
216
+
let libs = List.flatten libs in
217
+
let global_config =
218
+
{
219
+
Global_config.deps =
220
+
{
221
+
packages = extra_pkgs;
222
+
libraries =
223
+
extra_libs
224
+
@ List.map (fun (lib : Packages.libty) -> lib.lib_name) libs;
225
+
};
226
+
}
227
+
in
228
+
let local =
229
+
[
230
+
{
231
+
Packages.name = monorepo_pkg_name;
232
+
version = "1.0";
233
+
libraries = libs;
234
+
mlds;
235
+
assets;
236
+
selected = true;
237
+
remaps = [];
238
+
pkg_dir = Fpath.v ".";
239
+
doc_dir = Fpath.v ".";
240
+
other_docs;
241
+
config = global_config;
242
+
};
243
+
]
244
+
in
245
+
let global =
246
+
Packages.of_libs
247
+
~packages_dir:(Some (Fpath.v "opam_switch"))
248
+
(List.map (fun (l : library) -> l.name) global_libs
249
+
|> Util.StringSet.of_list)
250
+
in
251
+
local @ global
+4
driver/monorepo_style.mli
+4
driver/monorepo_style.mli
+215
driver/ocamlfind.ml
+215
driver/ocamlfind.ml
···
1
+
let init =
2
+
let initialized = ref false in
3
+
fun () ->
4
+
if !initialized then ()
5
+
else
6
+
let prefix = Opam.prefix () in
7
+
let env_camllib = Fpath.(v prefix / "lib" / "ocaml" |> to_string) in
8
+
let config = Fpath.(v prefix / "lib" / "findlib.conf" |> to_string) in
9
+
Findlib.init ~config ~env_camllib ()
10
+
11
+
let all () =
12
+
init ();
13
+
Fl_package_base.list_packages ()
14
+
15
+
let get_dir lib =
16
+
try
17
+
init ();
18
+
Fl_package_base.query lib |> fun x ->
19
+
Ok Fpath.(v x.package_dir |> to_dir_path)
20
+
with e ->
21
+
Logs.err (fun m -> m "Error: %s\n" (Printexc.to_string e));
22
+
Error (`Msg "Error getting directory")
23
+
24
+
let archives pkg =
25
+
init ();
26
+
let package = Fl_package_base.query pkg in
27
+
let get_1 preds =
28
+
try
29
+
[
30
+
Fl_metascanner.lookup "archive" preds
31
+
package.Fl_package_base.package_defs;
32
+
]
33
+
with _ -> []
34
+
in
35
+
match pkg with
36
+
| "stdlib" -> [ "stdlib.cma"; "stdlib.cmxa" ]
37
+
| _ ->
38
+
get_1 [ "native" ] @ get_1 [ "byte" ]
39
+
@ get_1 [ "native"; "ppx_driver" ]
40
+
@ get_1 [ "byte"; "ppx_driver" ]
41
+
|> List.filter (fun x -> String.length x > 0)
42
+
|> List.sort_uniq String.compare
43
+
44
+
let sub_libraries top =
45
+
init ();
46
+
let packages = Fl_package_base.list_packages () in
47
+
List.fold_left
48
+
(fun acc lib ->
49
+
let package = String.split_on_char '.' lib |> List.hd in
50
+
if package = top then Util.StringSet.add lib acc else acc)
51
+
Util.StringSet.empty packages
52
+
53
+
(* Returns deep dependencies for the given package *)
54
+
let rec dep =
55
+
let memo = ref Util.StringMap.empty in
56
+
fun pkg ->
57
+
init ();
58
+
try Util.StringMap.find pkg !memo
59
+
with Not_found -> (
60
+
try
61
+
let deps = Fl_package_base.requires ~preds:[ "ppx_driver" ] pkg in
62
+
let result =
63
+
List.fold_left
64
+
(fun acc x ->
65
+
match dep x with
66
+
| Ok dep_deps -> Util.StringSet.(union acc (add x dep_deps))
67
+
| Error _ -> acc)
68
+
Util.StringSet.empty deps
69
+
in
70
+
memo := Util.StringMap.add pkg (Ok result) !memo;
71
+
Ok result
72
+
with e ->
73
+
let result = Error (`Msg (Printexc.to_string e)) in
74
+
memo := Util.StringMap.add pkg result !memo;
75
+
result)
76
+
77
+
let deps pkgs =
78
+
let results = List.map dep pkgs in
79
+
Ok
80
+
(List.fold_left Util.StringSet.union
81
+
(Util.StringSet.singleton "stdlib")
82
+
(List.map (Result.value ~default:Util.StringSet.empty) results))
83
+
84
+
module Db = struct
85
+
type t = {
86
+
all_libs : Util.StringSet.t;
87
+
all_lib_deps : Util.StringSet.t Util.StringMap.t;
88
+
lib_dirs_and_archives : (string * Fpath.t * Util.StringSet.t) list;
89
+
archives_by_dir : Util.StringSet.t Fpath.map;
90
+
libname_of_archive : string Fpath.map;
91
+
cmi_only_libs : (Fpath.t * string) list;
92
+
}
93
+
94
+
let create libs =
95
+
let _ = Opam.prefix () in
96
+
let libs = Util.StringSet.to_seq libs |> List.of_seq in
97
+
98
+
(* First, find the complete set of libraries - that is, including all of
99
+
the dependencies of the libraries supplied on the commandline *)
100
+
let all_libs_deps =
101
+
match deps libs with
102
+
| Error (`Msg msg) ->
103
+
Logs.err (fun m -> m "Error finding dependencies: %s" msg);
104
+
Util.StringSet.empty
105
+
| Ok libs -> Util.StringSet.add "stdlib" libs
106
+
in
107
+
108
+
let all_libs_set =
109
+
Util.StringSet.union all_libs_deps (Util.StringSet.of_list libs)
110
+
in
111
+
let all_libs = Util.StringSet.elements all_libs_set in
112
+
113
+
(* Now we need the dependency tree of those libraries *)
114
+
let all_lib_deps =
115
+
List.fold_right
116
+
(fun lib_name acc ->
117
+
match deps [ lib_name ] with
118
+
| Ok deps -> Util.StringMap.add lib_name deps acc
119
+
| Error (`Msg msg) ->
120
+
Logs.err (fun m ->
121
+
m
122
+
"Error finding dependencies of library '%s' through \
123
+
ocamlfind: %s"
124
+
lib_name msg);
125
+
acc)
126
+
all_libs Util.StringMap.empty
127
+
in
128
+
129
+
(* We also need to find, for each library, the library directory and
130
+
the list of archives for that library *)
131
+
let lib_dirs_and_archives =
132
+
List.filter_map
133
+
(fun lib ->
134
+
match get_dir lib with
135
+
| Error _ ->
136
+
Logs.err (fun m -> m "No dir for library %s" lib);
137
+
None
138
+
| Ok p ->
139
+
let archives = archives lib in
140
+
let archives =
141
+
List.map
142
+
(fun x ->
143
+
try Filename.chop_extension x
144
+
with e ->
145
+
Logs.err (fun m -> m "Can't chop extension from %s" x);
146
+
raise e)
147
+
archives
148
+
in
149
+
let archives = Util.StringSet.(of_list archives) in
150
+
Some (lib, p, archives))
151
+
all_libs
152
+
in
153
+
154
+
(* An individual directory may contain multiple libraries, each with
155
+
zero or more archives. We need to know which directories contain
156
+
which archives *)
157
+
let archives_by_dir =
158
+
List.fold_left
159
+
(fun set (_lib, p, archives) ->
160
+
Fpath.Map.update p
161
+
(function
162
+
| Some set -> Some (Util.StringSet.union set archives)
163
+
| None -> Some archives)
164
+
set)
165
+
Fpath.Map.empty lib_dirs_and_archives
166
+
in
167
+
168
+
(* Compute the mapping between full path of an archive to the
169
+
name of the libary *)
170
+
let libname_of_archive =
171
+
List.fold_left
172
+
(fun map (lib, dir, archives) ->
173
+
match Util.StringSet.elements archives with
174
+
| [] -> map
175
+
| [ archive ] ->
176
+
Fpath.Map.update
177
+
Fpath.(dir / archive)
178
+
(function
179
+
| None -> Some lib
180
+
| Some x ->
181
+
Logs.info (fun m ->
182
+
m
183
+
"Multiple libraries for archive %s: %s and %s. \
184
+
Arbitrarily picking the latter."
185
+
archive x lib);
186
+
Some lib)
187
+
map
188
+
| xs ->
189
+
Logs.err (fun m ->
190
+
m "multiple archives detected: [%a]"
191
+
Fmt.(list ~sep:sp string)
192
+
xs);
193
+
assert false)
194
+
Fpath.Map.empty lib_dirs_and_archives
195
+
in
196
+
197
+
(* We also need to know about libraries that have no archives at all
198
+
(these are virtual libraries usually) *)
199
+
let cmi_only_libs =
200
+
List.fold_left
201
+
(fun map (lib, dir, archives) ->
202
+
match Util.StringSet.elements archives with
203
+
| [] -> (dir, lib) :: map
204
+
| _ -> map)
205
+
[] lib_dirs_and_archives
206
+
in
207
+
{
208
+
all_libs = all_libs_set;
209
+
all_lib_deps;
210
+
lib_dirs_and_archives;
211
+
archives_by_dir;
212
+
libname_of_archive;
213
+
cmi_only_libs;
214
+
}
215
+
end
+27
driver/ocamlfind.mli
+27
driver/ocamlfind.mli
···
1
+
val get_dir : string -> (Fpath.t, [> `Msg of string ]) result
2
+
(** [get_dir libname] returns the path where [libname] is installed *)
3
+
4
+
val all : unit -> string list
5
+
(** [all ()] returns a list of all packages *)
6
+
7
+
val archives : string -> string list
8
+
(** Returns the list of archive file names of a given library *)
9
+
10
+
val sub_libraries : string -> Util.StringSet.t
11
+
(** Returns the list of sublibraries of a given library *)
12
+
13
+
val deps : string list -> (Util.StringSet.t, [> `Msg of string ]) result
14
+
(** Returns the list of transitive package dependencies of given libraries *)
15
+
16
+
module Db : sig
17
+
type t = {
18
+
all_libs : Util.StringSet.t;
19
+
all_lib_deps : Util.StringSet.t Util.StringMap.t;
20
+
lib_dirs_and_archives : (string * Fpath.t * Util.StringSet.t) list;
21
+
archives_by_dir : Util.StringSet.t Fpath.map;
22
+
libname_of_archive : string Fpath.map;
23
+
cmi_only_libs : (Fpath.t * string) list;
24
+
}
25
+
26
+
val create : Util.StringSet.t -> t
27
+
end
+68
driver/ocamlobjinfo.ml
+68
driver/ocamlobjinfo.ml
···
1
+
(* ocamlobjinfo *)
2
+
3
+
open Bos
4
+
let ocamlobjinfo = Cmd.v "ocamlobjinfo"
5
+
6
+
let source_possibilities file =
7
+
let default = [ file ] in
8
+
let generated =
9
+
if Astring.String.is_suffix ~affix:"-gen" file then
10
+
let pos = String.length file - 4 in
11
+
[ Astring.String.take ~max:pos file ]
12
+
else []
13
+
in
14
+
let pp =
15
+
if Astring.String.is_suffix ~affix:".pp.ml" file then
16
+
let pos = String.length file - 5 in
17
+
[ Astring.String.take ~max:pos file ^ "ml" ]
18
+
else []
19
+
in
20
+
pp @ default @ generated
21
+
22
+
let get_source file srcdirs =
23
+
let cmd = Cmd.(ocamlobjinfo % p file) in
24
+
let lines_res =
25
+
Worker_pool.submit ("Ocamlobjinfo " ^ Fpath.to_string file) cmd None
26
+
in
27
+
let lines =
28
+
match lines_res with
29
+
| Ok l -> String.split_on_char '\n' l.output
30
+
| Error e ->
31
+
Logs.err (fun m ->
32
+
m "Error finding source for module %a: %s" Fpath.pp file
33
+
(Printexc.to_string e));
34
+
[]
35
+
in
36
+
let f =
37
+
List.filter_map
38
+
(fun line ->
39
+
let affix = "Source file: " in
40
+
if Astring.String.is_prefix ~affix line then
41
+
let name =
42
+
String.sub line (String.length affix)
43
+
(String.length line - String.length affix)
44
+
in
45
+
let name = Fpath.(filename (v name)) in
46
+
let possibilities =
47
+
List.map
48
+
(fun dir ->
49
+
List.map
50
+
(fun poss -> Fpath.(dir / poss))
51
+
(source_possibilities name))
52
+
srcdirs
53
+
|> List.flatten
54
+
in
55
+
List.find_opt
56
+
(fun f ->
57
+
Logs.debug (fun m -> m "src: checking %a" Fpath.pp f);
58
+
Sys.file_exists (Fpath.to_string f))
59
+
possibilities
60
+
else None)
61
+
lines
62
+
in
63
+
match f with
64
+
| [] -> None
65
+
| x :: _ :: _ ->
66
+
Logs.warn (fun m -> m "Multiple source files found for %a" Fpath.pp file);
67
+
Some x
68
+
| x :: _ -> Some x
+3
driver/ocamlobjinfo.mli
+3
driver/ocamlobjinfo.mli
+331
driver/odoc.ml
+331
driver/odoc.ml
···
1
+
open Bos
2
+
3
+
module Id : sig
4
+
type t
5
+
val to_fpath : t -> Fpath.t
6
+
val of_fpath : Fpath.t -> t
7
+
val to_string : t -> string
8
+
end = struct
9
+
type t = Fpath.t
10
+
11
+
let to_fpath id = id
12
+
13
+
let of_fpath id = id |> Fpath.normalize |> Fpath.rem_empty_seg
14
+
(* If an odoc path ends with a [/] everything breaks *)
15
+
16
+
let to_string id = match Fpath.to_string id with "." -> "" | v -> v
17
+
end
18
+
19
+
let index_filename = "index.odoc-index"
20
+
21
+
let sidebar_filename = "sidebar.odoc-sidebar"
22
+
23
+
type compile_deps = { digest : Digest.t; deps : (string * Digest.t) list }
24
+
25
+
let odoc = ref (Cmd.v "odoc")
26
+
27
+
let odoc_md = ref (Cmd.v "odoc-md")
28
+
29
+
let compile_deps f =
30
+
let cmd = Cmd.(!odoc % "compile-deps" % Fpath.to_string f) in
31
+
let desc = Printf.sprintf "Compile deps for %s" (Fpath.to_string f) in
32
+
let deps = Cmd_outputs.submit None desc cmd None in
33
+
let l = List.filter_map (Astring.String.cut ~sep:" ") deps in
34
+
let basename = Fpath.(basename (f |> rem_ext)) |> String.capitalize_ascii in
35
+
match List.partition (fun (n, _) -> basename = n) l with
36
+
| [ (_, digest) ], deps -> Ok { digest; deps }
37
+
| _ -> Error (`Msg "odd")
38
+
39
+
let compile ~output_dir ~input_file:file ~includes ~warnings_tag ~parent_id
40
+
~ignore_output =
41
+
let open Cmd in
42
+
let includes =
43
+
Fpath.Set.fold
44
+
(fun path acc -> Cmd.(acc % "-I" % p path))
45
+
includes Cmd.empty
46
+
in
47
+
48
+
let output_file =
49
+
let _, f = Fpath.split_base file in
50
+
Some Fpath.(output_dir // Id.to_fpath parent_id // set_ext "odoc" f)
51
+
in
52
+
let cmd =
53
+
!odoc % "compile" % Fpath.to_string file % "--output-dir" % p output_dir
54
+
%% includes % "--enable-missing-root-warning"
55
+
in
56
+
let cmd = cmd % "--parent-id" % Id.to_string parent_id in
57
+
let cmd =
58
+
match warnings_tag with
59
+
| None -> cmd
60
+
| Some tag -> cmd % "--warnings-tag" % tag
61
+
in
62
+
let desc = Printf.sprintf "Compiling %s" (Fpath.to_string file) in
63
+
let log =
64
+
if ignore_output then None else Some (`Compile, Fpath.to_string file)
65
+
in
66
+
ignore @@ Cmd_outputs.submit log desc cmd output_file
67
+
68
+
let compile_md ~output_dir ~input_file:file ~parent_id =
69
+
let open Cmd in
70
+
let output_file =
71
+
let _, f = Fpath.split_base file in
72
+
Some Fpath.(output_dir // Id.to_fpath parent_id // set_ext "odoc" f)
73
+
in
74
+
let cmd = !odoc_md % p file % "--output-dir" % p output_dir in
75
+
let cmd =
76
+
match Id.to_string parent_id with "" -> cmd | x -> cmd % "--parent-id" % x
77
+
in
78
+
let desc = Printf.sprintf "Compiling Markdown %s" (Fpath.to_string file) in
79
+
let _lines =
80
+
Cmd_outputs.submit
81
+
(Some (`Compile, Fpath.to_string file))
82
+
desc cmd output_file
83
+
in
84
+
()
85
+
86
+
let compile_asset ~output_dir ~name ~parent_id =
87
+
let open Cmd in
88
+
let output_file =
89
+
Some
90
+
Fpath.(output_dir // Id.to_fpath parent_id / ("asset-" ^ name ^ ".odoc"))
91
+
in
92
+
let cmd =
93
+
!odoc % "compile-asset" % "--name" % name % "--output-dir" % p output_dir
94
+
in
95
+
96
+
let cmd = cmd % "--parent-id" % Id.to_string parent_id in
97
+
let desc = Printf.sprintf "Compiling %s" name in
98
+
ignore @@ Cmd_outputs.submit (Some (`Compile, name)) desc cmd output_file
99
+
100
+
let compile_impl ~output_dir ~input_file:file ~includes ~parent_id ~source_id =
101
+
let open Cmd in
102
+
let includes =
103
+
Fpath.Set.fold
104
+
(fun path acc -> Cmd.(acc % "-I" % p path))
105
+
includes Cmd.empty
106
+
in
107
+
let cmd =
108
+
!odoc % "compile-impl" % Fpath.to_string file % "--output-dir"
109
+
% p output_dir %% includes % "--enable-missing-root-warning"
110
+
in
111
+
let output_file =
112
+
let _, f = Fpath.split_base file in
113
+
Some
114
+
Fpath.(
115
+
output_dir // Id.to_fpath parent_id
116
+
/ ("impl-" ^ to_string (set_ext "odoc" f)))
117
+
in
118
+
let cmd = cmd % "--parent-id" % Id.to_string parent_id in
119
+
let cmd = cmd % "--source-id" % Id.to_string source_id in
120
+
let desc =
121
+
Printf.sprintf "Compiling implementation %s" (Fpath.to_string file)
122
+
in
123
+
ignore
124
+
@@ Cmd_outputs.submit
125
+
(Some (`Compile, Fpath.to_string file))
126
+
desc cmd output_file
127
+
128
+
let doc_args docs =
129
+
let open Cmd in
130
+
List.fold_left
131
+
(fun acc (pkg_name, path) ->
132
+
let s = Format.asprintf "%s:%a" pkg_name Fpath.pp path in
133
+
v "-P" % s %% acc)
134
+
Cmd.empty docs
135
+
136
+
let lib_args libs =
137
+
let open Cmd in
138
+
List.fold_left
139
+
(fun acc (libname, path) ->
140
+
let s = Format.asprintf "%s:%a" libname Fpath.pp path in
141
+
v "-L" % s %% acc)
142
+
Cmd.empty libs
143
+
144
+
let link ?(ignore_output = false) ~custom_layout ~input_file:file ?output_file
145
+
~docs ~libs ~includes ~warnings_tags ?current_package () =
146
+
let open Cmd in
147
+
let output_file =
148
+
match output_file with Some f -> f | None -> Fpath.set_ext "odocl" file
149
+
in
150
+
let docs = doc_args docs in
151
+
let libs = lib_args libs in
152
+
let includes =
153
+
List.fold_left (fun acc i -> acc % "-I" % p i) empty includes
154
+
in
155
+
let current_package =
156
+
match current_package with
157
+
| None -> Cmd.empty
158
+
| Some c -> Cmd.(v "--current-package" % c)
159
+
in
160
+
let cmd =
161
+
!odoc % "link" % p file % "-o" % p output_file %% docs %% libs %% includes
162
+
%% current_package % "--enable-missing-root-warning"
163
+
in
164
+
let cmd =
165
+
if Fpath.to_string file = "stdlib.odoc" then cmd % "--open=\"\"" else cmd
166
+
in
167
+
let cmd =
168
+
List.fold_left (fun acc k -> acc % "--warnings-tags" % k) cmd warnings_tags
169
+
in
170
+
let desc = Printf.sprintf "Linking %s" (Fpath.to_string file) in
171
+
let cmd = if custom_layout then cmd % "--custom-layout" else cmd in
172
+
let log =
173
+
if ignore_output then None else Some (`Link, Fpath.to_string file)
174
+
in
175
+
ignore @@ Cmd_outputs.submit log desc cmd (Some output_file)
176
+
177
+
let compile_index ?(ignore_output = false) ~output_file ?occurrence_file ~json
178
+
~roots ~simplified ~wrap () =
179
+
let roots =
180
+
List.fold_left (fun c r -> Cmd.(c % "--root" % p r)) Cmd.empty roots
181
+
in
182
+
let json = if json then Cmd.v "--json" else Cmd.empty in
183
+
let simplified =
184
+
if simplified then Cmd.v "--simplified-json" else Cmd.empty
185
+
in
186
+
let wrap = if wrap then Cmd.v "--wrap-json" else Cmd.empty in
187
+
let occ =
188
+
match occurrence_file with
189
+
| None -> Cmd.empty
190
+
| Some f -> Cmd.(v "--occurrences" % p f)
191
+
in
192
+
let cmd =
193
+
Cmd.(
194
+
!odoc % "compile-index" %% json %% simplified %% wrap %% v "-o"
195
+
% p output_file %% roots %% occ)
196
+
in
197
+
let desc =
198
+
Printf.sprintf "Generating index for %s" (Fpath.to_string output_file)
199
+
in
200
+
let log =
201
+
if ignore_output then None else Some (`Index, Fpath.to_string output_file)
202
+
in
203
+
ignore @@ Cmd_outputs.submit log desc cmd (Some output_file)
204
+
205
+
let sidebar_generate ?(ignore_output = false) ~output_file ~json input_file () =
206
+
let json = if json then Cmd.v "--json" else Cmd.empty in
207
+
let cmd =
208
+
Cmd.(
209
+
!odoc % "sidebar-generate" %% json %% v "-o" % p output_file
210
+
% p input_file)
211
+
in
212
+
let desc =
213
+
Printf.sprintf "Generating sidebar for %s" (Fpath.to_string output_file)
214
+
in
215
+
let log =
216
+
if ignore_output then None else Some (`Generate, Fpath.to_string output_file)
217
+
in
218
+
ignore @@ Cmd_outputs.submit log desc cmd (Some output_file)
219
+
220
+
let html_generate ~output_dir ?sidebar ?(ignore_output = false)
221
+
?(search_uris = []) ?remap ?(as_json = false) ?home_breadcrumb
222
+
~input_file:file () =
223
+
let open Cmd in
224
+
let index =
225
+
match sidebar with None -> empty | Some idx -> v "--sidebar" % p idx
226
+
in
227
+
let home_breadcrumb =
228
+
match home_breadcrumb with
229
+
| None -> empty
230
+
| Some name -> v "--home-breadcrumb" % name
231
+
in
232
+
let search_uris =
233
+
List.fold_left
234
+
(fun acc filename -> acc % "--search-uri" % p filename)
235
+
empty search_uris
236
+
in
237
+
let cmd =
238
+
!odoc % "html-generate" % p file %% index %% search_uris % "-o" % output_dir
239
+
%% home_breadcrumb
240
+
in
241
+
let cmd =
242
+
match remap with None -> cmd | Some f -> cmd % "--remap-file" % p f
243
+
in
244
+
let cmd = if as_json then cmd % "--as-json" else cmd in
245
+
let desc = Printf.sprintf "Generating HTML for %s" (Fpath.to_string file) in
246
+
let log =
247
+
if ignore_output then None else Some (`Generate, Fpath.to_string file)
248
+
in
249
+
ignore @@ Cmd_outputs.submit log desc cmd None
250
+
251
+
let html_generate_asset ~output_dir ?(ignore_output = false) ?home_breadcrumb
252
+
~input_file:file ~asset_path () =
253
+
let open Cmd in
254
+
let home_breadcrumb =
255
+
match home_breadcrumb with
256
+
| None -> empty
257
+
| Some name -> v "--home-breadcrumb" % name
258
+
in
259
+
let cmd =
260
+
!odoc % "html-generate-asset" % "-o" % output_dir % "--asset-unit" % p file
261
+
% p asset_path %% home_breadcrumb
262
+
in
263
+
let desc = Printf.sprintf "Copying asset %s" (Fpath.to_string file) in
264
+
let log =
265
+
if ignore_output then None else Some (`Generate, Fpath.to_string file)
266
+
in
267
+
ignore @@ Cmd_outputs.submit log desc cmd None
268
+
269
+
let html_generate_source ~output_dir ?(ignore_output = false) ~source ?sidebar
270
+
?(search_uris = []) ?(as_json = false) ?home_breadcrumb ~input_file:file ()
271
+
=
272
+
let open Cmd in
273
+
let file = v "--impl" % p file in
274
+
let sidebar =
275
+
match sidebar with None -> empty | Some idx -> v "--sidebar" % p idx
276
+
in
277
+
let home_breadcrumb =
278
+
match home_breadcrumb with
279
+
| None -> empty
280
+
| Some name -> v "--home-breadcrumb" % name
281
+
in
282
+
let search_uris =
283
+
List.fold_left
284
+
(fun acc filename -> acc % "--search-uri" % p filename)
285
+
empty search_uris
286
+
in
287
+
let cmd =
288
+
!odoc % "html-generate-source" %% file %% sidebar % p source %% search_uris
289
+
% "-o" % output_dir %% home_breadcrumb
290
+
in
291
+
let cmd = if as_json then cmd % "--as-json" else cmd in
292
+
293
+
let desc = Printf.sprintf "Generating HTML for %s" (Fpath.to_string source) in
294
+
let log =
295
+
if ignore_output then None else Some (`Generate, Fpath.to_string source)
296
+
in
297
+
ignore @@ Cmd_outputs.submit log desc cmd None
298
+
299
+
let support_files path =
300
+
let open Cmd in
301
+
let cmd = !odoc % "support-files" % "-o" % Fpath.to_string path in
302
+
let desc = "Generating support files" in
303
+
Cmd_outputs.submit None desc cmd None
304
+
305
+
let count_occurrences ~input ~output =
306
+
let open Cmd in
307
+
let input = Cmd.of_values Fpath.to_string input in
308
+
let output_c = v "-o" % p output in
309
+
let cmd = !odoc % "count-occurrences" %% input %% output_c in
310
+
let desc = "Counting occurrences" in
311
+
let log = Some (`Count_occurrences, Fpath.to_string output) in
312
+
ignore @@ Cmd_outputs.submit log desc cmd None
313
+
314
+
let classify dirs =
315
+
let open Cmd in
316
+
let cmd = List.fold_left (fun cmd d -> cmd % p d) (!odoc % "classify") dirs in
317
+
let desc =
318
+
Format.asprintf "Classifying [%a]" (Fmt.(list ~sep:sp) Fpath.pp) dirs
319
+
in
320
+
let log =
321
+
Some (`Classify, String.concat "," (List.map Fpath.to_string dirs))
322
+
in
323
+
let lines =
324
+
Cmd_outputs.submit log desc cmd None |> List.filter (fun l -> l <> "")
325
+
in
326
+
List.map
327
+
(fun line ->
328
+
match String.split_on_char ' ' line with
329
+
| name :: modules -> (name, modules)
330
+
| _ -> failwith "bad classify output")
331
+
lines
+104
driver/odoc.mli
+104
driver/odoc.mli
···
1
+
module Id : sig
2
+
type t
3
+
val to_fpath : t -> Fpath.t
4
+
val of_fpath : Fpath.t -> t
5
+
val to_string : t -> string
6
+
end
7
+
8
+
val index_filename : string
9
+
val sidebar_filename : string
10
+
11
+
val odoc : Bos.Cmd.t ref
12
+
val odoc_md : Bos.Cmd.t ref
13
+
14
+
type compile_deps = { digest : Digest.t; deps : (string * Digest.t) list }
15
+
val compile_deps : Fpath.t -> (compile_deps, [> `Msg of string ]) result
16
+
val classify : Fpath.t list -> (string * string list) list
17
+
val compile_impl :
18
+
output_dir:Fpath.t ->
19
+
input_file:Fpath.t ->
20
+
includes:Fpath.set ->
21
+
parent_id:Id.t ->
22
+
source_id:Id.t ->
23
+
unit
24
+
val compile :
25
+
output_dir:Fpath.t ->
26
+
input_file:Fpath.t ->
27
+
includes:Fpath.set ->
28
+
warnings_tag:string option ->
29
+
parent_id:Id.t ->
30
+
ignore_output:bool ->
31
+
unit
32
+
val compile_md :
33
+
output_dir:Fpath.t -> input_file:Fpath.t -> parent_id:Id.t -> unit
34
+
35
+
val compile_asset : output_dir:Fpath.t -> name:string -> parent_id:Id.t -> unit
36
+
37
+
val link :
38
+
?ignore_output:bool ->
39
+
custom_layout:bool ->
40
+
input_file:Fpath.t ->
41
+
?output_file:Fpath.t ->
42
+
docs:(string * Fpath.t) list ->
43
+
libs:(string * Fpath.t) list ->
44
+
includes:Fpath.t list ->
45
+
warnings_tags:string list ->
46
+
?current_package:string ->
47
+
unit ->
48
+
unit
49
+
50
+
val compile_index :
51
+
?ignore_output:bool ->
52
+
output_file:Fpath.t ->
53
+
?occurrence_file:Fpath.t ->
54
+
json:bool ->
55
+
roots:Fpath.t list ->
56
+
simplified:bool ->
57
+
wrap:bool ->
58
+
unit ->
59
+
unit
60
+
61
+
val sidebar_generate :
62
+
?ignore_output:bool ->
63
+
output_file:Fpath.t ->
64
+
json:bool ->
65
+
Fpath.t ->
66
+
unit ->
67
+
unit
68
+
69
+
val html_generate :
70
+
output_dir:string ->
71
+
?sidebar:Fpath.t ->
72
+
?ignore_output:bool ->
73
+
?search_uris:Fpath.t list ->
74
+
?remap:Fpath.t ->
75
+
?as_json:bool ->
76
+
?home_breadcrumb:string ->
77
+
input_file:Fpath.t ->
78
+
unit ->
79
+
unit
80
+
81
+
val html_generate_asset :
82
+
output_dir:string ->
83
+
?ignore_output:bool ->
84
+
?home_breadcrumb:string ->
85
+
input_file:Fpath.t ->
86
+
asset_path:Fpath.t ->
87
+
unit ->
88
+
unit
89
+
90
+
val html_generate_source :
91
+
output_dir:string ->
92
+
?ignore_output:bool ->
93
+
source:Fpath.t ->
94
+
?sidebar:Fpath.t ->
95
+
?search_uris:Fpath.t list ->
96
+
?as_json:bool ->
97
+
?home_breadcrumb:string ->
98
+
input_file:Fpath.t ->
99
+
unit ->
100
+
unit
101
+
102
+
val support_files : Fpath.t -> string list
103
+
104
+
val count_occurrences : input:Fpath.t list -> output:Fpath.t -> unit
+233
driver/odoc_unit.ml
+233
driver/odoc_unit.ml
···
1
+
module Pkg_args = struct
2
+
type t = {
3
+
odoc_dir : Fpath.t;
4
+
odocl_dir : Fpath.t;
5
+
includes : Fpath.Set.t;
6
+
pages : Fpath.t Util.StringMap.t;
7
+
libs : Fpath.t Util.StringMap.t;
8
+
}
9
+
10
+
let v ~odoc_dir ~odocl_dir ~includes ~pages ~libs =
11
+
let includes = Fpath.Set.of_list includes in
12
+
let pages, libs = Util.StringMap.(of_list pages, of_list libs) in
13
+
{ odoc_dir; odocl_dir; includes; pages; libs }
14
+
15
+
let map_rel dir m =
16
+
Util.StringMap.fold (fun a b acc -> (a, Fpath.(dir // b)) :: acc) m []
17
+
18
+
let compiled_pages v = map_rel v.odoc_dir v.pages
19
+
let compiled_libs v = map_rel v.odoc_dir v.libs
20
+
let includes (x : t) =
21
+
List.map (fun y -> Fpath.(x.odoc_dir // y)) (Fpath.Set.to_list x.includes)
22
+
let linked_pages v = map_rel v.odocl_dir v.pages
23
+
let linked_libs v = map_rel v.odocl_dir v.libs
24
+
25
+
let combine v1 v2 =
26
+
if v1.odoc_dir <> v2.odoc_dir then
27
+
Fmt.invalid_arg "combine: odoc_dir differs";
28
+
if v1.odocl_dir <> v2.odocl_dir then
29
+
Fmt.invalid_arg "combine: odocl_dir differs";
30
+
{
31
+
odoc_dir = v1.odoc_dir;
32
+
odocl_dir = v1.odocl_dir;
33
+
includes = Fpath.Set.union v1.includes v2.includes;
34
+
pages = Util.StringMap.union (fun _ x _ -> Some x) v1.pages v2.pages;
35
+
libs = Util.StringMap.union (fun _ x _ -> Some x) v1.libs v2.libs;
36
+
}
37
+
38
+
let pp fmt x =
39
+
let sfp_pp =
40
+
Fmt.(
41
+
list ~sep:comma (fun fmt (a, b) ->
42
+
Format.fprintf fmt "(%s, %a)" a Fpath.pp b))
43
+
in
44
+
Format.fprintf fmt
45
+
"@[<hov>odoc_dir: %a@;\
46
+
odocl_dir: %a@;\
47
+
includes: %a@;\
48
+
pages: [%a]@;\
49
+
libs: [%a]@]"
50
+
Fpath.pp x.odoc_dir Fpath.pp x.odocl_dir
51
+
Fmt.Dump.(list Fpath.pp)
52
+
(Fpath.Set.to_list x.includes)
53
+
sfp_pp
54
+
(Util.StringMap.bindings x.pages)
55
+
sfp_pp
56
+
(Util.StringMap.bindings x.libs)
57
+
end
58
+
59
+
type sidebar = { output_file : Fpath.t; json : bool; pkg_dir : Fpath.t }
60
+
61
+
type index = {
62
+
roots : Fpath.t list;
63
+
output_file : Fpath.t;
64
+
json : bool;
65
+
search_dir : Fpath.t;
66
+
sidebar : sidebar option;
67
+
pkg_name : string;
68
+
}
69
+
70
+
let pp_index fmt x =
71
+
Format.fprintf fmt
72
+
"@[<hov>roots: %a@;output_file: %a@;json: %b@;search_dir: %a@]"
73
+
(Fmt.list Fpath.pp) x.roots Fpath.pp x.output_file x.json Fpath.pp
74
+
x.search_dir
75
+
76
+
type 'a t = {
77
+
parent_id : Odoc.Id.t;
78
+
input_file : Fpath.t;
79
+
input_copy : Fpath.t option;
80
+
(* Used to stash cmtis from virtual libraries into the odoc dir for voodoo mode.
81
+
See https://github.com/ocaml/odoc/pull/1309 *)
82
+
output_dir : Fpath.t;
83
+
odoc_file : Fpath.t;
84
+
odocl_file : Fpath.t;
85
+
pkg_args : Pkg_args.t;
86
+
pkgname : string option;
87
+
index : index option;
88
+
enable_warnings : bool;
89
+
to_output : bool;
90
+
kind : 'a;
91
+
}
92
+
93
+
type intf_extra = {
94
+
hidden : bool;
95
+
hash : string;
96
+
deps : (string * Digest.t) list;
97
+
}
98
+
99
+
and intf = [ `Intf of intf_extra ]
100
+
101
+
type impl_extra = { src_id : Odoc.Id.t; src_path : Fpath.t }
102
+
type impl = [ `Impl of impl_extra ]
103
+
104
+
type mld = [ `Mld ]
105
+
type md = [ `Md ]
106
+
type asset = [ `Asset ]
107
+
108
+
type all_kinds = [ impl | intf | mld | asset | md ]
109
+
type any = all_kinds t
110
+
111
+
let rec pp_kind : all_kinds Fmt.t =
112
+
fun fmt x ->
113
+
match x with
114
+
| `Intf x -> Format.fprintf fmt "`Intf %a" pp_intf_extra x
115
+
| `Impl x -> Format.fprintf fmt "`Impl %a" pp_impl_extra x
116
+
| `Mld -> Format.fprintf fmt "`Mld"
117
+
| `Md -> Format.fprintf fmt "`Md"
118
+
| `Asset -> Format.fprintf fmt "`Asset"
119
+
120
+
and pp_intf_extra fmt x =
121
+
Format.fprintf fmt "@[<hov>hidden: %b@;hash: %s@;deps: [%a]@]" x.hidden x.hash
122
+
Fmt.Dump.(list (pair string string))
123
+
x.deps
124
+
125
+
and pp_impl_extra fmt x =
126
+
Format.fprintf fmt "@[<hov>src_id: %s@;src_path: %a@]"
127
+
(Odoc.Id.to_string x.src_id)
128
+
Fpath.pp x.src_path
129
+
130
+
and pp : all_kinds t Fmt.t =
131
+
fun fmt x ->
132
+
Format.fprintf fmt
133
+
"@[<hov>parent_id: %s@;\
134
+
input_file: %a@;\
135
+
output_dir: %a@;\
136
+
odoc_file: %a@;\
137
+
odocl_file: %a@;\
138
+
pkg_args: %a@;\
139
+
pkgname: %a@;\
140
+
index: %a@;\
141
+
kind:%a@;\
142
+
@]"
143
+
(Odoc.Id.to_string x.parent_id)
144
+
Fpath.pp x.input_file Fpath.pp x.output_dir Fpath.pp x.odoc_file Fpath.pp
145
+
x.odocl_file Pkg_args.pp x.pkg_args (Fmt.option Fmt.string) x.pkgname
146
+
(Fmt.option pp_index) x.index pp_kind
147
+
(x.kind :> all_kinds)
148
+
149
+
let pkg_dir : Packages.t -> Fpath.t = fun pkg -> pkg.pkg_dir
150
+
let doc_dir : Packages.t -> Fpath.t = fun pkg -> pkg.doc_dir
151
+
let lib_dir (pkg : Packages.t) (lib : Packages.libty) =
152
+
match lib.id_override with
153
+
| Some id -> Fpath.v id
154
+
| None -> Fpath.(doc_dir pkg / lib.Packages.lib_name)
155
+
let src_dir pkg = Fpath.(doc_dir pkg / "src")
156
+
let src_lib_dir (pkg : Packages.t) (lib : Packages.libty) =
157
+
match lib.id_override with
158
+
| Some id -> Fpath.v id
159
+
| None -> Fpath.(src_dir pkg / lib.Packages.lib_name)
160
+
161
+
type dirs = {
162
+
odoc_dir : Fpath.t;
163
+
odocl_dir : Fpath.t;
164
+
index_dir : Fpath.t;
165
+
mld_dir : Fpath.t;
166
+
}
167
+
168
+
let fix_virtual ~(precompiled_units : intf t list Util.StringMap.t)
169
+
~(units : intf t list Util.StringMap.t) =
170
+
Logs.debug (fun m ->
171
+
m "Fixing virtual libraries: %d precompiled units, %d other units"
172
+
(Util.StringMap.cardinal precompiled_units)
173
+
(Util.StringMap.cardinal units));
174
+
let all =
175
+
Util.StringMap.union
176
+
(fun h x y ->
177
+
Logs.debug (fun m ->
178
+
m "Unifying hash %s (%d, %d)" h (List.length x) (List.length y));
179
+
Some (x @ y))
180
+
precompiled_units units
181
+
in
182
+
Util.StringMap.map
183
+
(fun units ->
184
+
List.map
185
+
(fun unit ->
186
+
let uhash = match unit.kind with `Intf { hash; _ } -> hash in
187
+
if not (Fpath.has_ext "cmt" unit.input_file) then unit
188
+
else
189
+
match Util.StringMap.find uhash all with
190
+
| [ _ ] -> unit
191
+
| xs -> (
192
+
let unit_name =
193
+
Fpath.rem_ext unit.input_file |> Fpath.basename
194
+
in
195
+
match
196
+
List.filter
197
+
(fun (x : intf t) ->
198
+
(match x.kind with `Intf { hash; _ } -> uhash = hash)
199
+
&& Fpath.has_ext "cmti" x.input_file
200
+
&& Fpath.rem_ext x.input_file |> Fpath.basename
201
+
= unit_name)
202
+
xs
203
+
with
204
+
| [ x ] -> { unit with input_file = x.input_file }
205
+
| xs -> (
206
+
Logs.debug (fun m ->
207
+
m
208
+
"Duplicate hash found, but multiple (%d) matching \
209
+
cmti found for %a"
210
+
(List.length xs) Fpath.pp unit.input_file);
211
+
let possibles =
212
+
List.find_map
213
+
(fun x ->
214
+
match x.input_copy with
215
+
| Some x ->
216
+
if
217
+
x |> Bos.OS.File.exists
218
+
|> Result.value ~default:false
219
+
then Some x
220
+
else None
221
+
| None -> None)
222
+
xs
223
+
in
224
+
match possibles with
225
+
| None ->
226
+
Logs.debug (fun m -> m "Not replacing input file");
227
+
unit
228
+
| Some x ->
229
+
Logs.debug (fun m ->
230
+
m "Replacing input_file of unit with %a" Fpath.pp x);
231
+
{ unit with input_file = x })))
232
+
units)
233
+
units
+98
driver/odoc_unit.mli
+98
driver/odoc_unit.mli
···
1
+
module Pkg_args : sig
2
+
type t
3
+
4
+
val compiled_pages : t -> (string * Fpath.t) list
5
+
val compiled_libs : t -> (string * Fpath.t) list
6
+
val includes : t -> Fpath.t list
7
+
val linked_pages : t -> (string * Fpath.t) list
8
+
val linked_libs : t -> (string * Fpath.t) list
9
+
10
+
val v :
11
+
odoc_dir:Fpath.t ->
12
+
odocl_dir:Fpath.t ->
13
+
includes:Fpath.t list ->
14
+
pages:(string * Fpath.t) list ->
15
+
libs:(string * Fpath.t) list ->
16
+
t
17
+
18
+
val combine : t -> t -> t
19
+
20
+
val pp : t Fmt.t
21
+
end
22
+
23
+
type sidebar = { output_file : Fpath.t; json : bool; pkg_dir : Fpath.t }
24
+
type index = {
25
+
roots : Fpath.t list;
26
+
output_file : Fpath.t;
27
+
json : bool;
28
+
search_dir : Fpath.t;
29
+
sidebar : sidebar option;
30
+
pkg_name : string;
31
+
(** The package this index belongs to, recorded in its sherlodoc database
32
+
so cross-package search can attribute and filter results. *)
33
+
}
34
+
35
+
type 'a t = {
36
+
parent_id : Odoc.Id.t;
37
+
input_file : Fpath.t;
38
+
input_copy : Fpath.t option;
39
+
(* Used to stash cmtis from virtual libraries into the odoc dir for voodoo mode *)
40
+
output_dir : Fpath.t;
41
+
odoc_file : Fpath.t;
42
+
odocl_file : Fpath.t;
43
+
pkg_args : Pkg_args.t;
44
+
pkgname : string option;
45
+
index : index option;
46
+
enable_warnings : bool;
47
+
to_output : bool;
48
+
kind : 'a;
49
+
}
50
+
51
+
type intf_extra = {
52
+
hidden : bool;
53
+
hash : string;
54
+
deps : (string * Digest.t) list;
55
+
}
56
+
and intf = [ `Intf of intf_extra ]
57
+
58
+
type impl_extra = { src_id : Odoc.Id.t; src_path : Fpath.t }
59
+
type impl = [ `Impl of impl_extra ]
60
+
61
+
type mld = [ `Mld ]
62
+
type md = [ `Md ]
63
+
type asset = [ `Asset ]
64
+
65
+
type any = [ impl | intf | mld | asset | md ] t
66
+
67
+
val pp : any Fmt.t
68
+
69
+
val pkg_dir : Packages.t -> Fpath.t
70
+
val lib_dir : Packages.t -> Packages.libty -> Fpath.t
71
+
val doc_dir : Packages.t -> Fpath.t
72
+
val src_dir : Packages.t -> Fpath.t
73
+
val src_lib_dir : Packages.t -> Packages.libty -> Fpath.t
74
+
75
+
type dirs = {
76
+
odoc_dir : Fpath.t;
77
+
odocl_dir : Fpath.t;
78
+
index_dir : Fpath.t;
79
+
mld_dir : Fpath.t;
80
+
}
81
+
82
+
val fix_virtual :
83
+
precompiled_units:intf t list Util.StringMap.t ->
84
+
units:intf t list Util.StringMap.t ->
85
+
intf t list Util.StringMap.t
86
+
(** [fix_virtual ~precompiled_units ~units] replaces the input file in units
87
+
representing implementations of virtual libraries. Implementation units have
88
+
a [cmt] but no [cmti], even though the interface is actually constrained by
89
+
a [mli]. The [cmi] file for the implementation is actually taken from the
90
+
virtual library, so this function replaces the [cmt] used for the interface
91
+
rendering of the implemenetation library units with the [cmti] taken from
92
+
the virtual library. [units] should contain all the units that might be
93
+
changed by this function. [precompiled_units] should be empty if this is
94
+
being called before any compilation has taken place - ie. in monorepo or
95
+
opam mode. In voodoo mode if the virtual library is in a different package
96
+
it will have already been compiled. and thus should not be changed. The
97
+
types of the inputs and outputs are hashtbls of units, where the hashtable
98
+
key is the interface hash. *)
+336
driver/odoc_units_of.ml
+336
driver/odoc_units_of.ml
···
1
+
open Odoc_unit
2
+
3
+
type indices_style =
4
+
| Voodoo
5
+
| Normal of { toplevel_content : string option }
6
+
| Automatic
7
+
8
+
let packages ~dirs ~extra_paths ~remap ~indices_style (pkgs : Packages.t list) :
9
+
any list =
10
+
let { odoc_dir; odocl_dir; index_dir; mld_dir = _ } = dirs in
11
+
12
+
let extra_libs_paths = extra_paths.Voodoo.libs in
13
+
let extra_libs_of_pkg = extra_paths.Voodoo.libs_of_pkg in
14
+
let extra_pkg_paths = extra_paths.Voodoo.pkgs in
15
+
16
+
let lib_dirs =
17
+
let open Packages in
18
+
let lds = extra_libs_paths in
19
+
List.fold_left
20
+
(fun lds pkg ->
21
+
List.fold_left
22
+
(fun lds lib ->
23
+
let lib_dir = lib_dir pkg lib in
24
+
let lds' = Util.StringMap.add lib.lib_name lib_dir lds in
25
+
lds')
26
+
lds pkg.libraries)
27
+
lds pkgs
28
+
in
29
+
let pkg_paths =
30
+
List.fold_left
31
+
(fun acc pkg -> Util.StringMap.add pkg.Packages.name (doc_dir pkg) acc)
32
+
extra_pkg_paths pkgs
33
+
in
34
+
35
+
let libs_of_pkg =
36
+
let libs_of_pkg pkg =
37
+
List.map (fun lib -> lib.Packages.lib_name) pkg.Packages.libraries
38
+
in
39
+
List.fold_left
40
+
(fun acc pkg ->
41
+
Util.StringMap.add pkg.Packages.name (libs_of_pkg pkg) acc)
42
+
extra_libs_of_pkg pkgs
43
+
in
44
+
45
+
let dash_p pkgname path = (pkgname, path) in
46
+
47
+
let dash_l lib_name =
48
+
match Util.StringMap.find_opt lib_name lib_dirs with
49
+
| Some dir -> [ (lib_name, dir) ]
50
+
| None ->
51
+
Logs.debug (fun m -> m "Library %s not found" lib_name);
52
+
[]
53
+
in
54
+
let base_args pkg lib_deps : Pkg_args.t =
55
+
let own_page = dash_p pkg.Packages.name (doc_dir pkg) in
56
+
let includes =
57
+
List.concat_map dash_l (Util.StringSet.to_list lib_deps) |> List.map snd
58
+
in
59
+
let libs =
60
+
List.fold_left
61
+
(fun acc lib -> Util.StringSet.add lib.Packages.lib_name acc)
62
+
lib_deps pkg.Packages.libraries
63
+
in
64
+
let libs = List.concat_map dash_l (Util.StringSet.to_list libs) in
65
+
Pkg_args.v ~pages:[ own_page ] ~libs ~includes ~odoc_dir ~odocl_dir
66
+
in
67
+
let args_of_config config : Pkg_args.t =
68
+
let { Global_config.deps = { packages; libraries } } = config in
69
+
let pages_rel =
70
+
List.filter_map
71
+
(fun pkgname ->
72
+
match Util.StringMap.find_opt pkgname pkg_paths with
73
+
| None ->
74
+
Logs.debug (fun m -> m "Package '%s' not found" pkgname);
75
+
None
76
+
| Some path -> Some (dash_p pkgname path))
77
+
packages
78
+
in
79
+
(* Add all liraries from added packages *)
80
+
let libraries_from_pkgs =
81
+
List.filter_map
82
+
(fun pkgname -> Util.StringMap.find_opt pkgname libs_of_pkg)
83
+
packages
84
+
in
85
+
let libraries = List.concat @@ (libraries :: libraries_from_pkgs) in
86
+
let libs_rel = List.concat_map dash_l libraries in
87
+
Pkg_args.v ~pages:pages_rel ~libs:libs_rel ~includes:[] ~odoc_dir ~odocl_dir
88
+
in
89
+
let args_of =
90
+
let cache = Hashtbl.create 10 in
91
+
fun pkg lib_deps : Pkg_args.t ->
92
+
match Hashtbl.find_opt cache (pkg, lib_deps) with
93
+
| Some res -> res
94
+
| None ->
95
+
let result =
96
+
Pkg_args.combine (base_args pkg lib_deps)
97
+
(args_of_config pkg.Packages.config)
98
+
in
99
+
Hashtbl.add cache (pkg, lib_deps) result;
100
+
result
101
+
in
102
+
103
+
let index_of pkg =
104
+
let roots = [ Fpath.( // ) odocl_dir (doc_dir pkg) ] in
105
+
let output_file = Fpath.(index_dir / pkg.name / Odoc.index_filename) in
106
+
let pkg_dir = doc_dir pkg in
107
+
let sidebar =
108
+
let output_file = Fpath.(index_dir / pkg.name / Odoc.sidebar_filename) in
109
+
{ output_file; json = false; pkg_dir }
110
+
in
111
+
{
112
+
roots;
113
+
output_file;
114
+
json = false;
115
+
search_dir = doc_dir pkg;
116
+
sidebar = Some sidebar;
117
+
pkg_name = pkg.name;
118
+
}
119
+
in
120
+
121
+
let make_unit ~name ~kind ~rel_dir ~input_file ~pkg ~lib_deps ~enable_warnings
122
+
~to_output ~stash_input : _ t =
123
+
let to_output = to_output || not remap in
124
+
(* If we haven't got active remapping, we output everything *)
125
+
let ( // ) = Fpath.( // ) in
126
+
let ( / ) = Fpath.( / ) in
127
+
let pkg_args = args_of pkg lib_deps in
128
+
let parent_id = rel_dir |> Odoc.Id.of_fpath in
129
+
let odoc_file =
130
+
odoc_dir // rel_dir / (String.uncapitalize_ascii name ^ ".odoc")
131
+
in
132
+
(* odoc will uncapitalise the output filename *)
133
+
let odocl_file =
134
+
odocl_dir // rel_dir / (String.uncapitalize_ascii name ^ ".odocl")
135
+
in
136
+
let input_copy =
137
+
if stash_input then
138
+
Some (odoc_dir // rel_dir / (String.uncapitalize_ascii name ^ ".cmti"))
139
+
else None
140
+
in
141
+
{
142
+
output_dir = odoc_dir;
143
+
pkgname = Some pkg.Packages.name;
144
+
pkg_args;
145
+
parent_id;
146
+
input_file;
147
+
input_copy;
148
+
odoc_file;
149
+
odocl_file;
150
+
kind;
151
+
to_output;
152
+
enable_warnings;
153
+
index = Some (index_of pkg);
154
+
}
155
+
in
156
+
157
+
let of_intf hidden pkg (lib : Packages.libty) lib_deps (intf : Packages.intf)
158
+
: intf t =
159
+
let rel_dir = lib_dir pkg lib in
160
+
let kind =
161
+
let deps = intf.mif_deps in
162
+
let kind = `Intf { hidden; hash = intf.mif_hash; deps } in
163
+
kind
164
+
in
165
+
let name = intf.mif_path |> Fpath.rem_ext |> Fpath.basename in
166
+
let stash_input = lib.archive_name = None in
167
+
make_unit ~name ~kind ~rel_dir ~input_file:intf.mif_path ~pkg ~lib_deps
168
+
~enable_warnings:pkg.selected ~to_output:pkg.selected ~stash_input
169
+
in
170
+
let of_impl pkg lib lib_deps (impl : Packages.impl) : impl t option =
171
+
match impl.mip_src_info with
172
+
| None -> None
173
+
| Some { src_path } ->
174
+
let rel_dir = lib_dir pkg lib in
175
+
let kind =
176
+
let src_name = Fpath.filename src_path in
177
+
let src_id =
178
+
Fpath.(src_lib_dir pkg lib / src_name) |> Odoc.Id.of_fpath
179
+
in
180
+
`Impl { src_id; src_path }
181
+
in
182
+
let name =
183
+
impl.mip_path |> Fpath.rem_ext |> Fpath.basename
184
+
|> String.uncapitalize_ascii |> ( ^ ) "impl-"
185
+
in
186
+
let unit =
187
+
make_unit ~name ~kind ~rel_dir ~input_file:impl.mip_path ~pkg
188
+
~lib_deps ~enable_warnings:false ~to_output:pkg.selected
189
+
~stash_input:false
190
+
in
191
+
Some unit
192
+
in
193
+
194
+
let of_module pkg (lib : Packages.libty) lib_deps (m : Packages.modulety) :
195
+
any list =
196
+
let i :> any = of_intf m.m_hidden pkg lib lib_deps m.m_intf in
197
+
let m :> any list =
198
+
Option.bind m.m_impl (of_impl pkg lib lib_deps) |> Option.to_list
199
+
in
200
+
i :: m
201
+
in
202
+
let of_lib pkg (lib : Packages.libty) =
203
+
let lib_deps = Util.StringSet.add lib.lib_name lib.lib_deps in
204
+
let index = index_of pkg in
205
+
let units = List.concat_map (of_module pkg lib lib_deps) lib.modules in
206
+
if remap && not pkg.selected then units
207
+
else
208
+
let landing_page :> any = Landing_pages.library ~dirs ~pkg ~index lib in
209
+
landing_page :: units
210
+
in
211
+
let of_mld pkg (mld : Packages.mld) : mld t list =
212
+
let open Fpath in
213
+
let { Packages.mld_path; mld_rel_path } = mld in
214
+
let rel_dir = doc_dir pkg // Fpath.parent mld_rel_path |> Fpath.normalize in
215
+
let kind = `Mld in
216
+
let name = mld_path |> Fpath.rem_ext |> Fpath.basename |> ( ^ ) "page-" in
217
+
let lib_deps =
218
+
pkg.libraries
219
+
|> List.map (fun lib -> lib.Packages.lib_name)
220
+
|> Util.StringSet.of_list
221
+
in
222
+
let unit =
223
+
make_unit ~name ~kind ~rel_dir ~input_file:mld_path ~pkg ~lib_deps
224
+
~enable_warnings:pkg.selected ~to_output:pkg.selected ~stash_input:false
225
+
in
226
+
[ unit ]
227
+
in
228
+
let of_md pkg (md : Packages.md) : md t list =
229
+
let ext = Fpath.get_ext md.md_path in
230
+
match ext with
231
+
| ".md" ->
232
+
let open Fpath in
233
+
let { Packages.md_path; md_rel_path } = md in
234
+
let rel_dir =
235
+
doc_dir pkg // Fpath.parent md_rel_path |> Fpath.normalize
236
+
in
237
+
let kind = `Md in
238
+
let name =
239
+
md_path |> Fpath.rem_ext |> Fpath.basename |> ( ^ ) "page-"
240
+
in
241
+
let lib_deps = Util.StringSet.empty in
242
+
let unit =
243
+
make_unit ~name ~kind ~rel_dir ~input_file:md_path ~pkg ~lib_deps
244
+
~enable_warnings:pkg.selected ~to_output:pkg.selected
245
+
~stash_input:false
246
+
in
247
+
[ unit ]
248
+
| _ ->
249
+
Logs.debug (fun m ->
250
+
m "Skipping non-markdown doc file %a" Fpath.pp md.md_path);
251
+
[]
252
+
in
253
+
let of_asset pkg (asset : Packages.asset) : asset t list =
254
+
let open Fpath in
255
+
let { Packages.asset_path; asset_rel_path } = asset in
256
+
let rel_dir =
257
+
doc_dir pkg // Fpath.parent asset_rel_path |> Fpath.normalize
258
+
in
259
+
let kind = `Asset in
260
+
let unit =
261
+
let name = asset_path |> Fpath.basename |> ( ^ ) "asset-" in
262
+
make_unit ~name ~kind ~rel_dir ~input_file:asset_path ~pkg
263
+
~lib_deps:Util.StringSet.empty ~enable_warnings:false ~to_output:true
264
+
~stash_input:false
265
+
in
266
+
[ unit ]
267
+
in
268
+
269
+
let of_package (pkg : Packages.t) : any list =
270
+
let lib_units :> any list list = List.map (of_lib pkg) pkg.libraries in
271
+
let mld_units :> any list list = List.map (of_mld pkg) pkg.mlds in
272
+
let asset_units :> any list list = List.map (of_asset pkg) pkg.assets in
273
+
let md_units :> any list list = List.map (of_md pkg) pkg.other_docs in
274
+
let pkg_index () :> any list =
275
+
let has_index_page =
276
+
List.exists
277
+
(fun mld ->
278
+
Fpath.equal
279
+
(Fpath.normalize mld.Packages.mld_rel_path)
280
+
(Fpath.normalize (Fpath.v "./index.mld")))
281
+
pkg.mlds
282
+
in
283
+
if has_index_page || (remap && not pkg.selected) then []
284
+
else
285
+
let index = index_of pkg in
286
+
[ Landing_pages.package ~dirs ~pkg ~index ]
287
+
in
288
+
let src_index () :> any list =
289
+
if remap && not pkg.selected then []
290
+
else if
291
+
(* Some library has a module which has an implementation which has a source *)
292
+
List.exists
293
+
(fun lib ->
294
+
List.exists
295
+
(fun m ->
296
+
match m.Packages.m_impl with
297
+
| Some { mip_src_info = Some _; _ } -> true
298
+
| _ -> false)
299
+
lib.Packages.modules)
300
+
pkg.libraries
301
+
then
302
+
let index = index_of pkg in
303
+
[ Landing_pages.src ~dirs ~pkg ~index ]
304
+
else []
305
+
in
306
+
let std_units = mld_units @ asset_units @ md_units @ lib_units in
307
+
match indices_style with
308
+
| Automatic when pkg.name = Monorepo_style.monorepo_pkg_name ->
309
+
let others :> any list =
310
+
Landing_pages.make_custom dirs index_of
311
+
(List.find
312
+
(fun p -> p.Packages.name = Monorepo_style.monorepo_pkg_name)
313
+
pkgs)
314
+
in
315
+
others @ List.concat std_units
316
+
| Normal _ | Voodoo | Automatic ->
317
+
List.concat (pkg_index () :: src_index () :: std_units)
318
+
in
319
+
match indices_style with
320
+
| Normal { toplevel_content = None } ->
321
+
let gen_indices :> any = Landing_pages.package_list ~dirs ~remap pkgs in
322
+
gen_indices :: List.concat_map of_package pkgs
323
+
| Normal { toplevel_content = Some content } ->
324
+
let content ppf = Format.fprintf ppf "%s" content in
325
+
let libs =
326
+
List.concat_map
327
+
(fun pkg -> List.map (fun lib -> (pkg, lib)) pkg.Packages.libraries)
328
+
pkgs
329
+
in
330
+
let index :> any =
331
+
Landing_pages.make_index ~dirs
332
+
~rel_dir:Fpath.(v "./")
333
+
~libs ~pkgs ~enable_warnings:true ~content ~index:None
334
+
in
335
+
index :: List.concat_map of_package pkgs
336
+
| Voodoo | Automatic -> List.concat_map of_package pkgs
+14
driver/odoc_units_of.mli
+14
driver/odoc_units_of.mli
···
1
+
open Odoc_unit
2
+
3
+
type indices_style =
4
+
| Voodoo
5
+
| Normal of { toplevel_content : string option }
6
+
| Automatic
7
+
8
+
val packages :
9
+
dirs:dirs ->
10
+
extra_paths:Voodoo.extra_paths ->
11
+
remap:bool ->
12
+
indices_style:indices_style ->
13
+
Packages.t list ->
14
+
any list
+350
driver/opam.ml
+350
driver/opam.ml
···
1
+
open Bos
2
+
3
+
let opam = Cmd.v "opam"
4
+
5
+
type package = { name : string; version : string }
6
+
7
+
let pp fmt p = Format.fprintf fmt "%s.%s" p.name p.version
8
+
9
+
let memoize f =
10
+
let r = ref None in
11
+
fun () ->
12
+
match !r with
13
+
| Some x -> x
14
+
| None ->
15
+
let x = f () in
16
+
r := Some x;
17
+
x
18
+
19
+
let get_switch =
20
+
memoize @@ fun () ->
21
+
Util.lines_of_process Cmd.(opam % "switch" % "show") |> List.hd
22
+
23
+
let prefix =
24
+
memoize @@ fun () ->
25
+
Util.lines_of_process
26
+
Cmd.(opam % "var" % "--switch" % get_switch () % "prefix")
27
+
|> List.hd
28
+
29
+
let all_opam_packages =
30
+
memoize @@ fun () ->
31
+
let prefix = prefix () in
32
+
match Bos.OS.Dir.contents Fpath.(v prefix / ".opam-switch" / "packages") with
33
+
| Error (`Msg msg) ->
34
+
Logs.err (fun m -> m "Error listing opam packages: %s" msg);
35
+
[]
36
+
| Ok contents ->
37
+
List.filter_map
38
+
(fun p ->
39
+
let name = Fpath.basename p in
40
+
match Astring.String.cut ~sep:"." name with
41
+
| Some (name, version) -> Some { name; version }
42
+
| None -> None)
43
+
contents
44
+
45
+
let pkg_contents { name; _ } =
46
+
let prefix = Fpath.v (prefix ()) in
47
+
let changes_file =
48
+
Format.asprintf "%a/.opam-switch/install/%s.changes" Fpath.pp prefix name
49
+
in
50
+
let file = OpamFilename.raw changes_file in
51
+
let filename =
52
+
OpamFile.make @@ OpamFilename.raw @@ Filename.basename changes_file
53
+
in
54
+
let changed =
55
+
try
56
+
OpamFilename.with_contents
57
+
(fun str ->
58
+
OpamFile.Changes.read_from_string ~filename
59
+
@@
60
+
(* Field [opam-version] is invalid in [*.changes] files, displaying a warning. *)
61
+
if String.starts_with ~prefix:"opam-version" str then
62
+
match OpamStd.String.cut_at str '\n' with
63
+
| Some (_, str) -> str
64
+
| None -> assert false
65
+
else str)
66
+
file
67
+
with
68
+
| OpamSystem.File_not_found s ->
69
+
Logs.err (fun m ->
70
+
m "File not found: %s.\n%s\nConsidering it empty." changes_file s);
71
+
OpamStd.String.Map.empty
72
+
| OpamPp.Bad_version _ ->
73
+
Logs.err (fun m ->
74
+
m "Bad version while parsing %s.\nConsidering it empty."
75
+
changes_file);
76
+
OpamStd.String.Map.empty
77
+
| OpamPp.Bad_format _ ->
78
+
Logs.err (fun m ->
79
+
m "Bad format while parsing %s.\nConsidering it empty." changes_file);
80
+
OpamStd.String.Map.empty
81
+
in
82
+
let added =
83
+
OpamStd.String.Map.fold
84
+
(fun file x acc ->
85
+
match x with
86
+
| OpamDirTrack.Added _ -> (
87
+
try
88
+
if not @@ Sys.is_directory Fpath.(to_string (prefix // v file))
89
+
then file :: acc
90
+
else acc
91
+
with _ ->
92
+
acc
93
+
(* dose (and maybe others) sometimes creates a symlink to something that doesn't exist *)
94
+
)
95
+
| _ -> acc)
96
+
changed []
97
+
in
98
+
List.map Fpath.v added
99
+
100
+
let deps pkgs =
101
+
let cmd =
102
+
Cmd.(
103
+
opam % "list" % "--recursive" % "-i" % "--columns" % "package" % "--color"
104
+
% "never" % "-s" % "--or")
105
+
in
106
+
let cmd =
107
+
List.fold_left (fun cmd pkg -> Cmd.(cmd % "--required-by" % pkg)) cmd pkgs
108
+
in
109
+
let out = Util.lines_of_process cmd in
110
+
List.filter_map
111
+
(fun x ->
112
+
match Astring.String.cut ~sep:"." x with
113
+
| Some (name, version) -> Some { name; version }
114
+
| None -> None)
115
+
out
116
+
117
+
type doc_file = {
118
+
kind : [ `Mld | `Asset | `Other ];
119
+
file : Fpath.t;
120
+
rel_path : Fpath.t;
121
+
}
122
+
123
+
let pp_doc_file fmt { kind; file; rel_path } =
124
+
Format.fprintf fmt "kind: %a@,file: %a@,rel_path: %a@,"
125
+
(Fmt.of_to_string (function
126
+
| `Mld -> "`Mld"
127
+
| `Asset -> "`Asset"
128
+
| `Other -> "`Other"))
129
+
kind Fpath.pp file Fpath.pp rel_path
130
+
131
+
type installed_files = {
132
+
libs : Fpath.set;
133
+
docs : doc_file list;
134
+
odoc_config : Fpath.t option;
135
+
}
136
+
137
+
type package_of_fpath = package Fpath.map
138
+
139
+
(* Here we use an associative list *)
140
+
type fpaths_of_package = (package * installed_files) list
141
+
142
+
let pp_fpath_set fmt set =
143
+
Fpath.Set.iter (Format.fprintf fmt "%a@." Fpath.pp) set
144
+
145
+
let pp_fpaths_of_package fmt l =
146
+
List.iter
147
+
(fun (p, { libs; docs; odoc_config }) ->
148
+
Format.fprintf fmt "%a:@,libs: %a@,docs: %a@,odoc_config: %a@," pp p
149
+
pp_fpath_set libs
150
+
Fmt.Dump.(list pp_doc_file)
151
+
docs (Fmt.option Fpath.pp) odoc_config)
152
+
l
153
+
154
+
let classify_docs prefix only_package contents =
155
+
let pkg_match pkg =
156
+
match only_package with None -> true | Some p -> p = pkg
157
+
in
158
+
159
+
let is_dir f =
160
+
try Sys.is_directory (Fpath.to_string f) with Sys_error _ -> false
161
+
in
162
+
163
+
List.fold_left
164
+
(fun acc fpath ->
165
+
match Fpath.segs fpath with
166
+
| "doc" :: pkg :: "odoc-pages" :: _ :: _
167
+
when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
168
+
Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
169
+
let kind =
170
+
match Fpath.get_ext fpath with ".mld" -> `Mld | _ -> `Asset
171
+
in
172
+
let rel_path =
173
+
Fpath.rem_prefix Fpath.(v "doc" / pkg / "odoc-pages") fpath
174
+
|> Option.get
175
+
in
176
+
{ kind; file = Fpath.(prefix // fpath); rel_path } :: acc
177
+
| "doc" :: pkg :: "odoc-assets" :: _ :: _
178
+
when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
179
+
Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
180
+
let rel_path =
181
+
Fpath.rem_prefix Fpath.(v "doc" / pkg / "odoc-assets") fpath
182
+
|> Option.get
183
+
in
184
+
let rel_path = Fpath.(v "_assets" // rel_path) in
185
+
{ kind = `Asset; file = Fpath.(prefix // fpath); rel_path } :: acc
186
+
| [ "doc"; pkg; _ ]
187
+
when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
188
+
Logs.debug (fun m -> m "Found other doc: %a" Fpath.pp fpath);
189
+
let rel_path = Fpath.base fpath in
190
+
{ kind = `Other; file = Fpath.(prefix // fpath); rel_path } :: acc
191
+
| _ -> acc)
192
+
[] contents
193
+
194
+
let classify_libs prefix only_package contents =
195
+
let pkg_match pkg =
196
+
match only_package with None -> true | Some p -> p = pkg
197
+
in
198
+
199
+
let libs =
200
+
List.fold_left
201
+
(fun set fpath ->
202
+
match Fpath.segs fpath with
203
+
| "lib" :: "stublibs" :: _ -> set
204
+
| "lib" :: pkg :: _ :: _
205
+
when Fpath.has_ext ".cmi" fpath && pkg_match pkg ->
206
+
Fpath.Set.add Fpath.(prefix // fpath |> split_base |> fst) set
207
+
| _ -> set)
208
+
Fpath.Set.empty contents
209
+
in
210
+
libs
211
+
212
+
let find_odoc_config prefix only_package contents =
213
+
let pkg_match pkg =
214
+
match only_package with None -> true | Some p -> p = pkg
215
+
in
216
+
217
+
let opt =
218
+
List.find_opt
219
+
(fun fpath ->
220
+
match Fpath.segs fpath with
221
+
| [ "doc"; pkg; "odoc-config.sexp" ] -> pkg_match pkg
222
+
| _ -> false)
223
+
contents
224
+
in
225
+
226
+
Option.map (fun p -> Fpath.(prefix // p)) opt
227
+
228
+
let dune_overrides () =
229
+
let ocamlpath = Sys.getenv_opt "OCAMLPATH" in
230
+
match ocamlpath with
231
+
| None -> []
232
+
| Some path -> (
233
+
(* OCAMLPATH is set in dune to be e.g. /Users/jon/odoc/_build/install/default/lib *)
234
+
(* Let's strip the 'lib' off and we can find the installed files *)
235
+
let path = Fpath.v path in
236
+
match Fpath.segs path |> List.rev with
237
+
| "lib" :: _ :: "install" :: "_build" :: _ -> (
238
+
(* Check it's of the right form *)
239
+
let base = Fpath.split_base path |> fst in
240
+
let contents =
241
+
Bos.OS.Dir.fold_contents
242
+
(fun x acc ->
243
+
match Fpath.relativize ~root:base x with
244
+
| None -> acc
245
+
| Some r -> r :: acc)
246
+
[] base
247
+
in
248
+
match contents with
249
+
| Ok contents ->
250
+
Logs.debug (fun m ->
251
+
m "dune install contents: %a"
252
+
Fmt.(Dump.list Fpath.pp)
253
+
contents);
254
+
let packages =
255
+
List.fold_left
256
+
(fun acc fpath ->
257
+
match Fpath.segs fpath with
258
+
| "lib" :: pkg :: _ :: _ -> Util.StringSet.add pkg acc
259
+
| "doc" :: pkg :: _ :: _ -> Util.StringSet.add pkg acc
260
+
| _ -> acc)
261
+
Util.StringSet.empty contents
262
+
in
263
+
264
+
Logs.debug (fun m ->
265
+
m "Found packages: %a"
266
+
Fmt.(Dump.list string)
267
+
(Util.StringSet.elements packages));
268
+
Util.StringSet.fold
269
+
(fun pkg acc ->
270
+
let libs = classify_libs base (Some pkg) contents in
271
+
let docs = classify_docs base (Some pkg) contents in
272
+
let odoc_config = find_odoc_config base (Some pkg) contents in
273
+
Logs.debug (fun m ->
274
+
m "pkg %s Found %d docs" pkg (List.length docs));
275
+
({ name = pkg; version = "dev" }, { libs; docs; odoc_config })
276
+
:: acc)
277
+
packages []
278
+
| Error (`Msg msg) ->
279
+
Logs.err (fun m ->
280
+
m "Error listing dune install directory: %s" msg);
281
+
[])
282
+
| _ -> [])
283
+
284
+
let check pkgs =
285
+
let cmd =
286
+
Cmd.(
287
+
opam % "list" % "-i" % "--columns" % "package" % "--color" % "never"
288
+
% "-s")
289
+
in
290
+
let cmd = List.fold_left Cmd.( % ) cmd pkgs in
291
+
let out = Util.lines_of_process cmd in
292
+
let res =
293
+
List.filter_map
294
+
(fun x ->
295
+
match Astring.String.cut ~sep:"." x with
296
+
| Some (name, _version) -> Some name
297
+
| None -> None)
298
+
out
299
+
in
300
+
let missing = Util.StringSet.(diff (of_list pkgs) (of_list res)) in
301
+
let dune_pkgnames =
302
+
Util.StringSet.of_list (List.map (fun (p, _) -> p.name) (dune_overrides ()))
303
+
in
304
+
let missing = Util.StringSet.diff missing dune_pkgnames in
305
+
if Util.StringSet.cardinal missing = 0 then Ok () else Error missing
306
+
307
+
let pkg_to_dir_map () =
308
+
let dune_overrides = dune_overrides () in
309
+
let pkgs = all_opam_packages () in
310
+
let prefix = prefix () in
311
+
let pkg_content =
312
+
List.map
313
+
(fun p ->
314
+
let contents = pkg_contents p in
315
+
let libs = classify_libs (Fpath.v prefix) None contents in
316
+
let docs = classify_docs (Fpath.v prefix) None contents in
317
+
let odoc_config = find_odoc_config (Fpath.v prefix) None contents in
318
+
(p, { libs; docs; odoc_config }))
319
+
pkgs
320
+
in
321
+
322
+
(* Remove anything from opam that is present in the dune overrides *)
323
+
let pkg_content =
324
+
List.filter
325
+
(fun (p, _) ->
326
+
not @@ List.exists (fun (p', _) -> p.name = p'.name) dune_overrides)
327
+
pkg_content
328
+
in
329
+
330
+
let pkg_content = pkg_content @ dune_overrides in
331
+
332
+
let map =
333
+
List.fold_left
334
+
(fun map (p, { libs; _ }) ->
335
+
Fpath.Set.fold
336
+
(fun dir map ->
337
+
Fpath.Map.update dir
338
+
(function
339
+
| None -> Some p
340
+
| Some x ->
341
+
Logs.debug (fun m ->
342
+
m "Multiple packages (%a,%a) found for dir %a" pp x pp p
343
+
Fpath.pp dir);
344
+
Some p)
345
+
map)
346
+
libs map)
347
+
Fpath.Map.empty pkg_content
348
+
in
349
+
Logs.debug (fun m -> m "pkg_to_dir_map: %a" pp_fpaths_of_package pkg_content);
350
+
(pkg_content, map)
+32
driver/opam.mli
+32
driver/opam.mli
···
1
+
type package = { name : string; version : string }
2
+
3
+
type doc_file = {
4
+
kind : [ `Mld | `Asset | `Other ];
5
+
file : Fpath.t;
6
+
rel_path : Fpath.t;
7
+
}
8
+
9
+
type installed_files = {
10
+
libs : Fpath.set;
11
+
docs : doc_file list;
12
+
odoc_config : Fpath.t option;
13
+
}
14
+
15
+
type package_of_fpath = package Fpath.map
16
+
17
+
(* Here we use an associative list *)
18
+
type fpaths_of_package = (package * installed_files) list
19
+
val all_opam_packages : unit -> package list
20
+
21
+
val pkg_contents : package -> Fpath.t list
22
+
(** [pkg_contents pkg] returns the files installed by [pkg], relative to the
23
+
switch prefix, as recorded in opam's [<prefix>/.opam-switch/install/<pkg>.changes]
24
+
file. Directories are not included. *)
25
+
26
+
val classify_docs : Fpath.t -> string option -> Fpath.t list -> doc_file list
27
+
28
+
val check : string list -> (unit, Util.StringSet.t) Result.t
29
+
val deps : string list -> package list
30
+
val pkg_to_dir_map : unit -> fpaths_of_package * package_of_fpath
31
+
val pp : Format.formatter -> package -> unit
32
+
val prefix : unit -> string
+604
driver/packages.ml
+604
driver/packages.ml
···
1
+
(* Packages *)
2
+
3
+
type dep = string * Digest.t
4
+
5
+
(* type id = Odoc.id *)
6
+
7
+
type intf = { mif_hash : string; mif_path : Fpath.t; mif_deps : dep list }
8
+
9
+
let 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
+
15
+
type src_info = { src_path : Fpath.t }
16
+
17
+
let pp_src_info fmt i =
18
+
Format.fprintf fmt "@[<hov>{@,src_path: %a@,}@]" Fpath.pp i.src_path
19
+
20
+
type impl = {
21
+
mip_path : Fpath.t;
22
+
mip_src_info : src_info option;
23
+
mip_deps : dep list;
24
+
}
25
+
26
+
let 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
+
35
+
type modulety = {
36
+
m_name : string;
37
+
m_intf : intf;
38
+
m_impl : impl option;
39
+
m_hidden : bool;
40
+
}
41
+
42
+
let 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
+
47
+
type mld = { mld_path : Fpath.t; mld_rel_path : Fpath.t }
48
+
49
+
type md = { md_path : Fpath.t; md_rel_path : Fpath.t }
50
+
51
+
let 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
+
55
+
let 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
+
59
+
type asset = { asset_path : Fpath.t; asset_rel_path : Fpath.t }
60
+
61
+
let 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
+
65
+
type 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
+
74
+
let 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
+
94
+
type 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
+
108
+
let 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
+
124
+
let maybe_prepend_top top_dir dir =
125
+
match top_dir with None -> dir | Some d -> Fpath.(d // dir)
126
+
127
+
let pkg_dir top_dir pkg_name = maybe_prepend_top top_dir Fpath.(v pkg_name)
128
+
129
+
module 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
204
+
end
205
+
206
+
module 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
285
+
end
286
+
287
+
(* Construct the list of mlds and assets from a package name and its list of pages *)
288
+
let 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
+
306
+
let 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
+
367
+
let 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
+
442
+
let 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
+
547
+
let 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
+
582
+
let 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
+101
driver/packages.mli
+101
driver/packages.mli
···
1
+
(** {1 OCaml compilation unit} *)
2
+
3
+
(** {2 Interface part} *)
4
+
5
+
type dep = string * Digest.t
6
+
7
+
type intf = { mif_hash : string; mif_path : Fpath.t; mif_deps : dep list }
8
+
9
+
val pp_intf : Format.formatter -> intf -> unit
10
+
11
+
(** {2 Implementation part} *)
12
+
13
+
type src_info = { src_path : Fpath.t }
14
+
15
+
type impl = {
16
+
mip_path : Fpath.t;
17
+
mip_src_info : src_info option;
18
+
mip_deps : dep list;
19
+
}
20
+
21
+
val pp_impl : Format.formatter -> impl -> unit
22
+
23
+
(** {2 OCaml Compilation unit} *)
24
+
25
+
type modulety = {
26
+
m_name : string;
27
+
m_intf : intf;
28
+
m_impl : impl option;
29
+
m_hidden : bool;
30
+
}
31
+
32
+
(** {1 Standalone pages units} *)
33
+
34
+
type mld = { mld_path : Fpath.t; mld_rel_path : Fpath.t }
35
+
36
+
type md = { md_path : Fpath.t; md_rel_path : Fpath.t }
37
+
38
+
val pp_mld : Format.formatter -> mld -> unit
39
+
40
+
val pp_md : Format.formatter -> md -> unit
41
+
42
+
(** {1 Asset units} *)
43
+
44
+
type asset = { asset_path : Fpath.t; asset_rel_path : Fpath.t }
45
+
46
+
val pp_asset : Format.formatter -> asset -> unit
47
+
48
+
(** {1 Packages} *)
49
+
50
+
(** Compilation units are associated to libraries, while documentation are
51
+
associated to package *)
52
+
53
+
type libty = {
54
+
lib_name : string;
55
+
dir : Fpath.t;
56
+
archive_name : string option;
57
+
lib_deps : Util.StringSet.t;
58
+
modules : modulety list;
59
+
id_override : string option;
60
+
}
61
+
62
+
module Lib : sig
63
+
val v :
64
+
libname_of_archive:string Fpath.Map.t ->
65
+
pkg_name:string ->
66
+
dir:Fpath.t ->
67
+
cmtidir:Fpath.t option ->
68
+
all_lib_deps:Util.StringSet.t Util.StringMap.t ->
69
+
cmi_only_libs:(Fpath.t * string) list ->
70
+
id_override:string option ->
71
+
libty list
72
+
73
+
val pp : Format.formatter -> libty -> unit
74
+
end
75
+
76
+
type t = {
77
+
name : string;
78
+
version : string;
79
+
libraries : libty list;
80
+
mlds : mld list;
81
+
assets : asset list;
82
+
selected : bool;
83
+
remaps : (string * string) list;
84
+
other_docs : md list;
85
+
pkg_dir : Fpath.t;
86
+
doc_dir : Fpath.t;
87
+
config : Global_config.t;
88
+
}
89
+
90
+
val pp : Format.formatter -> t -> unit
91
+
92
+
val fix_missing_deps : t list -> t list
93
+
94
+
val mk_mlds : Opam.doc_file list -> mld list * asset list * md list
95
+
96
+
val of_libs : packages_dir:Fpath.t option -> Util.StringSet.t -> t list
97
+
(** Turns a set of libraries into a map from package name to package *)
98
+
99
+
val of_packages : packages_dir:Fpath.t option -> string list -> t list
100
+
101
+
val remap_virtual : t list -> t list
+117
driver/run.ml
+117
driver/run.ml
···
1
+
let instrument = false
2
+
3
+
open Bos
4
+
5
+
let instrument_dir =
6
+
lazy
7
+
(let dir = Fpath.v "landmarks" in
8
+
OS.Dir.delete dir |> Result.get_ok;
9
+
OS.Dir.create dir |> Result.get_ok |> ignore;
10
+
dir)
11
+
12
+
type t = {
13
+
cmd : string list;
14
+
time : float; (** Running time in seconds. *)
15
+
output_file : Fpath.t option;
16
+
output : string;
17
+
errors : string;
18
+
status : [ `Exited of int | `Signaled of int ];
19
+
}
20
+
21
+
(* Environment variables passed to commands. *)
22
+
23
+
(* Record the commands executed, their running time and optionally the path to
24
+
the produced file. *)
25
+
let commands = ref []
26
+
27
+
let n = Atomic.make 0
28
+
29
+
(** Return the list of executed commands where the first argument was [cmd]. *)
30
+
let run env cmd output_file =
31
+
let cmd = Bos.Cmd.to_list cmd in
32
+
let myn = Atomic.fetch_and_add n 1 in
33
+
Logs.debug (fun m -> m "%d - Executing: %s" myn (String.concat " " cmd));
34
+
let proc_mgr = Eio.Stdenv.process_mgr env in
35
+
let t_start = Unix.gettimeofday () in
36
+
let env =
37
+
let env = OS.Env.current () |> Result.get_ok in
38
+
env
39
+
in
40
+
let env =
41
+
Astring.String.Map.fold
42
+
(fun k v env -> Astring.String.concat [ k; "="; v ] :: env)
43
+
env []
44
+
|> Array.of_list
45
+
in
46
+
(* Logs.debug (fun m -> m "Running cmd %a" Fmt.(list ~sep:sp string) cmd); *)
47
+
let output, errors, status =
48
+
Eio.Switch.run ~name:"Process.parse_out" @@ fun sw ->
49
+
let r, w = Eio.Process.pipe proc_mgr ~sw in
50
+
let re, we = Eio.Process.pipe proc_mgr ~sw in
51
+
try
52
+
let child =
53
+
Eio.Process.spawn ~sw proc_mgr ~stdout:w ~stderr:we ~env cmd
54
+
in
55
+
Eio.Flow.close w;
56
+
Eio.Flow.close we;
57
+
let output, err =
58
+
Eio.Fiber.pair
59
+
(fun () ->
60
+
Eio.Buf_read.parse_exn Eio.Buf_read.take_all r ~max_size:max_int)
61
+
(fun () ->
62
+
Eio.Buf_read.parse_exn Eio.Buf_read.take_all re ~max_size:max_int)
63
+
in
64
+
Eio.Flow.close r;
65
+
Eio.Flow.close re;
66
+
let status = Eio.Process.await child in
67
+
(output, err, status)
68
+
with Eio.Exn.Io _ as ex ->
69
+
let bt = Printexc.get_raw_backtrace () in
70
+
Eio.Exn.reraise_with_context ex bt "%d - running command: %a" myn
71
+
Eio.Process.pp_args cmd
72
+
in
73
+
(* Logs.debug (fun m ->
74
+
m "Finished running cmd %a" Fmt.(list ~sep:sp string) cmd); *)
75
+
let t_end = Unix.gettimeofday () in
76
+
let time = t_end -. t_start in
77
+
let result = { cmd; time; output_file; output; errors; status } in
78
+
commands := result :: !commands;
79
+
(match result.status with
80
+
| `Exited 0 -> ()
81
+
| _ ->
82
+
let verb, n =
83
+
match result.status with
84
+
| `Exited n -> ("exited", n)
85
+
| `Signaled n -> ("signaled", n)
86
+
in
87
+
Logs.err (fun m ->
88
+
m
89
+
"@[<2>Process %s with %d:@ '@[%a'@]@]@\n\n\
90
+
Stdout:\n\
91
+
%s\n\n\
92
+
Stderr:\n\
93
+
%s"
94
+
verb n
95
+
Fmt.(list ~sep:sp string)
96
+
result.cmd result.output result.errors));
97
+
result
98
+
99
+
(** Print an executed command and its time. *)
100
+
101
+
let filter_commands cmd =
102
+
match
103
+
List.filter
104
+
(fun c -> match c.cmd with _ :: cmd' :: _ -> cmd = cmd' | _ -> false)
105
+
!commands
106
+
with
107
+
| [] -> []
108
+
| _ :: _ as cmds -> cmds
109
+
110
+
let print_cmd c =
111
+
Printf.printf "[%4.2f] $ %s\n" c.time (String.concat " " c.cmd)
112
+
113
+
(** Returns the [k] commands that took the most time for a given subcommand. *)
114
+
let k_longest_commands cmd k =
115
+
filter_commands cmd
116
+
|> List.sort (fun a b -> Float.compare b.time a.time)
117
+
|> List.filteri (fun i _ -> i < k)
+69
driver/sherlodoc.ml
+69
driver/sherlodoc.ml
···
1
+
open Bos
2
+
open Cmd_outputs
3
+
4
+
let sherlodoc = Cmd.v "sherlodoc"
5
+
6
+
(* All paths relative to the html output dir *)
7
+
8
+
(* Per-package sherlodoc db for javascript search*)
9
+
let db_js_file pkg_dir = Fpath.(pkg_dir / "sherlodoc_db.js")
10
+
11
+
(* Per-package sherlodoc marshal file for server-side search *)
12
+
let db_marshal_file pkg_dir = Fpath.(pkg_dir / "sherlodoc_db.marshal")
13
+
14
+
(* Global static sherlodoc support file for javascript search *)
15
+
let js_file = Fpath.v "sherlodoc.js"
16
+
17
+
let index ?(ignore_output = false) ~format ~inputs ~dst ?favored_prefixes ?pkg ()
18
+
=
19
+
let desc = Printf.sprintf "Sherlodoc indexing at %s" (Fpath.to_string dst) in
20
+
let format =
21
+
Cmd.(v "--format" % match format with `marshal -> "marshal" | `js -> "js")
22
+
in
23
+
let favored_prefixes =
24
+
match favored_prefixes with
25
+
| None -> Cmd.empty
26
+
| Some favored_prefixes ->
27
+
Cmd.(v "--favoured_prefixes" % String.concat "," favored_prefixes)
28
+
in
29
+
let log =
30
+
if ignore_output then None else Some (`Sherlodoc, Fpath.to_string dst)
31
+
in
32
+
let run extra_args =
33
+
let cmd =
34
+
Cmd.(
35
+
sherlodoc % "index" %% format %% favored_prefixes %% extra_args % "-o"
36
+
% p dst)
37
+
in
38
+
ignore @@ submit_ignore_failures log desc cmd (Some dst)
39
+
in
40
+
match pkg with
41
+
| None -> run Cmd.(inputs |> List.map p |> of_list)
42
+
| Some name ->
43
+
(* sherlodoc records the owning package from tab-separated lines
44
+
([name<TAB>file]) read via [--file-list]; positional ODOCL_FILE
45
+
arguments are validated as plain paths and cannot carry it. Without a
46
+
package, entries carry none and cross-package search can neither
47
+
attribute nor filter results. *)
48
+
Bos.OS.File.with_tmp_oc "sherlodoc-filelist-%s.txt"
49
+
(fun file_list oc () ->
50
+
List.iter
51
+
(fun i -> Printf.fprintf oc "%s\t%s\n" name (Cmd.p i))
52
+
inputs;
53
+
flush oc;
54
+
run Cmd.(v "--file-list" % p file_list))
55
+
()
56
+
|> function
57
+
| Ok () -> ()
58
+
| Error (`Msg m) ->
59
+
Logs.err (fun f -> f "Sherlodoc indexing at %a: %s" Fpath.pp dst m)
60
+
61
+
let js dst =
62
+
let cmd = Cmd.(sherlodoc % "js" % p dst) in
63
+
let desc = Printf.sprintf "Sherlodoc js at %s" (Fpath.to_string dst) in
64
+
let _lines =
65
+
submit_ignore_failures
66
+
(Some (`Sherlodoc, Fpath.to_string dst))
67
+
desc cmd (Some dst)
68
+
in
69
+
()
+327
driver/stats.ml
+327
driver/stats.ml
···
1
+
(* Stats *)
2
+
3
+
(** Returns the [k] commands that took the most time for a given subcommand. *)
4
+
5
+
type stats = {
6
+
mutable total_units : int Atomic.t;
7
+
mutable total_impls : int Atomic.t;
8
+
mutable total_mlds : int Atomic.t;
9
+
mutable total_assets : int Atomic.t;
10
+
mutable total_indexes : int Atomic.t;
11
+
mutable non_hidden_units : int Atomic.t;
12
+
mutable compiled_units : int Atomic.t;
13
+
mutable compiled_impls : int Atomic.t;
14
+
mutable compiled_mlds : int Atomic.t;
15
+
mutable compiled_assets : int Atomic.t;
16
+
mutable linked_units : int Atomic.t;
17
+
mutable linked_impls : int Atomic.t;
18
+
mutable linked_mlds : int Atomic.t;
19
+
mutable generated_indexes : int Atomic.t;
20
+
mutable generated_units : int Atomic.t;
21
+
mutable processes : int Atomic.t;
22
+
mutable process_activity : string Atomic.t Array.t;
23
+
mutable finished : bool;
24
+
}
25
+
26
+
let stats =
27
+
{
28
+
total_units = Atomic.make 0;
29
+
total_impls = Atomic.make 0;
30
+
total_mlds = Atomic.make 0;
31
+
total_assets = Atomic.make 0;
32
+
total_indexes = Atomic.make 0;
33
+
non_hidden_units = Atomic.make 0;
34
+
compiled_units = Atomic.make 0;
35
+
compiled_impls = Atomic.make 0;
36
+
compiled_mlds = Atomic.make 0;
37
+
compiled_assets = Atomic.make 0;
38
+
linked_units = Atomic.make 0;
39
+
linked_impls = Atomic.make 0;
40
+
linked_mlds = Atomic.make 0;
41
+
generated_units = Atomic.make 0;
42
+
generated_indexes = Atomic.make 0;
43
+
processes = Atomic.make 0;
44
+
process_activity = [||];
45
+
finished = false;
46
+
}
47
+
48
+
let render_stats env ~generate_json nprocs =
49
+
let if_app f =
50
+
match Logs.level () with Some (App | Warning) | None -> f () | _ -> ()
51
+
in
52
+
(* Avoids overkill indentation *)
53
+
if_app @@ fun () ->
54
+
let open Progress in
55
+
let clock = Eio.Stdenv.clock env in
56
+
let total = Atomic.get stats.total_units in
57
+
let total_impls = Atomic.get stats.total_impls in
58
+
let total_mlds = Atomic.get stats.total_mlds in
59
+
let total_assets = Atomic.get stats.total_assets in
60
+
let total_indexes = Atomic.get stats.total_indexes in
61
+
let bar message total =
62
+
let open Progress.Line in
63
+
list [ lpad 16 (const message); bar total; rpad 10 (count_to total) ]
64
+
in
65
+
let procs total =
66
+
let open Progress.Line in
67
+
list [ lpad 16 (const "Processes"); bar total; rpad 10 (count_to total) ]
68
+
in
69
+
let description =
70
+
let open Progress.Line in
71
+
string
72
+
in
73
+
let descriptions = Multi.lines (List.init nprocs (fun _ -> description)) in
74
+
75
+
let non_hidden = Atomic.get stats.non_hidden_units in
76
+
77
+
let dline x y = Multi.line (bar x y) in
78
+
let config = Progress.Config.v ~persistent:false () in
79
+
let total_generate =
80
+
let units = total_impls + non_hidden + total_mlds in
81
+
if generate_json then 2 * units else units
82
+
in
83
+
with_reporters ~config
84
+
Multi.(
85
+
dline "Compiling" total
86
+
++ dline "Compiling impls" total_impls
87
+
++ dline "Compiling pages" total_mlds
88
+
++ dline "Compiling assets" total_assets
89
+
++ dline "Linking" non_hidden
90
+
++ dline "Linking impls" total_impls
91
+
++ dline "Linking mlds" total_mlds
92
+
++ dline "Indexes" total_indexes
93
+
++ dline "HTML" total_generate
94
+
++ line (procs nprocs)
95
+
++ descriptions)
96
+
(fun comp
97
+
compimpl
98
+
compmld
99
+
compassets
100
+
link
101
+
linkimpl
102
+
linkmld
103
+
indexes
104
+
html
105
+
procs
106
+
descr
107
+
->
108
+
let rec inner (a, b, c, j, d, e, f, i, g, h) =
109
+
Eio.Time.sleep clock 0.1;
110
+
let a' = Atomic.get stats.compiled_units in
111
+
let b' = Atomic.get stats.compiled_impls in
112
+
let c' = Atomic.get stats.compiled_mlds in
113
+
let j' = Atomic.get stats.compiled_assets in
114
+
let d' = Atomic.get stats.linked_units in
115
+
let e' = Atomic.get stats.linked_impls in
116
+
let f' = Atomic.get stats.linked_mlds in
117
+
let i' = Atomic.get stats.generated_indexes in
118
+
let g' = Atomic.get stats.generated_units in
119
+
let h' = Atomic.get stats.processes in
120
+
List.iteri
121
+
(fun i descr -> descr (Atomic.get stats.process_activity.(i)))
122
+
descr;
123
+
comp (a' - a);
124
+
compimpl (b' - b);
125
+
compmld (c' - c);
126
+
compassets (j' - j);
127
+
link (d' - d);
128
+
linkimpl (e' - e);
129
+
linkmld (f' - f);
130
+
indexes (i' - i);
131
+
html (g' - g);
132
+
procs (h' - h);
133
+
if not stats.finished then inner (a', b', c', j', d', e', f', i', g', h')
134
+
in
135
+
inner (0, 0, 0, 0, 0, 0, 0, 0, 0, 0))
136
+
137
+
let init_nprocs nprocs =
138
+
stats.process_activity <- Array.init nprocs (fun _ -> Atomic.make "idle")
139
+
140
+
let pp_stats fmt stats =
141
+
Fmt.pf fmt
142
+
"Total units: %d\n\
143
+
Total impls: %d\n\
144
+
Total mlds: %d\n\
145
+
Non-hidden units: %d\n\
146
+
Compiled units: %d\n\
147
+
Compiled impls: %d\n\
148
+
Compiled mlds: %d\n\
149
+
Linked units: %d\n\
150
+
Linked impls: %d\n\
151
+
Linked mlds: %d\n\
152
+
Generated units: %d\n"
153
+
(Atomic.get stats.total_units)
154
+
(Atomic.get stats.total_impls)
155
+
(Atomic.get stats.total_mlds)
156
+
(Atomic.get stats.non_hidden_units)
157
+
(Atomic.get stats.compiled_units)
158
+
(Atomic.get stats.compiled_impls)
159
+
(Atomic.get stats.compiled_mlds)
160
+
(Atomic.get stats.linked_units)
161
+
(Atomic.get stats.linked_impls)
162
+
(Atomic.get stats.linked_mlds)
163
+
(Atomic.get stats.generated_units)
164
+
165
+
let k_longest_commands cmd k =
166
+
let open Run in
167
+
filter_commands cmd
168
+
|> List.sort (fun a b -> Float.compare b.time a.time)
169
+
|> List.filteri (fun i _ -> i < k)
170
+
171
+
let dump () =
172
+
let open Run in
173
+
List.iter print_cmd (List.rev !commands);
174
+
List.iter print_cmd (k_longest_commands "compile" 5);
175
+
List.iter print_cmd (k_longest_commands "link" 5);
176
+
List.iter print_cmd (k_longest_commands "html-generate" 5)
177
+
178
+
let rec compute_min_max_avg min_ max_ total count = function
179
+
| [] -> (min_, max_, total /. float count, count)
180
+
| hd :: tl ->
181
+
compute_min_max_avg (min min_ hd) (max max_ hd) (total +. hd) (count + 1)
182
+
tl
183
+
184
+
let compute_min_max_avg = function
185
+
| [] -> None
186
+
| hd :: tl -> Some (compute_min_max_avg hd hd hd 1 tl)
187
+
188
+
let compute_metric_int prefix suffix description values =
189
+
match compute_min_max_avg values with
190
+
| None -> []
191
+
| Some (min, max, avg, count) ->
192
+
let min = int_of_float min in
193
+
let max = int_of_float max in
194
+
let avg = int_of_float avg in
195
+
[
196
+
`Assoc
197
+
[
198
+
("name", `String (prefix ^ "-total-" ^ suffix));
199
+
("value", `Int count);
200
+
("description", `String ("Number of " ^ description));
201
+
];
202
+
`Assoc
203
+
[
204
+
("name", `String (prefix ^ "-size-" ^ suffix));
205
+
( "value",
206
+
`Assoc [ ("min", `Int min); ("max", `Int max); ("avg", `Int avg) ]
207
+
);
208
+
("units", `String "b");
209
+
("description", `String ("Size of " ^ description));
210
+
("trend", `String "lower-is-better");
211
+
];
212
+
]
213
+
214
+
let compute_metric_cmd cmd =
215
+
let open Run in
216
+
let cmds = filter_commands cmd in
217
+
let times = List.map (fun c -> c.Run.time) cmds in
218
+
match compute_min_max_avg times with
219
+
| None -> []
220
+
| Some (min, max, avg, count) ->
221
+
[
222
+
`Assoc
223
+
[
224
+
("name", `String ("total-" ^ cmd));
225
+
("value", `Int count);
226
+
( "description",
227
+
`String ("Number of time 'odoc " ^ cmd ^ "' has run.") );
228
+
];
229
+
`Assoc
230
+
[
231
+
("name", `String ("time-" ^ cmd));
232
+
( "value",
233
+
`Assoc
234
+
[
235
+
("min", `Float min); ("max", `Float max); ("avg", `Float avg);
236
+
] );
237
+
("units", `String "s");
238
+
("description", `String ("Time taken by 'odoc " ^ cmd ^ "'"));
239
+
("trend", `String "lower-is-better");
240
+
];
241
+
]
242
+
243
+
(** Analyze the size of files produced by a command. *)
244
+
let compute_produced_cmd cmd =
245
+
let output_file_size c =
246
+
match c.Run.output_file with
247
+
| Some f -> (
248
+
match Bos.OS.Path.stat f with
249
+
| Ok st -> Some (float st.Unix.st_size)
250
+
| Error _ -> None)
251
+
| None -> None
252
+
in
253
+
let sizes = List.filter_map output_file_size (Run.filter_commands cmd) in
254
+
compute_metric_int "produced" cmd
255
+
("files produced by 'odoc " ^ cmd ^ "'")
256
+
sizes
257
+
258
+
(** Analyze the size of files outputed to the given directory. *)
259
+
let compute_produced_tree cmd dir =
260
+
let acc_file_sizes path acc =
261
+
match Bos.OS.Path.stat path with
262
+
| Ok st -> float st.Unix.st_size :: acc
263
+
| Error _ -> acc
264
+
in
265
+
Bos.OS.Dir.fold_contents ~dotfiles:true ~elements:`Files acc_file_sizes [] dir
266
+
|> Result.value ~default:[]
267
+
|> compute_metric_int "produced" cmd ("files produced by 'odoc " ^ cmd ^ "'")
268
+
269
+
(** Analyze the running time of the slowest commands. *)
270
+
let compute_longest_cmd cmd =
271
+
let k = 5 in
272
+
let cmds = k_longest_commands cmd k in
273
+
let times = List.map (fun c -> c.Run.time) cmds in
274
+
match compute_min_max_avg times with
275
+
| None -> []
276
+
| Some (min, max, avg, _count) ->
277
+
[
278
+
`Assoc
279
+
[
280
+
("name", `String ("longest-" ^ cmd));
281
+
( "value",
282
+
`Assoc
283
+
[
284
+
("min", `Float min); ("max", `Float max); ("avg", `Float avg);
285
+
] );
286
+
("units", `String "s");
287
+
( "description",
288
+
`String
289
+
(Printf.sprintf
290
+
"Time taken by the %d longest calls to 'odoc %s'" k cmd) );
291
+
("trend", `String "lower-is-better");
292
+
];
293
+
]
294
+
295
+
let all_metrics html_dir =
296
+
compute_metric_cmd "compile"
297
+
@ compute_metric_cmd "compile-deps"
298
+
@ compute_metric_cmd "link"
299
+
@ compute_metric_cmd "html-generate"
300
+
@ compute_longest_cmd "compile"
301
+
@ compute_longest_cmd "link"
302
+
@ compute_produced_cmd "compile"
303
+
@ compute_produced_cmd "link"
304
+
@ compute_produced_tree "html-generate" html_dir
305
+
306
+
let bench_results html_dir =
307
+
let result =
308
+
`Assoc
309
+
[
310
+
("name", `String "odoc");
311
+
( "results",
312
+
`List
313
+
[
314
+
`Assoc
315
+
[
316
+
("name", `String "driver.mld");
317
+
("metrics", `List (all_metrics html_dir));
318
+
];
319
+
] );
320
+
]
321
+
in
322
+
Yojson.to_file "driver-benchmarks.json" result
323
+
324
+
let total_time () =
325
+
let open Run in
326
+
let cmds = !commands in
327
+
List.fold_left (fun acc c -> acc +. c.time) 0.0 cmds
+54
driver/status.ml
+54
driver/status.ml
···
1
+
let json ~html_dir ~pkg ?(redirections = Hashtbl.create 0) () =
2
+
let files =
3
+
let lib_dir = Odoc_unit.pkg_dir pkg in
4
+
let lib_dir = Fpath.( // ) html_dir lib_dir in
5
+
let files =
6
+
Bos.OS.Dir.fold_contents
7
+
~elements:(`Sat (fun x -> Ok (Fpath.has_ext "html" x)))
8
+
(fun path acc ->
9
+
`String
10
+
(Fpath.to_string (Fpath.rem_prefix lib_dir path |> Option.get))
11
+
:: acc)
12
+
[] lib_dir
13
+
|> function
14
+
| Ok e -> e
15
+
| Error (`Msg err) ->
16
+
Logs.err (fun m ->
17
+
m "Got an error while collecting files for status.json: %s" err);
18
+
[]
19
+
in
20
+
`List files
21
+
in
22
+
let name = `String pkg.Packages.name in
23
+
let version = `String pkg.Packages.version in
24
+
let failed = `Bool false in
25
+
let redirections =
26
+
Hashtbl.fold
27
+
(fun old_path new_path acc ->
28
+
`Assoc
29
+
[
30
+
("old_path", `String (Fpath.to_string old_path));
31
+
("new_path", `String (Fpath.to_string new_path));
32
+
]
33
+
:: acc)
34
+
redirections []
35
+
in
36
+
let redirections = `List redirections in
37
+
`Assoc
38
+
[
39
+
("name", name);
40
+
("version", version);
41
+
("files", files);
42
+
("failed", failed);
43
+
("redirections", redirections);
44
+
]
45
+
46
+
let file ~html_dir ~pkg ?(redirections = Hashtbl.create 0) () =
47
+
let json = json ~html_dir ~pkg ~redirections () in
48
+
let json = Yojson.Safe.pretty_to_string json in
49
+
let status_path = Fpath.(html_dir // Odoc_unit.pkg_dir pkg / "status.json") in
50
+
match Bos.OS.File.write status_path json with
51
+
| Ok () -> ()
52
+
| Error (`Msg msg) ->
53
+
Logs.err (fun m ->
54
+
m "Error when generating status.json for %s: %s" pkg.name msg)
+39
driver/util.ml
+39
driver/util.ml
···
1
+
open Bos
2
+
3
+
let ( >>= ) = Result.bind
4
+
5
+
module StringSet = Set.Make (String)
6
+
module StringMap = Map.Make (String)
7
+
8
+
let with_dir dir pat f =
9
+
match dir with
10
+
| None -> OS.Dir.with_tmp pat f () |> Result.get_ok
11
+
| Some dir -> f dir ()
12
+
13
+
let lines_of_channel ic =
14
+
let rec inner acc =
15
+
try
16
+
let l = input_line ic in
17
+
inner (l :: acc)
18
+
with End_of_file -> List.rev acc
19
+
in
20
+
inner []
21
+
22
+
let lines_of_process cmd =
23
+
match OS.Cmd.(run_out ~err:err_null cmd |> to_lines) with
24
+
| Ok x -> x
25
+
| Error (`Msg e) -> failwith ("Error: " ^ e)
26
+
27
+
(** Opens a file for writing and calls [f]. The destination directory is created
28
+
if needed. *)
29
+
let with_out_to filename f =
30
+
let filename = Fpath.normalize filename in
31
+
OS.Dir.create (Fpath.parent filename) >>= fun _ ->
32
+
OS.File.with_oc filename
33
+
(fun oc () ->
34
+
f oc;
35
+
Ok ())
36
+
()
37
+
|> Result.join
38
+
39
+
let cp src dst = assert (lines_of_process Cmd.(v "cp" % src % dst) = [])
+459
driver/voodoo.ml
+459
driver/voodoo.ml
···
1
+
(* Voodoo *)
2
+
3
+
let ( >>= ) = Result.bind
4
+
5
+
type pkg = {
6
+
name : string;
7
+
version : string;
8
+
universe : string;
9
+
blessed : bool;
10
+
path : Fpath.t; (** Root directory that [files] are relative to *)
11
+
files : Fpath.t list;
12
+
}
13
+
14
+
let prep_path = ref "prep"
15
+
16
+
(* We mark the paths that contain compiled units for both packages and libraries
17
+
by dropping in a marker file. The contents of the file is unimportant, as we
18
+
can determine which package or library we're looking at simply by its path. *)
19
+
let lib_marker = ".odoc_lib_marker"
20
+
let pkg_marker = ".odoc_pkg_marker"
21
+
22
+
let top_dir ~flat pkg =
23
+
if flat then Fpath.v pkg.name
24
+
else if pkg.blessed then Fpath.(v "p" / pkg.name / pkg.version)
25
+
else Fpath.(v "u" / pkg.universe / pkg.name / pkg.version)
26
+
27
+
(* Use output from Voodoo Prep as input *)
28
+
29
+
let find_universe_and_version pkg_name =
30
+
Bos.OS.Dir.contents Fpath.(v !prep_path / "universes") >>= fun universes ->
31
+
let universe =
32
+
match
33
+
List.find_opt
34
+
(fun u ->
35
+
match Bos.OS.Dir.exists Fpath.(u / pkg_name) with
36
+
| Ok b -> b
37
+
| Error _ -> false)
38
+
universes
39
+
with
40
+
| Some u -> Ok u
41
+
| None -> Error (`Msg (Format.sprintf "Failed to find package %s" pkg_name))
42
+
in
43
+
universe >>= fun u ->
44
+
Bos.OS.Dir.contents ~rel:true Fpath.(u / pkg_name) >>= fun version ->
45
+
match (Fpath.segs u, version) with
46
+
| _ :: _ :: u :: _, [ version ] -> Ok (u, Fpath.to_string version)
47
+
| _ -> Error (`Msg (Format.sprintf "Failed to find package %s" pkg_name))
48
+
49
+
(* Given a directory containing for example [a.cma] and [b.cma], this
50
+
function returns a Fpath.Map.t mapping [dir/a.cma -> a] and [dir/b.cma -> b] *)
51
+
let libname_of_archives_of_dir dir =
52
+
let files_res = Bos.OS.Dir.contents dir in
53
+
match files_res with
54
+
| Error _ -> Fpath.Map.empty
55
+
| Ok files ->
56
+
List.fold_left
57
+
(fun acc file ->
58
+
let base = Fpath.basename file in
59
+
if Astring.String.is_suffix ~affix:".cma" base then
60
+
let libname = String.sub base 0 (String.length base - 4) in
61
+
Fpath.Map.add Fpath.(dir / libname) libname acc
62
+
else acc)
63
+
Fpath.Map.empty files
64
+
65
+
let metas_of_pkg pkg =
66
+
List.filter
67
+
(fun p ->
68
+
let filename = Fpath.filename p in
69
+
filename = "META")
70
+
pkg.files
71
+
72
+
let of_voodoo ~flat pkg =
73
+
let metas = metas_of_pkg pkg in
74
+
75
+
let pkg_path = pkg.path in
76
+
77
+
(* a map from libname to the set of dependencies of that library *)
78
+
let (all_lib_deps, cmi_only_libs) :
79
+
Util.StringSet.t Util.StringMap.t * (Fpath.t * string) list =
80
+
List.fold_left
81
+
(fun (d, c) meta ->
82
+
let full_meta_path = Fpath.(pkg_path // meta) in
83
+
let m = Library_names.process_meta_file full_meta_path in
84
+
let d' =
85
+
List.fold_left
86
+
(fun acc lib ->
87
+
Util.StringMap.add lib.Library_names.name
88
+
(Util.StringSet.of_list ("stdlib" :: lib.Library_names.deps))
89
+
acc)
90
+
d m.libraries
91
+
in
92
+
let c' =
93
+
List.fold_left
94
+
(fun acc (lib : Library_names.library) ->
95
+
match (lib.archive_name, lib.dir) with
96
+
| None, Some dir ->
97
+
Logs.debug (fun m -> m "Found cmi_only_lib in dir: %s" dir);
98
+
(Fpath.(m.meta_dir / dir), lib.name) :: acc
99
+
| None, None -> acc
100
+
| Some _, _ -> acc)
101
+
c m.libraries
102
+
in
103
+
(d', c'))
104
+
(Util.StringMap.empty, []) metas
105
+
in
106
+
107
+
(* Transitively close [all_lib_deps] over itself so each lib's deps
108
+
reflect every lib reachable through META requires. *)
109
+
let all_lib_deps =
110
+
let cache : (string, Util.StringSet.t) Hashtbl.t =
111
+
Hashtbl.create (Util.StringMap.cardinal all_lib_deps)
112
+
in
113
+
let rec close lib =
114
+
match Hashtbl.find_opt cache lib with
115
+
| Some r -> r
116
+
| None ->
117
+
Hashtbl.add cache lib Util.StringSet.empty;
118
+
let direct =
119
+
match Util.StringMap.find_opt lib all_lib_deps with
120
+
| Some s -> s
121
+
| None -> Util.StringSet.empty
122
+
in
123
+
let closed =
124
+
Util.StringSet.fold
125
+
(fun dep acc ->
126
+
Util.StringSet.union (Util.StringSet.add dep (close dep)) acc)
127
+
direct Util.StringSet.empty
128
+
in
129
+
Hashtbl.replace cache lib closed;
130
+
closed
131
+
in
132
+
Util.StringMap.mapi (fun lib _ -> close lib) all_lib_deps
133
+
in
134
+
135
+
let ss_pp fmt ss = Format.fprintf fmt "[%d]" (Util.StringSet.cardinal ss) in
136
+
Logs.debug (fun m ->
137
+
m "all_lib_deps: %a\n%!"
138
+
Fmt.(list ~sep:comma (pair ~sep:comma string ss_pp))
139
+
(Util.StringMap.bindings all_lib_deps));
140
+
141
+
let docs = Opam.classify_docs pkg_path (Some pkg.name) pkg.files in
142
+
let mlds, assets, other_docs = Packages.mk_mlds docs in
143
+
144
+
let config =
145
+
let config_file =
146
+
Fpath.(pkg_path / "doc" / pkg.name / "odoc-config.sexp")
147
+
in
148
+
match Bos.OS.File.read config_file with
149
+
| Error (`Msg msg) ->
150
+
Logs.debug (fun m ->
151
+
m "No config file found: %a\n%s\n%!" Fpath.pp config_file msg);
152
+
Global_config.empty
153
+
| Ok s ->
154
+
Logs.debug (fun m -> m "Config file: %a\n%!" Fpath.pp config_file);
155
+
Global_config.parse s
156
+
in
157
+
158
+
Logs.debug (fun m ->
159
+
m "Config.packages: %s\n%!" (String.concat ", " config.deps.packages));
160
+
let meta_libraries : Packages.libty list =
161
+
metas
162
+
|> List.filter_map (fun meta_file ->
163
+
let full_meta_path = Fpath.(pkg_path // meta_file) in
164
+
let m = Library_names.process_meta_file full_meta_path in
165
+
let libname_of_archive = Library_names.libname_of_archive m in
166
+
Fpath.Map.iter
167
+
(fun k v -> Logs.debug (fun m -> m "%a,%s\n%!" Fpath.pp k v))
168
+
libname_of_archive;
169
+
170
+
let directories = Library_names.directories m in
171
+
Some
172
+
(List.concat_map
173
+
(fun directory ->
174
+
Logs.debug (fun m ->
175
+
m "Processing directory: %a\n%!" Fpath.pp directory);
176
+
Packages.Lib.v ~libname_of_archive ~pkg_name:pkg.name
177
+
~dir:directory ~cmtidir:None ~all_lib_deps ~cmi_only_libs
178
+
~id_override:None)
179
+
Fpath.(Set.to_list directories)))
180
+
|> List.flatten
181
+
in
182
+
183
+
(* A package may install a file into a directory it doesn't own — notably
184
+
[ocamlfind] drops [lib/ocaml/topfind] into the compiler's stdlib
185
+
directory. In an opam switch that directory is shared between packages,
186
+
so treating it as one of this package's libraries would document every
187
+
module physically present in it (e.g. the whole stdlib). Only treat a
188
+
directory as the package's own library if the package actually installed
189
+
a compiled module in it. *)
190
+
let pkg_owns_module_in dir =
191
+
let is_compiled_module p =
192
+
List.exists
193
+
(fun ext -> Fpath.has_ext ext p)
194
+
[ "cmi"; "cmti"; "cmt"; "cma"; "cmxa"; "cmxs"; "cmo"; "cmx" ]
195
+
in
196
+
List.exists
197
+
(fun f ->
198
+
is_compiled_module f
199
+
&& Fpath.equal (Fpath.parent f) (Fpath.to_dir_path dir))
200
+
pkg.files
201
+
in
202
+
203
+
(* Check the main package lib directory even if there's no meta file *)
204
+
let non_meta_libraries =
205
+
let libdirs_without_meta =
206
+
List.filter
207
+
(fun p ->
208
+
match Fpath.segs p with
209
+
| "lib" :: _ :: _
210
+
when Sys.is_directory Fpath.(pkg_path // p |> to_string) ->
211
+
pkg_owns_module_in p
212
+
&& not
213
+
(List.exists
214
+
(fun lib ->
215
+
Fpath.equal
216
+
Fpath.(to_dir_path lib.Packages.dir)
217
+
Fpath.(to_dir_path (pkg_path // p)))
218
+
meta_libraries)
219
+
| _ -> false)
220
+
pkg.files
221
+
in
222
+
223
+
Logs.debug (fun m ->
224
+
m "libdirs_without_meta: %a\n%!"
225
+
Fmt.(list ~sep:comma Fpath.pp)
226
+
(List.map (fun p -> Fpath.(pkg_path // p)) libdirs_without_meta));
227
+
228
+
Logs.debug (fun m ->
229
+
m "lib dirs: %a\n%!"
230
+
Fmt.(list ~sep:comma Fpath.pp)
231
+
(List.map (fun (lib : Packages.libty) -> lib.dir) meta_libraries));
232
+
233
+
List.map
234
+
(fun libdir ->
235
+
let libname_of_archive =
236
+
libname_of_archives_of_dir Fpath.(pkg_path // libdir)
237
+
in
238
+
Logs.debug (fun m ->
239
+
m "Processing directory without META: %a" Fpath.pp libdir);
240
+
Packages.Lib.v ~libname_of_archive ~pkg_name:pkg.name
241
+
~dir:Fpath.(pkg_path // libdir)
242
+
~cmtidir:None ~all_lib_deps ~cmi_only_libs:[] ~id_override:None)
243
+
libdirs_without_meta
244
+
|> List.flatten
245
+
in
246
+
let libraries = meta_libraries @ non_meta_libraries in
247
+
let pkg_dir = top_dir ~flat pkg in
248
+
let doc_dir = if flat then pkg_dir else Fpath.(pkg_dir / "doc") in
249
+
let result =
250
+
{
251
+
Packages.name = pkg.name;
252
+
version = pkg.version;
253
+
libraries;
254
+
mlds;
255
+
assets;
256
+
selected = true;
257
+
remaps = [];
258
+
other_docs;
259
+
pkg_dir;
260
+
doc_dir;
261
+
config;
262
+
}
263
+
in
264
+
result
265
+
266
+
let pp ppf v =
267
+
Format.fprintf ppf "n: %s v: %s u: %s [\n" v.name v.version v.universe;
268
+
List.iter (fun fp -> Format.fprintf ppf "%a\n" Fpath.pp fp) v.files;
269
+
Format.fprintf ppf "]\n%!"
270
+
271
+
let () = ignore pp
272
+
273
+
let find_pkg pkg_name ~blessed =
274
+
let contents =
275
+
Bos.OS.Dir.fold_contents ~dotfiles:true
276
+
(fun p acc -> p :: acc)
277
+
[]
278
+
Fpath.(v !prep_path)
279
+
in
280
+
match contents with
281
+
| Error _ -> None
282
+
| Ok c -> (
283
+
let sorted = List.sort (fun p1 p2 -> Fpath.compare p1 p2) c in
284
+
let last, packages =
285
+
List.fold_left
286
+
(fun (cur_opt, acc) file ->
287
+
match Fpath.segs file with
288
+
| "prep" :: "universes" :: u :: p :: v :: (_ :: _ as rest)
289
+
when p = pkg_name -> (
290
+
let file = Fpath.v (Astring.String.concat ~sep:"/" rest) in
291
+
match cur_opt with
292
+
| Some cur
293
+
when cur.name = p && cur.version = v && cur.universe = u ->
294
+
(Some { cur with files = file :: cur.files }, acc)
295
+
| _ ->
296
+
( Some
297
+
{
298
+
name = p;
299
+
version = v;
300
+
universe = u;
301
+
blessed;
302
+
path =
303
+
List.fold_left Fpath.add_seg (Fpath.v "prep")
304
+
[ "universes"; u; p; v ];
305
+
files = [ file ];
306
+
},
307
+
cur_opt :: acc ))
308
+
| _ -> (cur_opt, acc))
309
+
(None, []) sorted
310
+
in
311
+
let packages = List.filter_map (fun x -> x) (last :: packages) in
312
+
match packages with
313
+
| [ package ] -> Some package
314
+
| [] ->
315
+
Logs.err (fun m -> m "No package found for %s" pkg_name);
316
+
None
317
+
| _ ->
318
+
Logs.err (fun m -> m "Multiple packages found for %s" pkg_name);
319
+
None)
320
+
321
+
(* An alternative to [find_pkg] for packages installed in an opam switch:
322
+
rather than scanning a filesystem containing only the package's files, use
323
+
opam's [.changes] file to determine which files belong to the package. *)
324
+
let find_opam_pkg pkg_name =
325
+
match
326
+
List.find_opt
327
+
(fun p -> p.Opam.name = pkg_name)
328
+
(Opam.all_opam_packages ())
329
+
with
330
+
| None ->
331
+
Logs.err (fun m ->
332
+
m "Package %s is not installed in the current opam switch" pkg_name);
333
+
None
334
+
| Some pkg ->
335
+
let files = Opam.pkg_contents pkg in
336
+
(* [Opam.pkg_contents] lists files only; add their parent directories,
337
+
which [of_voodoo] needs in order to spot library directories that
338
+
aren't covered by a META file. *)
339
+
let dirs =
340
+
List.fold_left
341
+
(fun acc f -> Fpath.Set.add (Fpath.parent f) acc)
342
+
Fpath.Set.empty files
343
+
in
344
+
Some
345
+
{
346
+
name = pkg.Opam.name;
347
+
version = pkg.Opam.version;
348
+
universe = "";
349
+
blessed = true;
350
+
path = Fpath.v (Opam.prefix ());
351
+
files = files @ Fpath.Set.to_list dirs;
352
+
}
353
+
354
+
let occurrence_file_of_pkg ~flat pkg =
355
+
let top_dir = top_dir ~flat pkg in
356
+
Fpath.(top_dir / "occurrences-all.odoc-occurrences")
357
+
358
+
type extra_paths = {
359
+
pkgs : Fpath.t Util.StringMap.t;
360
+
libs : Fpath.t Util.StringMap.t;
361
+
libs_of_pkg : string list Util.StringMap.t;
362
+
}
363
+
364
+
let empty_extra_paths =
365
+
{
366
+
pkgs = Util.StringMap.empty;
367
+
libs = Util.StringMap.empty;
368
+
libs_of_pkg = Util.StringMap.empty;
369
+
}
370
+
371
+
let extra_paths ~flat compile_dir =
372
+
let contents =
373
+
Bos.OS.Dir.fold_contents ~dotfiles:true
374
+
(fun p acc -> p :: acc)
375
+
[] compile_dir
376
+
in
377
+
let add_libs pkgname libname libs_of_pkg =
378
+
Util.StringMap.update pkgname
379
+
(function None -> Some [ libname ] | Some l -> Some (libname :: l))
380
+
libs_of_pkg
381
+
in
382
+
let pkgs, libs, libs_of_pkg =
383
+
match contents with
384
+
| Error _ ->
385
+
(Util.StringMap.empty, Util.StringMap.empty, Util.StringMap.empty)
386
+
| Ok c ->
387
+
List.fold_left
388
+
(fun (pkgs, libs, libs_of_pkg) abs_path ->
389
+
let path = Fpath.rem_prefix compile_dir abs_path |> Option.get in
390
+
match Fpath.segs path with
391
+
| [ pkg; libname; l ] when flat && l = lib_marker ->
392
+
Logs.debug (fun m -> m "Found lib marker: %a" Fpath.pp path);
393
+
( pkgs,
394
+
Util.StringMap.add libname (Fpath.parent path) libs,
395
+
add_libs pkg libname libs_of_pkg )
396
+
| [ pkg; l ] when flat && l = pkg_marker ->
397
+
Logs.debug (fun m -> m "Found pkg marker: %a" Fpath.pp path);
398
+
( Util.StringMap.add pkg (Fpath.parent path) pkgs,
399
+
libs,
400
+
libs_of_pkg )
401
+
| [ "p"; pkg; _version; "doc"; libname; l ]
402
+
when (not flat) && l = lib_marker ->
403
+
Logs.debug (fun m -> m "Found lib marker: %a" Fpath.pp path);
404
+
( pkgs,
405
+
Util.StringMap.add libname (Fpath.parent path) libs,
406
+
add_libs pkg libname libs_of_pkg )
407
+
| [ "p"; pkg; _version; "doc"; l ]
408
+
when (not flat) && l = pkg_marker ->
409
+
Logs.debug (fun m -> m "Found pkg marker: %a" Fpath.pp path);
410
+
( Util.StringMap.add pkg (Fpath.parent path) pkgs,
411
+
libs,
412
+
libs_of_pkg )
413
+
| [ "u"; _universe; pkg; _version; "doc"; libname; l ]
414
+
when (not flat) && l = lib_marker ->
415
+
Logs.debug (fun m -> m "Found lib marker: %a" Fpath.pp path);
416
+
( pkgs,
417
+
Util.StringMap.add libname (Fpath.parent path) libs,
418
+
add_libs pkg libname libs_of_pkg )
419
+
| [ "u"; _universe; pkg; _version; "doc"; l ]
420
+
when (not flat) && l = pkg_marker ->
421
+
Logs.debug (fun m -> m "Found pkg marker: %a" Fpath.pp path);
422
+
( Util.StringMap.add pkg (Fpath.parent path) pkgs,
423
+
libs,
424
+
libs_of_pkg )
425
+
| _ -> (pkgs, libs, libs_of_pkg))
426
+
(Util.StringMap.empty, Util.StringMap.empty, Util.StringMap.empty)
427
+
c
428
+
in
429
+
{ pkgs; libs; libs_of_pkg }
430
+
431
+
let write_lib_markers odoc_dir pkgs =
432
+
let write file str =
433
+
match Bos.OS.File.write file str with
434
+
| Ok () -> ()
435
+
| Error (`Msg msg) ->
436
+
Logs.err (fun m -> m "Failed to write lib marker: %s" msg)
437
+
in
438
+
List.iter
439
+
(fun (pkg : Packages.t) ->
440
+
let libs = pkg.libraries in
441
+
let pkg_path = Odoc_unit.doc_dir pkg in
442
+
let marker = Fpath.(odoc_dir // pkg_path / pkg_marker) in
443
+
write marker
444
+
(Fmt.str
445
+
"This marks this directory as the location of odoc files for the \
446
+
package %s"
447
+
pkg.name);
448
+
449
+
List.iter
450
+
(fun (lib : Packages.libty) ->
451
+
let lib_dir = Odoc_unit.lib_dir pkg lib in
452
+
let marker = Fpath.(odoc_dir // lib_dir / lib_marker) in
453
+
write marker
454
+
(Fmt.str
455
+
"This marks this directory as the location of odoc files for \
456
+
library %s in package %s"
457
+
lib.lib_name pkg.name))
458
+
libs)
459
+
pkgs
+45
driver/voodoo.mli
+45
driver/voodoo.mli
···
1
+
val find_universe_and_version :
2
+
string -> (string * string, [> `Msg of string ]) result
3
+
4
+
type pkg
5
+
6
+
val find_pkg : string -> blessed:bool -> pkg option
7
+
(** [get_pkg name ~blessed] looks for a package named [name] in the prep
8
+
directory *)
9
+
10
+
val find_opam_pkg : string -> pkg option
11
+
(** [find_opam_pkg name] looks for a package named [name] installed in the
12
+
current opam switch, using opam's [.changes] file to determine which files
13
+
belong to it rather than searching the filesystem. *)
14
+
15
+
val of_voodoo : flat:bool -> pkg -> Packages.t
16
+
(** [of_voodoo ~flat pkg] returns the package layout for [pkg]. When [flat] is
17
+
true, output goes directly into [<package>/] (as in normal mode); otherwise
18
+
it goes into [p/<package>/<version>/doc/] (or
19
+
[u/<universe>/<package>/<version>/doc/] for unblessed packages). *)
20
+
21
+
val occurrence_file_of_pkg : flat:bool -> pkg -> Fpath.t
22
+
(** [occurrences_file_of_pkg ~flat pkg] returns an appropriate filename for the
23
+
occurrences file for [pkg]. *)
24
+
25
+
type extra_paths = {
26
+
pkgs : Fpath.t Util.StringMap.t;
27
+
libs : Fpath.t Util.StringMap.t;
28
+
libs_of_pkg : string list Util.StringMap.t;
29
+
}
30
+
31
+
val empty_extra_paths : extra_paths
32
+
(** When [odoc_driver] is not running in voodoo mode, this value can be passed
33
+
to {!Odoc_units_of.packages} *)
34
+
35
+
val extra_paths : flat:bool -> Fpath.t -> extra_paths
36
+
(** [extra_paths ~flat odoc_dir] returns the paths to packages and libraries
37
+
that have previously been compiled by odoc_driver running in voodoo mode.
38
+
In order to find these, the previous invocation of odoc_driver will need to
39
+
have written marker files by calling {!write_lib_markers}, and must have
40
+
been run with the same value of [flat]. *)
41
+
42
+
val write_lib_markers : Fpath.t -> Packages.t list -> unit
43
+
(** [write_lib_markers odoc_dir pkgs] writes marker files to show the locations
44
+
of the compilation units associated with packages and libraries in [pkgs].
45
+
*)
+52
driver/worker_pool.ml
+52
driver/worker_pool.ml
···
1
+
(* Worker pool *)
2
+
open Eio
3
+
4
+
type request = {
5
+
description : string;
6
+
request : Bos.Cmd.t;
7
+
output_file : Fpath.t option;
8
+
}
9
+
10
+
type response = (Run.t, exn) result
11
+
type resolver = response Eio.Promise.u
12
+
13
+
type t = (request * resolver) Eio.Stream.t
14
+
15
+
let stream : t = Eio.Stream.create 0
16
+
17
+
let handle_job env request output_file = Run.run env request output_file
18
+
19
+
exception Worker_failure of Run.t
20
+
21
+
let rec run_worker env id : unit =
22
+
let { request; output_file; description }, reply = Eio.Stream.take stream in
23
+
Atomic.incr Stats.stats.processes;
24
+
Atomic.set Stats.stats.process_activity.(id) description;
25
+
(try
26
+
let result = handle_job env request output_file in
27
+
match result.status with
28
+
| `Exited 0 ->
29
+
Atomic.decr Stats.stats.processes;
30
+
Atomic.set Stats.stats.process_activity.(id) "idle";
31
+
Promise.resolve reply (Ok result)
32
+
| _ -> Promise.resolve_error reply (Worker_failure result)
33
+
with e -> Promise.resolve_error reply e);
34
+
run_worker env id
35
+
36
+
let submit description request output_file =
37
+
let reply, resolve_reply = Promise.create () in
38
+
Eio.Stream.add stream ({ description; request; output_file }, resolve_reply);
39
+
Promise.await reply
40
+
41
+
let start_workers env sw n =
42
+
let spawn_worker name =
43
+
Fiber.fork_daemon ~sw (fun () ->
44
+
try
45
+
run_worker env name;
46
+
`Stop_daemon
47
+
with Stdlib.Exit -> `Stop_daemon)
48
+
in
49
+
for i = 0 to n - 1 do
50
+
spawn_worker i
51
+
done;
52
+
()
+8
driver/worker_pool.mli
+8
driver/worker_pool.mli
···
1
+
val submit : string -> Bos.Cmd.t -> Fpath.t option -> (Run.t, exn) result
2
+
(** Submit a command to be executed by a worker.
3
+
4
+
[submit desc cmd output_file] returns the list of output lines. [desc] is a
5
+
description of the command. *)
6
+
7
+
val start_workers : Eio_unix.Stdenv.base -> Eio.Switch.t -> int -> unit
8
+
(** Start the given number of new workers. *)
+11
-1
dune-project
+11
-1
dune-project
···
24
24
(bos (>= 0.2.1))
25
25
(fpath (>= 0.7.3))
26
26
(opam-format (>= 2.2.0))
27
-
sherlodoc))
27
+
sherlodoc
28
+
odoc
29
+
; Dependencies of the vendored driver (driver/), temporary pending upstreaming.
30
+
odoc-md
31
+
progress
32
+
yojson
33
+
ocamlfind
34
+
logs
35
+
eio
36
+
sexplib
37
+
ppx_sexp_conv))
+9
-1
odd.opam
+9
-1
odd.opam