From ba576961507aaca3ebcb39f8495597ef8f258cf0 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 23 Jul 2019 21:56:38 +0700 Subject: [PATCH] Remove globs from odoc Previously, the list of odocs per package and library was obtained by globing the odocs target dir. That's a bit dodgy because it relied on all the rules that generated such odocs to fire. The new code just simply generates the list of odocs from the sources without making any assumptions. Signed-off-by: Rudi Grinberg --- src/odoc.ml | 100 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 58 insertions(+), 42 deletions(-) diff --git a/src/odoc.ml b/src/odoc.ml index e7a9b315ee9..aa60f733a36 100644 --- a/src/odoc.ml +++ b/src/odoc.ml @@ -373,17 +373,52 @@ let static_html ctx = ; toplevel_index ctx ] -let odocs = - let odoc_pred = - Glob.of_string_exn (Loc.of_pos __POS__) "*.odoc" - |> Glob.to_pred - in - fun ctx target -> - let dir = Paths.odocs ctx target in - File_selector.create ~dir:(Path.build dir) odoc_pred - |> Build_system.eval_pred - |> Path.Set.fold ~init:[] ~f:(fun d acc -> - create_odoc ctx (Path.as_in_build_dir_exn d) ~target :: acc) +let check_mlds_no_dupes ~pkg ~mlds = + match + List.map mlds ~f:(fun mld -> + (Filename.chop_extension (Path.Build.basename mld), mld)) + |> String.Map.of_list + with + | Ok m -> m + | Error (_, p1, p2) -> + User_error.raise + [ Pp.textf "Package %s has two mld's with the same basename %s, %s" + (Package.Name.to_string pkg) + (Path.to_string_maybe_quoted (Path.build p1)) + (Path.to_string_maybe_quoted (Path.build p2)) + ] + +let odocs sctx target = + let ctx = Super_context.context sctx in + let dir = Paths.odocs ctx target in + match target with + | Pkg pkg -> + let mlds = + let mlds = Packages.mlds sctx pkg in + let mlds = check_mlds_no_dupes ~pkg ~mlds in + if String.Map.mem mlds "index" then + mlds + else + let gen_mld = Paths.gen_mld_dir ctx pkg ++ "index.mld" in + String.Map.add_exn mlds "index" gen_mld + in + String.Map.values mlds + |> List.map ~f:(fun mld -> + Mld.create mld + |> Mld.odoc_file ~doc_dir:dir + |> create_odoc ctx ~target) + | Lib lib -> + let info = Lib.Local.info lib in + let dir = Lib_info.src_dir info in + let modules = + let name = Lib_info.name info in + Dir_contents.get sctx ~dir + |> Dir_contents.modules_of_library ~name + in + let obj_dir = Lib_info.obj_dir info in + Modules.fold_no_vlib modules ~init:[] ~f:(fun m acc -> + let odoc = Obj_dir.Module.odoc obj_dir m in + create_odoc ctx ~target odoc :: acc) let setup_lib_html_rules_def = let module Input = struct @@ -407,7 +442,7 @@ let setup_lib_html_rules_def = in let f (sctx, lib, requires) = let ctx = Super_context.context sctx in - let odocs = odocs ctx (Lib lib) in + let odocs = odocs sctx (Lib lib) in let pkg = Lib.package (Lib.Local.to_lib lib) in List.iter odocs ~f:(setup_html sctx ~pkg ~requires); let html_files = List.map ~f:(fun o -> Path.build o.html_file) odocs in @@ -467,12 +502,12 @@ let setup_pkg_html_rules_def = Lib.closure libs ~linking:false in let ctx = Super_context.context sctx in List.iter libs ~f:(setup_lib_html_rules sctx ~requires); - let pkg_odocs = odocs ctx (Pkg pkg) in + let pkg_odocs = odocs sctx (Pkg pkg) in List.iter pkg_odocs ~f:(setup_html sctx ~pkg:(Some pkg) ~requires); let odocs = List.concat ( pkg_odocs - :: (List.map libs ~f:(fun lib -> odocs ctx (Lib lib))) + :: (List.map libs ~f:(fun lib -> odocs sctx (Lib lib))) ) in let html_files = List.map ~f:(fun o -> (Path.build o.html_file)) odocs in let static_html = List.map ~f:Path.build (static_html ctx) in @@ -543,44 +578,26 @@ let default_index ~pkg entry_modules = ); Buffer.contents b -let check_mlds_no_dupes ~pkg ~mlds = - match - List.map mlds ~f:(fun mld -> - (Filename.chop_extension (Path.Build.basename mld), mld)) - |> String.Map.of_list - with - | Ok m -> m - | Error (_, p1, p2) -> - User_error.raise - [ Pp.textf "Package %s has two mld's with the same basename %s, %s" - (Package.Name.to_string pkg) - (Path.to_string_maybe_quoted (Path.build p1)) - (Path.to_string_maybe_quoted (Path.build p2)) - ] - let setup_package_odoc_rules_def = let module Input = struct module Super_context = Super_context.As_memo_key - type t = Super_context.t * Package.Name.t * Path.Build.t list + type t = Super_context.t * Package.Name.t - let hash (sctx, p, ps) = + let hash (sctx, p) = Hashtbl.hash ( Super_context.hash sctx , Package.Name.hash p - , List.hash Path.Build.hash ps ) - let equal (s1, x1, y1) (s2, x2, y2) = + let equal (s1, x1) (s2, x2) = Super_context.equal s1 s2 && Package.Name.equal x1 x2 - && List.equal Path.Build.equal y1 y2 - let to_dyn (_, name, paths) = + let to_dyn (_, name) = Dyn.Tuple [ Package.Name.to_dyn name - ; Dyn.List (List.map ~f:Path.Build.to_dyn paths) ] end in @@ -591,7 +608,8 @@ let setup_package_odoc_rules_def = ~input:(module Input) ~visibility:Hidden Sync - (fun (sctx, pkg, mlds) -> + (fun (sctx, pkg) -> + let mlds = Packages.mlds sctx pkg in let mlds = check_mlds_no_dupes ~pkg ~mlds in let ctx = Super_context.context sctx in let mlds = @@ -614,8 +632,8 @@ let setup_package_odoc_rules_def = ) in Dep.setup_deps ctx (Pkg pkg) (Path.set_of_build_paths_list odocs)) -let setup_package_odoc_rules sctx ~pkg ~mlds = - Memo.With_implicit_output.exec setup_package_odoc_rules_def (sctx, pkg, mlds) +let setup_package_odoc_rules sctx ~pkg = + Memo.With_implicit_output.exec setup_package_odoc_rules_def (sctx, pkg) let init sctx = let stanzas = SC.stanzas sctx in @@ -661,9 +679,7 @@ let gen_rules sctx ~dir:_ rest = let pkg = Package.Name.of_string pkg in let packages = Super_context.packages sctx in Package.Name.Map.find packages pkg - |> Option.iter ~f:(fun _ -> - let mlds = Packages.mlds sctx pkg in - setup_package_odoc_rules sctx ~pkg ~mlds) + |> Option.iter ~f:(fun _ -> setup_package_odoc_rules sctx ~pkg) | "_odoc" :: "lib" :: lib :: _ -> let lib, lib_db = Scope_key.of_string sctx lib in (* diml: why isn't [None] some kind of error here? *)