diff --git a/src/lib.ml b/src/lib.ml index 2aefac0cb679..d02144b96fa6 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -18,6 +18,10 @@ module Status = struct | 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 @@ -282,7 +286,7 @@ and overlap = and private_deps_not_allowed = { private_dep : t - ; public_lib : t option + ; pd_loc : Loc.t } and 'a or_error = ('a, exn) result @@ -309,7 +313,7 @@ module Error = struct module Private_deps_not_allowed = struct type nonrec t = private_deps_not_allowed = { private_dep : t - ; public_lib : t option + ; pd_loc : Loc.t } end @@ -582,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 -> @@ -594,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 ~allow_private_deps db name ~loc ~stack in let t = { loc = info.loc ; name = name @@ -640,37 +647,45 @@ let rec instantiate db name (info : Info.t) ~stack ~hidden = Hashtbl.replace db.table ~key:name ~data:res; res -and find db name : (t, Error.Library_not_available.Reason.t) result = - result_of_resolve_status (find_internal db name ~stack:Dep_stack.empty) +and find db name ~allow_private_deps + : (t, Error.Library_not_available.Reason.t) result = + result_of_resolve_status (find_internal db name ~allow_private_deps + ~stack:Dep_stack.empty) -and find_even_when_hidden db name = - match find_internal db name ~stack:Dep_stack.empty with +and find_even_when_hidden db name ~allow_private_deps = + match + find_internal db name ~allow_private_deps ~stack:Dep_stack.empty + with | St_initializing _ -> assert false | St_found t -> Some t | St_not_found -> None | St_hidden (t, _) -> Some t -and find_internal db name ~stack : status = - match Hashtbl.find db.table name with +and find_internal db name ~allow_private_deps ~stack : status = | Some x -> x - | None -> resolve_name db name ~stack + | None -> resolve_name db name ~allow_private_deps ~stack -and resolve_dep db name ~loc ~stack : (t, exn) result = - match find_internal db name ~stack with +and resolve_dep db name ~loc ~allow_private_deps ~stack : (t, exn) result = + match find_internal db name ~allow_private_deps ~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 (status t) then ( + Error (Error (Private_deps_not_allowed + { pd_loc = loc ; private_dep = t })) + ) else ( + Ok t + ) | St_not_found -> Error (Error (Library_not_available { loc; name; reason = Not_found })) | St_hidden (_, hidden) -> Error (Error (Library_not_available { loc; name; reason = Hidden hidden })) -and resolve_name db name ~stack = +and resolve_name db name ~allow_private_deps ~stack = match db.resolve name with | Redirect (db', name') -> begin let db' = Option.value db' ~default:db in - match find_internal db' name' ~stack with + match find_internal db' name' ~allow_private_deps ~stack with | St_initializing _ as x -> x | x -> Hashtbl.add db.table name x; @@ -682,7 +697,7 @@ and resolve_name db name ~stack = let res = match db.parent with | None -> St_not_found - | Some db -> find_internal db name ~stack + | Some db -> find_internal db name ~allow_private_deps ~stack in Hashtbl.add db.table name res; res @@ -690,7 +705,7 @@ and resolve_name db name ~stack = match match db.parent with | None -> St_not_found - | Some db -> find_internal db name ~stack + | Some db -> find_internal db name ~allow_private_deps ~stack with | St_found _ as x -> Hashtbl.add db.table name x; @@ -698,28 +713,28 @@ 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 +and available_internal db name ~allow_private_deps ~stack = + match resolve_dep db name ~allow_private_deps ~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 ~allow_private_deps db name ~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 } -> @@ -727,7 +742,7 @@ and resolve_complex_deps db deps ~stack = match List.find_map choices ~f:(fun { required; forbidden; file } -> if String_set.exists forbidden - ~f:(available_internal db ~stack) then + ~f:(available_internal db ~allow_private_deps ~stack) then None else match @@ -735,7 +750,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 db deps ~allow_private_deps ~stack with | Ok ts -> Some (ts, file) | Error _ -> None) @@ -764,21 +779,21 @@ 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 db names ~allow_private_deps ~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 -> - closure_with_overlap_checks None pps ~stack ~allow_private_deps:true + resolve_simple_deps db pps ~allow_private_deps ~stack >>= fun pps -> + closure_with_overlap_checks None pps ~allow_private_deps ~stack in let deps = let rec loop acc = function @@ -795,7 +810,7 @@ and resolve_user_deps db deps ~pps ~stack = in (deps, pps, resolved_selects) -and closure_with_overlap_checks db ts ~stack ~allow_private_deps = +and closure_with_overlap_checks db ts ~allow_private_deps ~stack = let visited = ref String_map.empty in let res = ref [] in let orig_stack = stack in @@ -816,7 +831,7 @@ and closure_with_overlap_checks db ts ~stack ~allow_private_deps = | None -> Ok () | Some db -> - match find_internal db t.name ~stack with + match find_internal db t.name ~allow_private_deps ~stack with | St_found t' -> if t.unique_id = t'.unique_id then Ok () @@ -832,15 +847,7 @@ and closure_with_overlap_checks db ts ~stack ~allow_private_deps = >>= fun () -> Dep_stack.push stack (to_id t) >>= fun stack -> t.requires >>= fun deps -> - iter deps ~stack >>= fun () -> - (match status t, allow_private_deps with - | Status.Private _, false -> - Error (Error (Private_deps_not_allowed - { private_dep = t - ; public_lib = None - })) - | _, _ -> Ok ()) - >>| fun () -> + iter deps ~stack >>| fun () -> res := t :: !res and iter ts ~stack = match ts with @@ -852,20 +859,16 @@ and closure_with_overlap_checks db ts ~stack ~allow_private_deps = iter ts ~stack >>| fun () -> List.rev !res -let closure_with_overlap_checks db l ~allow_private_deps = - closure_with_overlap_checks db l ~stack:Dep_stack.empty ~allow_private_deps +let closure_with_overlap_checks db l = + closure_with_overlap_checks db l ~stack:Dep_stack.empty -let closure l = closure_with_overlap_checks None l ~allow_private_deps:true +let closure l = closure_with_overlap_checks None l let to_exn res = match res with | Ok x -> x | Error e -> raise e -let requires_exn t = to_exn t.requires -let ppx_runtime_deps_exn t = to_exn t.ppx_runtime_deps -let closure_exn l = to_exn (closure l) - module Compile = struct module Resolved_select = Resolved_select @@ -881,7 +884,7 @@ module Compile = struct let make libs = { direct_requires = libs - ; requires = libs >>= closure + ; requires = libs >>= closure ~allow_private_deps:true ; resolved_selects = [] ; pps = Ok [] ; optional = false @@ -892,12 +895,7 @@ module Compile = struct let for_lib db (t : lib) ~allow_private_deps = { direct_requires = t.requires ; requires = - (match - t.requires >>= closure_with_overlap_checks db ~allow_private_deps - with - | Error (Error (Private_deps_not_allowed e)) -> - Error (Error (Private_deps_not_allowed {e with public_lib = Some t})) - | Error _ | Ok _ as r -> r) + t.requires >>= closure_with_overlap_checks db ~allow_private_deps ; resolved_selects = t.resolved_selects ; pps = t.pps ; optional = t.optional @@ -997,7 +995,7 @@ module DB = struct Findlib.all_packages findlib |> List.map ~f:Findlib.Package.name) - let find = find + let find = find ~allow_private_deps:true let find_even_when_hidden = find_even_when_hidden let resolve t (loc, name) = @@ -1022,24 +1020,23 @@ module DB = struct let available t name = available_internal t name ~stack:Dep_stack.empty let get_compile_info t ?(allow_overlaps=false) ~allow_private_deps name = - match find_even_when_hidden t name with + match find_even_when_hidden t name ~allow_private_deps with | None -> Sexp.code_error "Lib.DB.get_compile_info got library that doesn't exist" [ "name", Sexp.To_sexp.string name ] | Some lib -> let t = Option.some_if (not allow_overlaps) t in - Compile.for_lib ~allow_private_deps t lib + Compile.for_lib t lib ~allow_private_deps 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 >>= - closure_with_overlap_checks - ~allow_private_deps:true + closure_with_overlap_checks ~allow_private_deps:true (Option.some_if (not allow_overlaps) t) in { Compile. @@ -1055,7 +1052,7 @@ module DB = struct let resolve_pps t pps = resolve_simple_deps t (pps : (Loc.t *Jbuild.Pp.t) list :> (Loc.t * string) list) - ~stack:Dep_stack.empty + ~stack:Dep_stack.empty ~allow_private_deps:true let rec all ?(recursive=false) t = let l = @@ -1074,6 +1071,10 @@ end +-----------------------------------------------------------------+ *) module Meta = struct + let requires_exn t = to_exn t.requires + let ppx_runtime_deps_exn t = to_exn t.ppx_runtime_deps + let closure_exn l = to_exn (closure l ~allow_private_deps:false) + let to_names ts = List.fold_left ts ~init:String_set.empty ~f:(fun acc t -> String_set.add acc t.name) @@ -1142,22 +1143,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 -> - let (public_lib, src) = - match t.public_lib with - | None -> - "", "" - | Some lib -> - (lib.name, - Path.to_string_maybe_quoted - (Path.drop_optional_build_context lib.src_dir)) in + | Private_deps_not_allowed (t : private_deps_not_allowed) -> Format.fprintf ppf - "@{Error@}: Public libraries may not have private dependencies.\n\ - Private dependency %S encountered in public library:\n\ - - %S in %s\n" + "%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 - public_lib - src let () = Report_error.register (fun exn -> diff --git a/src/lib.mli b/src/lib.mli index adf001e80f9c..201efeacd02f 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -151,7 +151,7 @@ module Error : sig module Private_deps_not_allowed : sig type nonrec t = { private_dep : t - ; public_lib : t option + ; pd_loc : Loc.t } end @@ -258,9 +258,13 @@ module DB : sig -> string list -> (lib list, exn) result - val find_even_when_hidden : t -> string -> lib option + val find_even_when_hidden + : t + -> string + -> allow_private_deps:bool + -> lib option - val available : t -> string -> bool + val available : t -> string -> allow_private_deps:bool -> bool (** Retreive the compile informations for the given library. Works for libraries that are optional and not available as well. *) @@ -298,7 +302,7 @@ end with type lib := t (** {1 Transitive closure} *) -val closure : L.t -> (L.t, exn) result +val closure : L.t -> allow_private_deps:bool -> (L.t, exn) result (** {1 Sub-systems} *) diff --git a/src/odoc.ml b/src/odoc.ml index c011a24ccdd5..764ac13de5ad 100644 --- a/src/odoc.ml +++ b/src/odoc.ml @@ -214,7 +214,8 @@ let setup_library_rules sctx (lib : Library.t) ~dir ~scope ~modules ~mld_files let doc_dir = Doc.dir sctx lib in let obj_dir, lib_unique_name = let lib = - Option.value_exn (Lib.DB.find_even_when_hidden (Scope.libs scope) lib.name) + Option.value_exn (Lib.DB.find_even_when_hidden (Scope.libs scope) lib.name + ~allow_private_deps:(Option.is_none lib.public)) in let name = let name = Lib.name lib in diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 4d539b1f35b3..5fc3cbed10dd 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -47,7 +47,7 @@ let build_ppx_driver sctx ~lib_db ~dep_kind ~target pps = | Error _ -> None in (driver, - Result.bind resolved_pps ~f:Lib.closure + Result.bind resolved_pps ~f:(Lib.closure ~allow_private_deps:true) |> Build.of_result) in let libs = @@ -81,7 +81,9 @@ let build_ppx_driver sctx ~lib_db ~dep_kind ~target pps = (* Provide a better error for migrate_driver_main given that this is an implicit dependency *) let libs = - match Lib.DB.available lib_db migrate_driver_main with + match + Lib.DB.available ~allow_private_deps:true lib_db migrate_driver_main + with | false -> Build.fail { fail = fun () -> die "@{Error@}: I couldn't find '%s'.\n\ diff --git a/src/super_context.ml b/src/super_context.ml index 8bb6f1cec0af..9b93dad60d0a 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -111,7 +111,10 @@ let create List.filter_map stanzas ~f:(fun stanza -> let keep = match (stanza : Stanza.t) with - | Library lib -> Lib.DB.available (Scope.libs scope) lib.name + | Library lib -> + Lib.DB.available (Scope.libs scope) + ~allow_private_deps:(Option.is_none lib.public) + lib.name | Install _ -> true | _ -> false in @@ -479,7 +482,7 @@ module Action = struct | Some ("lib-available", lib) -> add_lib_dep acc lib Optional; Some (str_exp (string_of_bool ( - Lib.DB.available (Scope.libs scope) lib))) + Lib.DB.available ~allow_private_deps:true (Scope.libs scope) lib))) | Some ("version", s) -> begin match Scope_info.resolve (Scope.info scope) (Package.Name.of_string s) with