Skip to content

Commit

Permalink
Move allow_private_deps to resolve_dep
Browse files Browse the repository at this point in the history
  • Loading branch information
@rgrinberg
rgrinberg committed Mar 11, 2018
1 parent 47559b9 commit cda4d61
Show file tree
Hide file tree
Showing 5 changed files with 90 additions and 89 deletions.
151 changes: 71 additions & 80 deletions src/lib.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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

Expand Down Expand Up @@ -582,19 +586,22 @@ 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 ->
Dep_path.prepend_exn e (Library (info.src_dir, name)))
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
Expand Down Expand Up @@ -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;
Expand All @@ -682,60 +697,60 @@ 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
| Hidden (info, hidden) ->
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;
x
| _ ->
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 } ->
let res, src_fn =
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
let deps =
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)
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 ()
Expand All @@ -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
Expand All @@ -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

Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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) =
Expand All @@ -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.
Expand All @@ -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 =
Expand All @@ -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)
Expand Down Expand Up @@ -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 ->
"<unknown>", "<unknown>"
| 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>Error@}: Public libraries may not have private dependencies.\n\
Private dependency %S encountered in public library:\n\
- %S in %s\n"
"%a@{<error>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 ->
Expand Down
Loading

0 comments on commit cda4d61

Please sign in to comment.