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? *)