matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

allow_private_deps flag 

Flag to guard public dependencies from acquiring private ones
This commit is contained in:
Rudi Grinberg 2018-03-12 23:38:23 +07:00
parent a9b84a6259
commit 0823f9d803
2 changed files with 71 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
src/lib.ml
View File

@ -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>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 ->

10
src/lib.mli
View File

@ -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