Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Further voodoo #1252

Merged
merged 8 commits into from
Dec 18, 2024
Merged
Changes from 1 commit
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Prev Previous commit
Next Next commit
Driver: unify some shared logic
jonludlam committed Dec 18, 2024
commit ff927b37f1b35fffb010a123136278e093d658ed
87 changes: 46 additions & 41 deletions src/driver/opam.ml
Original file line number Diff line number Diff line change
@@ -146,7 +146,47 @@ let pp_fpaths_of_package fmt l =
docs)
l

let classify_contents prefix only_package contents =
let classify_docs prefix only_package contents =
let pkg_match pkg =
match only_package with None -> true | Some p -> p = pkg
in

let is_dir f =
try Sys.is_directory (Fpath.to_string f) with Sys_error _ -> false
in

List.fold_left
(fun acc fpath ->
match Fpath.segs fpath with
| "doc" :: pkg :: "odoc-pages" :: _ :: _
when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
let kind =
match Fpath.get_ext fpath with ".mld" -> `Mld | _ -> `Asset
in
let rel_path =
Fpath.rem_prefix Fpath.(v "doc" / pkg / "odoc-pages") fpath
|> Option.get
in
{ kind; file = Fpath.(prefix // fpath); rel_path } :: acc
| "doc" :: pkg :: "odoc-assets" :: _ :: _
when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
let rel_path =
Fpath.rem_prefix Fpath.(v "doc" / pkg / "odoc-assets") fpath
|> Option.get
in
let rel_path = Fpath.(v "_assets" // rel_path) in
{ kind = `Asset; file = Fpath.(prefix // fpath); rel_path } :: acc
| [ "doc"; pkg; _ ]
when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
Logs.debug (fun m -> m "Found other doc: %a" Fpath.pp fpath);
let rel_path = Fpath.base fpath in
{ kind = `Other; file = Fpath.(prefix // fpath); rel_path } :: acc
| _ -> acc)
[] contents

let classify_libs prefix only_package contents =
let pkg_match pkg =
match only_package with None -> true | Some p -> p = pkg
in
@@ -162,44 +202,7 @@ let classify_contents prefix only_package contents =
| _ -> set)
Fpath.Set.empty contents
in

let is_dir f =
try Sys.is_directory (Fpath.to_string f) with Sys_error _ -> false
in

let docs =
List.fold_left
(fun acc fpath ->
match Fpath.segs fpath with
| "doc" :: pkg :: "odoc-pages" :: _ :: _
when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
let kind =
match Fpath.get_ext fpath with ".mld" -> `Mld | _ -> `Asset
in
let rel_path =
Fpath.rem_prefix Fpath.(v "doc" / pkg / "odoc-pages") fpath
|> Option.get
in
{ kind; file = Fpath.(prefix // fpath); rel_path } :: acc
| "doc" :: pkg :: "odoc-assets" :: _ :: _
when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
Logs.debug (fun m -> m "Found odoc page: %a" Fpath.pp fpath);
let rel_path =
Fpath.rem_prefix Fpath.(v "doc" / pkg / "odoc-assets") fpath
|> Option.get
in
let rel_path = Fpath.(v "_assets" // rel_path) in
{ kind = `Asset; file = Fpath.(prefix // fpath); rel_path } :: acc
| [ "doc"; pkg; _ ]
when pkg_match pkg && not (is_dir Fpath.(prefix // fpath)) ->
Logs.debug (fun m -> m "Found other doc: %a" Fpath.pp fpath);
let rel_path = Fpath.base fpath in
{ kind = `Other; file = Fpath.(prefix // fpath); rel_path } :: acc
| _ -> acc)
[] contents
in
(libs, docs)
libs

let dune_overrides () =
let ocamlpath = Sys.getenv_opt "OCAMLPATH" in
@@ -243,7 +246,8 @@ let dune_overrides () =
(Util.StringSet.elements packages));
Util.StringSet.fold
(fun pkg acc ->
let libs, docs = classify_contents base (Some pkg) contents in
let libs = classify_libs base (Some pkg) contents in
let docs = classify_docs base (Some pkg) contents in
Logs.debug (fun m ->
m "pkg %s Found %d docs" pkg (List.length docs));
({ name = pkg; version = "dev" }, { libs; docs }) :: acc)
@@ -262,7 +266,8 @@ let pkg_to_dir_map () =
List.map
(fun p ->
let contents = pkg_contents p in
let libs, docs = classify_contents (Fpath.v prefix) None contents in
let libs = classify_libs (Fpath.v prefix) None contents in
let docs = classify_docs (Fpath.v prefix) None contents in
(p, { libs; docs }))
pkgs
in
2 changes: 2 additions & 0 deletions src/driver/opam.mli
Original file line number Diff line number Diff line change
@@ -14,6 +14,8 @@ type package_of_fpath = package Fpath.map
type fpaths_of_package = (package * installed_files) list
val all_opam_packages : unit -> package list

val classify_docs : Fpath.t -> string option -> Fpath.t list -> doc_file list

val deps : string list -> package list
val pkg_to_dir_map : unit -> fpaths_of_package * package_of_fpath
val pp : Format.formatter -> package -> unit
35 changes: 17 additions & 18 deletions src/driver/packages.ml
Original file line number Diff line number Diff line change
@@ -271,22 +271,21 @@ end

(* Construct the list of mlds and assets from a package name and its list of pages *)
let mk_mlds docs =
let mlds, assets =
List.fold_left
(fun (mlds, assets) doc ->
match doc.Opam.kind with
| `Mld ->
( { mld_path = doc.Opam.file; mld_rel_path = doc.Opam.rel_path }
:: mlds,
assets )
| `Asset ->
( mlds,
{ asset_path = doc.Opam.file; asset_rel_path = doc.Opam.rel_path }
:: assets )
| `Other -> (mlds, assets))
([], []) docs
in
(mlds, assets)
List.fold_left
(fun (mlds, assets, others) doc ->
match doc.Opam.kind with
| `Mld ->
( { mld_path = doc.Opam.file; mld_rel_path = doc.Opam.rel_path }
:: mlds,
assets,
others )
| `Asset ->
( mlds,
{ asset_path = doc.Opam.file; asset_rel_path = doc.Opam.rel_path }
:: assets,
others )
| `Other -> (mlds, assets, doc.Opam.file :: others))
([], [], []) docs

let fix_missing_deps pkgs =
let lib_name_by_hash =
@@ -396,7 +395,7 @@ let of_libs ~packages_dir libs =
pkg = pkg')
opam_map
in
let mlds, assets = mk_mlds docs in
let mlds, assets, _ = mk_mlds docs in
Some
{
name = pkg.name;
@@ -457,7 +456,7 @@ let of_packages ~packages_dir packages =
in
let pkg_dir = pkg_dir packages_dir pkg.name in
let config = Global_config.load pkg.name in
let mlds, assets = mk_mlds files.docs in
let mlds, assets, _ = mk_mlds files.docs in
let selected = List.mem pkg.name packages in
let remaps =
if selected then []
2 changes: 2 additions & 0 deletions src/driver/packages.mli
Original file line number Diff line number Diff line change
@@ -84,6 +84,8 @@ val pp : Format.formatter -> t -> unit

type set = t Util.StringMap.t

val mk_mlds : Opam.doc_file list -> mld list * asset list * Fpath.t list

val of_libs : packages_dir:Fpath.t option -> Util.StringSet.t -> set
(** Turns a set of libraries into a map from package name to package *)

49 changes: 3 additions & 46 deletions src/driver/voodoo.ml
Original file line number Diff line number Diff line change
@@ -67,50 +67,6 @@ let metas_of_pkg pkg =
filename = "META")
pkg.files

(* Given a [pkg] and an output [pkg_path], returns a pair of lists of assets an mlds *)
let assets_and_mlds_of_pkg pkg_path pkg =
pkg.files
|> List.filter_map (fun p ->
let prefix = Fpath.(v "doc" / pkg.name / "odoc-pages") in
let asset_prefix = Fpath.(v "doc" / pkg.name / "odoc-assets") in
let check_name pkg_name =
if pkg_name <> pkg.name then (
Logs.err (fun k ->
k
"Error: name in 'doc' dir does not match package name: %s \
<> %s"
pkg_name pkg.name);
None)
else Some ()
in
let ( >>= ) = Option.bind in
match Fpath.segs p with
| "doc" :: pkg_name :: "odoc-pages" :: _ :: _ -> (
check_name pkg_name >>= fun () ->
match Fpath.rem_prefix prefix p with
| None -> None
| Some rel_path ->
let path = Fpath.(pkg_path // p) in
if Fpath.has_ext "mld" p then
Some
(`M { Packages.mld_path = path; mld_rel_path = rel_path })
else
Some
(`A
{ Packages.asset_path = path; asset_rel_path = rel_path })
)
| "doc" :: pkg_name :: "odoc-assets" :: _ :: _ -> (
check_name pkg_name >>= fun () ->
match Fpath.rem_prefix asset_prefix p with
| None -> None
| Some asset_rel_path ->
let asset_path = Fpath.(pkg_path // p) in
Some (`A { Packages.asset_path; asset_rel_path }))
| _ -> None)
|> List.partition_map (function
| `A asset -> Either.Left asset
| `M mld -> Either.Right mld)

let process_package pkg =
let metas = metas_of_pkg pkg in

@@ -139,7 +95,8 @@ let process_package pkg =
Fmt.(list ~sep:comma (pair ~sep:comma string ss_pp))
(Util.StringMap.bindings all_lib_deps));

let assets, mlds = assets_and_mlds_of_pkg pkg_path pkg in
let docs = Opam.classify_docs pkg_path (Some pkg.name) pkg.files in
let mlds, assets, other_docs = Packages.mk_mlds docs in

let config =
let config_file =
@@ -231,7 +188,7 @@ let process_package pkg =
assets;
selected = true;
remaps = [];
other_docs = [];
other_docs;
pkg_dir = top_dir pkg;
config;
}