From 0823f9d803b9fe46b3083ffb288ecd90a187cb06 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 12 Mar 2018 23:38:23 +0700 Subject: [PATCH] allow_private_deps flag Flag to guard public dependencies from acquiring private ones --- src/lib.ml | 80 ++++++++++++++++++++++++++++++++++++++++------------- src/lib.mli | 10 +++++++ 2 files changed, 71 insertions(+), 19 deletions(-) diff --git a/src/lib.ml b/src/lib.ml index 02db9ca1..dc83e14d 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -10,6 +10,18 @@ module Status = struct | Installed | Public | Private of Jbuild.Scope_info.Name.t + + let pp ppf t = + Format.pp_print_string ppf + (match t with + | Installed -> "installed" + | Public -> "public" + | Private s -> + sprintf "private (%s)" (Jbuild.Scope_info.Name.to_string s)) + + let is_private = function + | Private _ -> true + | Installed | Public -> false end module Info = struct @@ -254,6 +266,7 @@ and error = | Dependency_cycle of (Path.t * string) list | Conflict of conflict | Overlap of overlap + | Private_deps_not_allowed of private_deps_not_allowed and resolve_result = | Not_found @@ -271,6 +284,11 @@ and overlap = ; installed : t * Dep_path.Entry.t list } +and private_deps_not_allowed = + { private_dep : t + ; pd_loc : Loc.t + } + and 'a or_error = ('a, exn) result type lib = t @@ -292,12 +310,20 @@ module Error = struct } end + module Private_deps_not_allowed = struct + type nonrec t = private_deps_not_allowed = + { private_dep : t + ; pd_loc : Loc.t + } + end + type t = error = | Library_not_available of Library_not_available.t | No_solution_found_for_select of No_solution_found_for_select.t | Dependency_cycle of (Path.t * string) list | Conflict of Conflict.t | Overlap of Overlap.t + | Private_deps_not_allowed of Private_deps_not_allowed.t end exception Error of Error.t @@ -560,11 +586,13 @@ let rec instantiate db name (info : Info.t) ~stack ~hidden = (* Add [id] to the table, to detect loops *) Hashtbl.add db.table name (St_initializing id); + let allow_private_deps = Status.is_private info.status in + let requires, pps, resolved_selects = - resolve_user_deps db info.requires ~pps:info.pps ~stack + resolve_user_deps db info.requires ~allow_private_deps ~pps:info.pps ~stack in let ppx_runtime_deps = - resolve_simple_deps db info.ppx_runtime_deps ~stack + resolve_simple_deps db info.ppx_runtime_deps ~allow_private_deps ~stack in let map_error x = Result.map_error x ~f:(fun e -> @@ -572,7 +600,8 @@ let rec instantiate db name (info : Info.t) ~stack ~hidden = in let requires = map_error requires in let ppx_runtime_deps = map_error ppx_runtime_deps in - let resolve (loc, name) = resolve_dep db name ~loc ~stack in + let resolve (loc, name) = + resolve_dep db name ~allow_private_deps ~loc ~stack in let t = { loc = info.loc ; name = name @@ -633,12 +662,16 @@ and find_internal db name ~stack : status = | Some x -> x | None -> resolve_name db name ~stack -and resolve_dep db name ~loc ~stack : (t, exn) result = +and resolve_dep db name ~allow_private_deps ~loc ~stack : (t, exn) result = match find_internal db name ~stack with | St_initializing id -> Error (Dep_stack.dependency_cycle stack id) | St_found t -> - Ok t + if (not allow_private_deps) && Status.is_private t.status then ( + failwith "" + ) else ( + Ok t + ) | St_not_found -> Error (Error (Library_not_available { loc; name; reason = Not_found })) | St_hidden (_, hidden) -> @@ -677,27 +710,27 @@ and resolve_name db name ~stack = instantiate db name info ~stack ~hidden:(Some hidden) and available_internal db name ~stack = - match resolve_dep db name ~loc:Loc.none ~stack with + match resolve_dep db name ~allow_private_deps:true ~loc:Loc.none ~stack with | Ok _ -> true | Error _ -> false -and resolve_simple_deps db names ~stack = +and resolve_simple_deps db names ~allow_private_deps ~stack = let rec loop acc = function | [] -> Ok (List.rev acc) | (loc, name) :: names -> - resolve_dep db name ~loc ~stack >>= fun x -> + resolve_dep db name ~allow_private_deps ~loc ~stack >>= fun x -> loop (x :: acc) names in loop [] names -and resolve_complex_deps db deps ~stack = +and resolve_complex_deps db deps ~allow_private_deps ~stack = let res, resolved_selects = List.fold_left deps ~init:(Ok [], []) ~f:(fun (acc_res, acc_selects) dep -> let res, acc_selects = match (dep : Jbuild.Lib_dep.t) with | Direct (loc, name) -> let res = - resolve_dep db name ~loc ~stack >>| fun x -> [x] + resolve_dep db name ~allow_private_deps ~loc ~stack >>| fun x -> [x] in (res, acc_selects) | Select { result_fn; choices; loc } -> @@ -713,7 +746,7 @@ and resolve_complex_deps db deps ~stack = String_set.fold required ~init:[] ~f:(fun x acc -> (Loc.none, x) :: acc) in - resolve_simple_deps db deps ~stack + resolve_simple_deps ~allow_private_deps db deps ~stack with | Ok ts -> Some (ts, file) | Error _ -> None) @@ -742,20 +775,23 @@ and resolve_complex_deps db deps ~stack = in (res, resolved_selects) -and resolve_deps db deps ~stack = +and resolve_deps db deps ~allow_private_deps ~stack = match (deps : Info.Deps.t) with - | Simple names -> (resolve_simple_deps db names ~stack, []) - | Complex names -> resolve_complex_deps db names ~stack + | Simple names -> + (resolve_simple_deps db names ~allow_private_deps ~stack, []) + | Complex names -> + resolve_complex_deps ~allow_private_deps db names ~stack -and resolve_user_deps db deps ~pps ~stack = - let deps, resolved_selects = resolve_deps db deps ~stack in +and resolve_user_deps db deps ~allow_private_deps ~pps ~stack = + let deps, resolved_selects = + resolve_deps db deps ~allow_private_deps ~stack in let deps, pps = match pps with | [] -> (deps, Ok []) | pps -> let pps = let pps = (pps : (Loc.t * Jbuild.Pp.t) list :> (Loc.t * string) list) in - resolve_simple_deps db pps ~stack >>= fun pps -> + resolve_simple_deps db pps ~allow_private_deps ~stack >>= fun pps -> closure_with_overlap_checks None pps ~stack in let deps = @@ -996,7 +1032,7 @@ module DB = struct let resolve_user_written_deps t ?(allow_overlaps=false) deps ~pps = let res, pps, resolved_selects = resolve_user_deps t (Info.Deps.of_lib_deps deps) ~pps - ~stack:Dep_stack.empty + ~stack:Dep_stack.empty ~allow_private_deps:true in let requires = res @@ -1014,7 +1050,7 @@ module DB = struct } let resolve_pps t pps = - resolve_simple_deps t + resolve_simple_deps t ~allow_private_deps:true (pps : (Loc.t *Jbuild.Pp.t) list :> (Loc.t * string) list) ~stack:Dep_stack.empty @@ -1103,6 +1139,12 @@ let report_lib_error ppf (e : Error.t) = Format.fprintf ppf "-> %S in %s" name (Path.to_string_maybe_quoted path))) cycle + | Private_deps_not_allowed (t : private_deps_not_allowed) -> + Format.fprintf ppf + "%a@{Error@}: Public libraries may not have private dependencies.\ + \nPrivate dependency %S encountered in public library:\n" + Loc.print t.pd_loc + t.private_dep.name let () = Report_error.register (fun exn -> diff --git a/src/lib.mli b/src/lib.mli index 335cb65f..d35f55f3 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -37,6 +37,8 @@ module Status : sig | Installed | Public | Private of Jbuild.Scope_info.Name.t + + val pp : t Fmt.t end val status : t -> Status.t @@ -146,12 +148,20 @@ module Error : sig } end + module Private_deps_not_allowed : sig + type nonrec t = + { private_dep : t + ; pd_loc : Loc.t + } + end + type t = | Library_not_available of Library_not_available.t | No_solution_found_for_select of No_solution_found_for_select.t | Dependency_cycle of (Path.t * string) list | Conflict of Conflict.t | Overlap of Overlap.t + | Private_deps_not_allowed of Private_deps_not_allowed.t end exception Error of Error.t