Skip to content

Commit bcc7136

Browse files
JulowJulow
authored
Merge pull request #1179 from panglesd/refactor-driver
Driver: Separate types for "package" and "odoc unit".
2 parents 2ca8c07 + c95066b commit bcc7136

File tree

13 files changed

+480
-463
lines changed

13 files changed

+480
-463
lines changed

‎src/driver/compile.ml

Lines changed: 146 additions & 255 deletions
Large diffs are not rendered by default.

‎src/driver/compile.mli

Lines changed: 4 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,12 @@
11
type compiled
22

3-
val init_stats : Packages.set -> unit
3+
val init_stats : Odoc_unit.t list -> unit
44

55
val compile :
66
?partial:Fpath.t ->
7-
output_dir:Fpath.t ->
7+
partial_dir:Fpath.t ->
88
?linked_dir:Fpath.t ->
9-
Packages.set ->
9+
Odoc_unit.t list ->
1010
compiled list
1111
(** Use [partial] to reuse the output of a previous call to [compile]. Useful in
1212
the voodoo context.
@@ -18,8 +18,4 @@ type linked
1818

1919
val link : compiled list -> linked list
2020

21-
val index : odocl_dir:Fpath.t -> Packages.set -> unit
22-
23-
val sherlodoc : html_dir:Fpath.t -> odocl_dir:Fpath.t -> Packages.set -> unit
24-
25-
val html_generate : Fpath.t -> odocl_dir:Fpath.t -> linked list -> unit
21+
val html_generate : Fpath.t -> linked list -> unit

‎src/driver/dune_style.ml

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,7 @@ let of_dune_build dir =
3636
in
3737
let pkg_dir = Fpath.rem_prefix dir path |> Option.get in
3838
( pkg_dir,
39-
Packages.Lib.v ~pkg_dir
39+
Packages.Lib.v
4040
~libname_of_archive:(Util.StringMap.singleton libname libname)
4141
~pkg_name:libname ~dir:path ~cmtidir:(Some cmtidir) ))
4242
libs
@@ -53,7 +53,6 @@ let of_dune_build dir =
5353
version = "1.0";
5454
libraries = [ lib ];
5555
mlds = [];
56-
mld_odoc_dir = Fpath.v lib.Packages.lib_name;
5756
pkg_dir;
5857
other_docs = Fpath.Set.empty;
5958
} )

‎src/driver/indexes.ml

Lines changed: 0 additions & 7 deletions
This file was deleted.

‎src/driver/odoc.ml

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,10 @@ open Bos
33
type id = Fpath.t
44

55
let fpath_of_id id = id
6-
let id_of_fpath id = id
6+
7+
let id_of_fpath id =
8+
id |> Fpath.normalize
9+
|> Fpath.rem_empty_seg (* If an odoc path ends with a [/] everything breaks *)
710

811
let index_filename = "index.odoc-index"
912

‎src/driver/odoc_driver.ml

Lines changed: 30 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -451,6 +451,7 @@ let render_stats env nprocs =
451451
let total = Atomic.get Stats.stats.total_units in
452452
let total_impls = Atomic.get Stats.stats.total_impls in
453453
let total_mlds = Atomic.get Stats.stats.total_mlds in
454+
let total_indexes = Atomic.get Stats.stats.total_indexes in
454455
let bar message total =
455456
let open Progress.Line in
456457
list [ lpad 16 (const message); bar total; count_to total ]
@@ -459,6 +460,12 @@ let render_stats env nprocs =
459460
let open Progress.Line in
460461
list [ lpad 16 (const "Processes"); bar total; count_to total ]
461462
in
463+
let description =
464+
let open Progress.Line in
465+
string
466+
in
467+
let descriptions = Multi.lines (List.init nprocs (fun _ -> description)) in
468+
462469
let non_hidden = Atomic.get Stats.stats.non_hidden_units in
463470

464471
let dline x y = Multi.line (bar x y) in
@@ -470,32 +477,38 @@ let render_stats env nprocs =
470477
++ dline "Linking" non_hidden
471478
++ dline "Linking impls" total_impls
472479
++ dline "Linking mlds" total_mlds
480+
++ dline "Indexes" total_indexes
473481
++ dline "HTML" (total_impls + non_hidden + total_mlds)
474-
++ line (procs nprocs))
475-
(fun comp compimpl compmld link linkimpl linkmld html procs ->
476-
let rec inner (a, b, c, d, e, f, g, h) =
482+
++ line (procs nprocs)
483+
++ descriptions)
484+
(fun comp compimpl compmld link linkimpl linkmld indexes html procs descr ->
485+
let rec inner (a, b, c, d, e, f, i, g, h) =
477486
Eio.Time.sleep clock 0.1;
478487
let a' = Atomic.get Stats.stats.compiled_units in
479488
let b' = Atomic.get Stats.stats.compiled_impls in
480489
let c' = Atomic.get Stats.stats.compiled_mlds in
481490
let d' = Atomic.get Stats.stats.linked_units in
482491
let e' = Atomic.get Stats.stats.linked_impls in
483492
let f' = Atomic.get Stats.stats.linked_mlds in
493+
let i' = Atomic.get Stats.stats.generated_indexes in
484494
let g' = Atomic.get Stats.stats.generated_units in
485495
let h' = Atomic.get Stats.stats.processes in
486-
496+
List.iteri
497+
(fun i descr -> descr (Atomic.get Stats.stats.process_activity.(i)))
498+
descr;
487499
comp (a' - a);
488500
compimpl (b' - b);
489501
compmld (c' - c);
490502
link (d' - d);
491503
linkimpl (e' - e);
492504
linkmld (f' - f);
505+
indexes (i' - i);
493506
html (g' - g);
494507
procs (h' - h);
495508
if g' < non_hidden + total_impls + total_mlds then
496-
inner (a', b', c', d', e', f', g', h')
509+
inner (a', b', c', d', e', f', i', g', h')
497510
in
498-
inner (0, 0, 0, 0, 0, 0, 0, 0))
511+
inner (0, 0, 0, 0, 0, 0, 0, 0, 0))
499512

500513
let run libs verbose packages_dir odoc_dir odocl_dir html_dir stats nb_workers
501514
odoc_bin voodoo package_name blessed dune_style =
@@ -505,6 +518,7 @@ let run libs verbose packages_dir odoc_dir odocl_dir html_dir stats nb_workers
505518
Eio.Switch.run @@ fun sw ->
506519
if verbose then Logs.set_level (Some Logs.Debug);
507520
Logs.set_reporter (Logs_fmt.reporter ());
521+
Stats.init_nprocs nb_workers;
508522
let () = Worker_pool.start_workers env sw nb_workers in
509523

510524
let all =
@@ -529,35 +543,34 @@ let run libs verbose packages_dir odoc_dir odocl_dir html_dir stats nb_workers
529543
if voodoo then
530544
match Util.StringMap.to_list all with
531545
| [ (_, p) ] ->
532-
let output_path = Fpath.(odoc_dir // p.mld_odoc_dir) in
546+
let output_path = Fpath.(odoc_dir // p.pkg_dir / "doc") in
533547
Some output_path
534548
| _ -> failwith "Error, expecting singleton library in voodoo mode"
535549
else None
536550
in
537-
Compile.init_stats all;
538551
let () =
539552
Eio.Fiber.both
540553
(fun () ->
554+
let all =
555+
let all = Util.StringMap.bindings all |> List.map snd in
556+
Odoc_unit.of_packages ~output_dir:odoc_dir ~linked_dir:odocl_dir
557+
~index_dir:None all
558+
in
559+
Compile.init_stats all;
541560
let compiled =
542-
Compile.compile ?partial ~output_dir:odoc_dir ?linked_dir:odocl_dir
561+
Compile.compile ?partial ~partial_dir:odoc_dir ?linked_dir:odocl_dir
543562
all
544563
in
545564
let linked = Compile.link compiled in
546-
let odocl_dir = match odocl_dir with Some l -> l | None -> odoc_dir in
547-
let () = Compile.index ~odocl_dir all in
548-
let () = Compile.sherlodoc ~html_dir ~odocl_dir all in
549-
let () = Compile.html_generate html_dir ~odocl_dir linked in
565+
let () = Compile.html_generate html_dir linked in
550566
let _ = Odoc.support_files html_dir in
551567
())
552568
(fun () -> render_stats env nb_workers)
553569
in
554570

555571
Format.eprintf "Final stats: %a@.%!" Stats.pp_stats Stats.stats;
556572
Format.eprintf "Total time: %f@.%!" (Stats.total_time ());
557-
if stats then Stats.bench_results html_dir;
558-
let indexes = Util.StringMap.map (fun _i pkg -> Indexes.package pkg) all in
559-
560-
ignore indexes
573+
if stats then Stats.bench_results html_dir
561574

562575
let fpath_arg =
563576
let print ppf v = Fpath.pp ppf v in

‎src/driver/odoc_unit.ml

Lines changed: 201 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,201 @@
1+
type pkg_args = {
2+
pages : (string * Fpath.t) list;
3+
libs : (string * Fpath.t) list;
4+
}
5+
6+
type index = {
7+
pkg_args : pkg_args;
8+
output_file : Fpath.t;
9+
json : bool;
10+
search_dir : Fpath.t;
11+
}
12+
13+
type 'a unit = {
14+
parent_id : Odoc.id;
15+
odoc_dir : Fpath.t;
16+
input_file : Fpath.t;
17+
output_dir : Fpath.t;
18+
odoc_file : Fpath.t;
19+
odocl_file : Fpath.t;
20+
pkg_args : pkg_args;
21+
pkgname : string;
22+
include_dirs : Fpath.t list;
23+
index : index;
24+
kind : 'a;
25+
}
26+
27+
type intf_extra = { hidden : bool; hash : string; deps : intf unit list }
28+
and intf = [ `Intf of intf_extra ]
29+
30+
type impl_extra = { src_id : Odoc.id; src_path : Fpath.t }
31+
type impl = [ `Impl of impl_extra ]
32+
33+
type mld = [ `Mld ]
34+
35+
type t = [ impl | intf | mld ] unit
36+
37+
let of_packages ~output_dir ~linked_dir ~index_dir (pkgs : Packages.t list) :
38+
t list =
39+
let linked_dir =
40+
match linked_dir with None -> output_dir | Some dir -> dir
41+
in
42+
let index_dir = match index_dir with None -> output_dir | Some dir -> dir in
43+
(* This isn't a hashtable, but a table of hashes! Yay! *)
44+
let hashtable =
45+
let open Packages in
46+
let h = Util.StringMap.empty in
47+
List.fold_left
48+
(fun h pkg ->
49+
List.fold_left
50+
(fun h lib ->
51+
List.fold_left
52+
(fun h mod_ ->
53+
Util.StringMap.add mod_.m_intf.mif_hash
54+
(pkg, lib.lib_name, mod_) h)
55+
h lib.modules)
56+
h pkg.libraries)
57+
h pkgs
58+
in
59+
(* This one is a hashtable *)
60+
let cache = Hashtbl.create 10 in
61+
let pkg_args_of pkg : pkg_args =
62+
let pages =
63+
[
64+
(pkg.Packages.name, Fpath.(output_dir // pkg.Packages.pkg_dir / "doc"));
65+
]
66+
in
67+
let libs =
68+
List.map
69+
(fun lib ->
70+
( lib.Packages.lib_name,
71+
Fpath.(output_dir // pkg.Packages.pkg_dir / "lib" / lib.lib_name) ))
72+
pkg.libraries
73+
in
74+
{ pages; libs }
75+
in
76+
let pkg_args : pkg_args =
77+
let pages, libs =
78+
List.fold_left
79+
(fun (all_pages, all_libs) pkg ->
80+
let { pages; libs } = pkg_args_of pkg in
81+
(pages :: all_pages, libs :: all_libs))
82+
([], []) pkgs
83+
in
84+
let pages = List.concat pages in
85+
let libs = List.concat libs in
86+
{ pages; libs }
87+
in
88+
let index_of pkg =
89+
let pkg_args = pkg_args_of pkg in
90+
let output_file = Fpath.(index_dir / pkg.name / Odoc.index_filename) in
91+
{ pkg_args; output_file; json = false; search_dir = pkg.pkg_dir }
92+
in
93+
let make_unit ~kind ~rel_dir ~input_file ~prefix ~pkg ~include_dirs : _ unit =
94+
let ( // ) = Fpath.( // ) in
95+
let ( / ) = Fpath.( / ) in
96+
let filename = input_file |> Fpath.rem_ext |> Fpath.basename in
97+
let odoc_dir = output_dir // rel_dir in
98+
let parent_id = rel_dir |> Odoc.id_of_fpath in
99+
let odoc_file = odoc_dir / (prefix ^ filename ^ ".odoc") in
100+
let odocl_file = linked_dir // rel_dir / (prefix ^ filename ^ ".odocl") in
101+
{
102+
output_dir;
103+
pkgname = pkg.Packages.name;
104+
pkg_args;
105+
parent_id;
106+
odoc_dir;
107+
input_file;
108+
odoc_file;
109+
odocl_file;
110+
include_dirs;
111+
kind;
112+
index = index_of pkg;
113+
}
114+
in
115+
let rec build_deps deps =
116+
List.filter_map
117+
(fun (_name, hash) ->
118+
match Util.StringMap.find_opt hash hashtable with
119+
| None -> None
120+
| Some (pkg, lib, mod_) ->
121+
let result = of_intf mod_.m_hidden pkg lib mod_.m_intf in
122+
Hashtbl.add cache mod_.m_intf.mif_hash result;
123+
Some result)
124+
deps
125+
and of_intf hidden pkg libname (intf : Packages.intf) : intf unit =
126+
match Hashtbl.find_opt cache intf.mif_hash with
127+
| Some unit -> unit
128+
| None ->
129+
let open Fpath in
130+
let rel_dir = pkg.Packages.pkg_dir / "lib" / libname in
131+
let include_dirs, kind =
132+
let deps = build_deps intf.mif_deps in
133+
let include_dirs = List.map (fun u -> u.odoc_dir) deps in
134+
let kind = `Intf { hidden; hash = intf.mif_hash; deps } in
135+
(include_dirs, kind)
136+
in
137+
make_unit ~kind ~rel_dir ~prefix:"" ~input_file:intf.mif_path ~pkg
138+
~include_dirs
139+
in
140+
let of_impl pkg libname (impl : Packages.impl) : impl unit option =
141+
let open Fpath in
142+
match impl.mip_src_info with
143+
| None -> None
144+
| Some { src_path } ->
145+
let rel_dir = pkg.Packages.pkg_dir / "lib" / libname in
146+
let include_dirs =
147+
let deps = build_deps impl.mip_deps in
148+
List.map (fun u -> u.odoc_dir) deps
149+
in
150+
let kind =
151+
let src_name = Fpath.filename src_path in
152+
let src_id =
153+
Fpath.(pkg.pkg_dir / "src" / libname / src_name) |> Odoc.id_of_fpath
154+
in
155+
`Impl { src_id; src_path }
156+
in
157+
let unit =
158+
make_unit ~kind ~rel_dir ~input_file:impl.mip_path ~pkg ~include_dirs
159+
~prefix:"impl-"
160+
in
161+
Some unit
162+
in
163+
164+
let of_module pkg libname (m : Packages.modulety) : [ impl | intf ] unit list
165+
=
166+
let i :> [ impl | intf ] unit = of_intf m.m_hidden pkg libname m.m_intf in
167+
let m :> [ impl | intf ] unit list =
168+
Option.bind m.m_impl (of_impl pkg libname) |> Option.to_list
169+
in
170+
i :: m
171+
in
172+
let of_lib pkg (lib : Packages.libty) : [ impl | intf ] unit list =
173+
List.concat_map (of_module pkg lib.lib_name) lib.modules
174+
in
175+
let of_mld pkg (mld : Packages.mld) : mld unit list =
176+
let open Fpath in
177+
let { Packages.mld_path; mld_rel_path } = mld in
178+
let rel_dir =
179+
pkg.Packages.pkg_dir / "doc" // Fpath.parent mld_rel_path
180+
|> Fpath.normalize
181+
in
182+
let include_dirs =
183+
List.map
184+
(fun (lib : Packages.libty) ->
185+
Fpath.(output_dir // pkg.pkg_dir / "lib" / lib.lib_name))
186+
pkg.libraries
187+
in
188+
let include_dirs = (output_dir // rel_dir) :: include_dirs in
189+
let kind = `Mld in
190+
let unit =
191+
make_unit ~kind ~rel_dir ~input_file:mld_path ~pkg ~include_dirs
192+
~prefix:"page-"
193+
in
194+
[ unit ]
195+
in
196+
let of_package (pkg : Packages.t) : t list =
197+
let lib_units :> t list list = List.map (of_lib pkg) pkg.libraries in
198+
let mld_units :> t list list = List.map (of_mld pkg) pkg.mlds in
199+
List.concat (List.rev_append lib_units mld_units)
200+
in
201+
List.concat_map of_package pkgs

0 commit comments

Comments
 (0)