2016-12-02 13:54:32 +00:00
|
|
|
open Import
|
2018-02-20 11:46:10 +00:00
|
|
|
open Result.O
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Raw library information |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
2018-02-07 17:51:40 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
module Status = struct
|
|
|
|
type t =
|
|
|
|
| Installed
|
2018-03-16 03:10:09 +00:00
|
|
|
| Public of Package.t
|
2018-02-20 11:46:10 +00:00
|
|
|
| Private of Jbuild.Scope_info.Name.t
|
2018-03-12 16:38:23 +00:00
|
|
|
|
|
|
|
let pp ppf t =
|
|
|
|
Format.pp_print_string ppf
|
|
|
|
(match t with
|
|
|
|
| Installed -> "installed"
|
2018-03-16 03:10:09 +00:00
|
|
|
| Public _ -> "public"
|
2018-03-12 16:38:23 +00:00
|
|
|
| Private s ->
|
|
|
|
sprintf "private (%s)" (Jbuild.Scope_info.Name.to_string s))
|
|
|
|
|
|
|
|
let is_private = function
|
|
|
|
| Private _ -> true
|
2018-03-16 03:10:09 +00:00
|
|
|
| Installed | Public _ -> false
|
2016-12-15 11:20:46 +00:00
|
|
|
end
|
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
module Info = struct
|
|
|
|
module Deps = struct
|
|
|
|
type t =
|
2018-02-23 09:17:37 +00:00
|
|
|
| Simple of (Loc.t * string) list
|
2018-02-20 11:46:10 +00:00
|
|
|
| Complex of Jbuild.Lib_dep.t list
|
|
|
|
|
|
|
|
let of_lib_deps deps =
|
|
|
|
let rec loop acc (deps : Jbuild.Lib_dep.t list) =
|
|
|
|
match deps with
|
2018-02-23 09:17:37 +00:00
|
|
|
| [] -> Some (List.rev acc)
|
|
|
|
| Direct x :: deps -> loop (x :: acc) deps
|
|
|
|
| Select _ :: _ -> None
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
|
|
|
match loop [] deps with
|
|
|
|
| Some l -> Simple l
|
|
|
|
| None -> Complex deps
|
2018-02-23 09:17:37 +00:00
|
|
|
|
|
|
|
let to_lib_deps = function
|
|
|
|
| Simple l -> List.map l ~f:Jbuild.Lib_dep.direct
|
|
|
|
| Complex l -> l
|
2018-02-20 11:46:10 +00:00
|
|
|
end
|
|
|
|
|
2016-12-02 13:54:32 +00:00
|
|
|
type t =
|
2018-02-20 11:46:10 +00:00
|
|
|
{ loc : Loc.t
|
|
|
|
; kind : Jbuild.Library.Kind.t
|
|
|
|
; status : Status.t
|
|
|
|
; src_dir : Path.t
|
|
|
|
; obj_dir : Path.t
|
|
|
|
; version : string option
|
|
|
|
; synopsis : string option
|
|
|
|
; archives : Path.t list Mode.Dict.t
|
|
|
|
; plugins : Path.t list Mode.Dict.t
|
|
|
|
; foreign_archives : Path.t list Mode.Dict.t
|
|
|
|
; jsoo_runtime : Path.t list
|
|
|
|
; requires : Deps.t
|
2018-02-23 09:17:37 +00:00
|
|
|
; ppx_runtime_deps : (Loc.t * string) list
|
|
|
|
; pps : (Loc.t * Jbuild.Pp.t) list
|
2018-02-20 11:46:10 +00:00
|
|
|
; optional : bool
|
2018-02-23 09:17:37 +00:00
|
|
|
; virtual_deps : (Loc.t * string) list
|
|
|
|
; sub_systems : Jbuild.Sub_system_info.t Sub_system_name.Map.t
|
2018-02-20 11:46:10 +00:00
|
|
|
}
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let user_written_deps t =
|
|
|
|
List.fold_left t.virtual_deps
|
|
|
|
~init:(Deps.to_lib_deps t.requires)
|
|
|
|
~f:(fun acc s -> Jbuild.Lib_dep.Direct s :: acc)
|
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
let of_library_stanza ~dir (conf : Jbuild.Library.t) =
|
|
|
|
let archive_file ext = Path.relative dir (conf.name ^ ext) in
|
|
|
|
let archive_files ~f_ext =
|
|
|
|
Mode.Dict.of_func (fun ~mode -> [archive_file (f_ext mode)])
|
|
|
|
in
|
|
|
|
let stubs =
|
|
|
|
if Jbuild.Library.has_stubs conf then
|
|
|
|
[Jbuild.Library.stubs_archive conf ~dir ~ext_lib:""]
|
|
|
|
else
|
|
|
|
[]
|
|
|
|
in
|
|
|
|
let jsoo_runtime =
|
|
|
|
List.map conf.buildable.js_of_ocaml.javascript_files
|
|
|
|
~f:(Path.relative dir)
|
|
|
|
in
|
|
|
|
let status =
|
|
|
|
match conf.public with
|
|
|
|
| None -> Status.Private conf.scope_name
|
2018-03-16 03:10:09 +00:00
|
|
|
| Some p -> Public p.package
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
|
|
|
let foreign_archives =
|
|
|
|
{ Mode.Dict.
|
|
|
|
byte = stubs
|
|
|
|
; native = Path.relative dir conf.name :: stubs
|
|
|
|
}
|
|
|
|
in
|
|
|
|
{ loc = conf.buildable.loc
|
|
|
|
; kind = conf.kind
|
|
|
|
; src_dir = dir
|
|
|
|
; obj_dir = Utils.library_object_directory ~dir conf.name
|
|
|
|
; version = None
|
|
|
|
; synopsis = conf.synopsis
|
|
|
|
; archives = archive_files ~f_ext:Mode.compiled_lib_ext
|
|
|
|
; plugins = archive_files ~f_ext:Mode.plugin_ext
|
|
|
|
; optional = conf.optional
|
|
|
|
; foreign_archives
|
|
|
|
; jsoo_runtime
|
|
|
|
; status
|
2018-02-23 09:17:37 +00:00
|
|
|
; virtual_deps = conf.virtual_deps
|
2018-02-20 11:46:10 +00:00
|
|
|
; requires = Deps.of_lib_deps conf.buildable.libraries
|
|
|
|
; ppx_runtime_deps = conf.ppx_runtime_libraries
|
|
|
|
; pps = Jbuild.Preprocess_map.pps conf.buildable.preprocess
|
2018-02-23 09:17:37 +00:00
|
|
|
; sub_systems = conf.sub_systems
|
2018-02-20 11:46:10 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
let of_findlib_package pkg =
|
|
|
|
let module P = Findlib.Package in
|
2018-02-23 09:17:37 +00:00
|
|
|
let loc = Loc.in_file (Path.to_string (P.meta_file pkg)) in
|
|
|
|
let add_loc x = (loc, x) in
|
|
|
|
let sub_systems =
|
|
|
|
match P.dune_file pkg with
|
|
|
|
| None -> Sub_system_name.Map.empty
|
|
|
|
| Some fn ->
|
|
|
|
Installed_dune_file.load ~fname:(Path.to_string fn)
|
|
|
|
in
|
|
|
|
{ loc = loc
|
2018-02-20 11:46:10 +00:00
|
|
|
; kind = Normal
|
|
|
|
; src_dir = P.dir pkg
|
|
|
|
; obj_dir = P.dir pkg
|
|
|
|
; version = P.version pkg
|
|
|
|
; synopsis = P.description pkg
|
|
|
|
; archives = P.archives pkg
|
|
|
|
; plugins = P.plugins pkg
|
|
|
|
; jsoo_runtime = P.jsoo_runtime pkg
|
2018-02-23 09:17:37 +00:00
|
|
|
; requires = Simple (List.map (P.requires pkg) ~f:add_loc)
|
|
|
|
; ppx_runtime_deps = List.map (P.ppx_runtime_deps pkg) ~f:add_loc
|
2018-02-20 11:46:10 +00:00
|
|
|
; pps = []
|
2018-02-23 09:17:37 +00:00
|
|
|
; virtual_deps = []
|
2018-02-20 11:46:10 +00:00
|
|
|
; optional = false
|
|
|
|
; status = Installed
|
|
|
|
; (* We don't know how these are named for external libraries *)
|
|
|
|
foreign_archives = Mode.Dict.make_both []
|
2018-02-23 09:17:37 +00:00
|
|
|
; sub_systems = sub_systems
|
2018-02-20 11:46:10 +00:00
|
|
|
}
|
|
|
|
end
|
|
|
|
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Types |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
|
|
|
module Error0 = struct
|
|
|
|
module Library_not_available = struct
|
|
|
|
module Reason = struct
|
|
|
|
module Hidden = struct
|
|
|
|
type t =
|
|
|
|
{ name : string
|
2018-02-28 18:50:48 +00:00
|
|
|
; path : Path.t
|
2018-02-20 11:46:10 +00:00
|
|
|
; reason : string
|
|
|
|
}
|
|
|
|
end
|
|
|
|
|
|
|
|
type t =
|
|
|
|
| Not_found
|
|
|
|
| Hidden of Hidden.t
|
|
|
|
|
|
|
|
let to_string = function
|
|
|
|
| Not_found -> "not found"
|
2018-02-28 18:50:48 +00:00
|
|
|
| Hidden { path; reason; _ } ->
|
2018-02-20 11:46:10 +00:00
|
|
|
sprintf "in %s is hidden (%s)"
|
2018-02-28 18:50:48 +00:00
|
|
|
(Path.to_string_maybe_quoted path) reason
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
let pp ppf t = Format.pp_print_string ppf (to_string t)
|
|
|
|
end
|
|
|
|
|
|
|
|
type t =
|
2018-02-23 09:17:37 +00:00
|
|
|
{ loc : Loc.t
|
|
|
|
; name : string
|
2018-02-20 11:46:10 +00:00
|
|
|
; reason : Reason.t
|
|
|
|
}
|
|
|
|
end
|
|
|
|
|
|
|
|
module No_solution_found_for_select = struct
|
|
|
|
type t = { loc : Loc.t }
|
|
|
|
end
|
|
|
|
end
|
|
|
|
|
|
|
|
module Resolved_select = struct
|
|
|
|
type t =
|
|
|
|
{ src_fn : (string, Error0.No_solution_found_for_select.t) result
|
|
|
|
; dst_fn : string
|
|
|
|
}
|
|
|
|
end
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
type sub_system = ..
|
|
|
|
|
|
|
|
module Sub_system0 = struct
|
|
|
|
module type S = sig
|
|
|
|
type t
|
|
|
|
type sub_system += T of t
|
|
|
|
val to_sexp : (t -> Syntax.Version.t * Sexp.t) option
|
|
|
|
end
|
|
|
|
|
|
|
|
type 'a s = (module S with type t = 'a)
|
|
|
|
|
|
|
|
module Instance = struct
|
2018-02-28 19:04:02 +00:00
|
|
|
type t = T : 'a s * 'a -> t
|
2018-02-23 09:17:37 +00:00
|
|
|
end
|
|
|
|
end
|
|
|
|
|
|
|
|
module Id = struct
|
2018-02-20 11:46:10 +00:00
|
|
|
type t =
|
|
|
|
{ unique_id : int
|
|
|
|
; path : Path.t
|
|
|
|
; name : string
|
|
|
|
}
|
|
|
|
end
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
type t =
|
2018-02-23 09:17:37 +00:00
|
|
|
{ loc : Loc.t
|
|
|
|
; name : string
|
|
|
|
; unique_id : int
|
|
|
|
; kind : Jbuild.Library.Kind.t
|
|
|
|
; status : Status.t
|
|
|
|
; src_dir : Path.t
|
|
|
|
; obj_dir : Path.t
|
|
|
|
; version : string option
|
|
|
|
; synopsis : string option
|
|
|
|
; archives : Path.t list Mode.Dict.t
|
|
|
|
; plugins : Path.t list Mode.Dict.t
|
|
|
|
; foreign_archives : Path.t list Mode.Dict.t
|
|
|
|
; jsoo_runtime : Path.t list
|
2018-03-30 20:55:44 +00:00
|
|
|
; requires : t list Or_exn.t
|
|
|
|
; ppx_runtime_deps : t list Or_exn.t
|
|
|
|
; pps : t list Or_exn.t
|
2018-02-23 09:17:37 +00:00
|
|
|
; resolved_selects : Resolved_select.t list
|
|
|
|
; optional : bool
|
|
|
|
; user_written_deps : Jbuild.Lib_deps.t
|
2018-02-28 19:04:02 +00:00
|
|
|
; (* This is mutable to avoid this error:
|
|
|
|
|
|
|
|
{[
|
|
|
|
This kind of expression is not allowed as right-hand side of `let rec'
|
|
|
|
}]
|
|
|
|
*)
|
|
|
|
mutable sub_systems : Sub_system0.Instance.t Lazy.t Sub_system_name.Map.t
|
2018-02-20 11:46:10 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
and db =
|
|
|
|
{ parent : db option
|
2018-02-28 18:50:48 +00:00
|
|
|
; resolve : string -> resolve_result
|
|
|
|
; table : (string, status) Hashtbl.t
|
2018-02-20 11:46:10 +00:00
|
|
|
; all : string list Lazy.t
|
|
|
|
}
|
|
|
|
|
2018-02-28 18:50:48 +00:00
|
|
|
and status =
|
|
|
|
| St_initializing of Id.t (* To detect cycles *)
|
|
|
|
| St_found of t
|
|
|
|
| St_not_found
|
|
|
|
| St_hidden of t * Error0.Library_not_available.Reason.Hidden.t
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
and error =
|
|
|
|
| Library_not_available of Error0.Library_not_available.t
|
|
|
|
| No_solution_found_for_select of Error0.No_solution_found_for_select.t
|
|
|
|
| Dependency_cycle of (Path.t * string) list
|
|
|
|
| Conflict of conflict
|
2018-03-05 16:11:27 +00:00
|
|
|
| Overlap of overlap
|
2018-03-12 16:38:23 +00:00
|
|
|
| Private_deps_not_allowed of private_deps_not_allowed
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-02-28 18:50:48 +00:00
|
|
|
and resolve_result =
|
|
|
|
| Not_found
|
|
|
|
| Found of Info.t
|
|
|
|
| Hidden of Info.t * string
|
|
|
|
| Redirect of db option * string
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
and conflict =
|
2018-02-23 09:17:37 +00:00
|
|
|
{ lib1 : t * Dep_path.Entry.t list
|
|
|
|
; lib2 : t * Dep_path.Entry.t list
|
2018-02-20 11:46:10 +00:00
|
|
|
}
|
|
|
|
|
2018-03-05 16:11:27 +00:00
|
|
|
and overlap =
|
|
|
|
{ in_workspace : t
|
|
|
|
; installed : t * Dep_path.Entry.t list
|
|
|
|
}
|
|
|
|
|
2018-03-12 16:38:23 +00:00
|
|
|
and private_deps_not_allowed =
|
|
|
|
{ private_dep : t
|
|
|
|
; pd_loc : Loc.t
|
|
|
|
}
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
type lib = t
|
2018-02-13 10:36:15 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
module Error = struct
|
|
|
|
include Error0
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
module Conflict = struct
|
|
|
|
type nonrec t = conflict =
|
2018-02-23 09:17:37 +00:00
|
|
|
{ lib1 : t * Dep_path.Entry.t list
|
|
|
|
; lib2 : t * Dep_path.Entry.t list
|
2018-02-20 11:46:10 +00:00
|
|
|
}
|
|
|
|
end
|
|
|
|
|
2018-03-05 16:11:27 +00:00
|
|
|
module Overlap = struct
|
|
|
|
type nonrec t = overlap =
|
|
|
|
{ in_workspace : t
|
|
|
|
; installed : t * Dep_path.Entry.t list
|
|
|
|
}
|
|
|
|
end
|
|
|
|
|
2018-03-12 16:38:23 +00:00
|
|
|
module Private_deps_not_allowed = struct
|
|
|
|
type nonrec t = private_deps_not_allowed =
|
|
|
|
{ private_dep : t
|
|
|
|
; pd_loc : Loc.t
|
|
|
|
}
|
|
|
|
end
|
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
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
|
2018-03-05 16:11:27 +00:00
|
|
|
| Overlap of Overlap.t
|
2018-03-12 16:38:23 +00:00
|
|
|
| Private_deps_not_allowed of Private_deps_not_allowed.t
|
2016-12-02 13:54:32 +00:00
|
|
|
end
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
exception Error of Error.t
|
2017-05-18 12:49:56 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
let not_available ~loc reason fmt =
|
|
|
|
Errors.kerrf fmt ~f:(fun s ->
|
|
|
|
Loc.fail loc "%s %a" s
|
|
|
|
Error.Library_not_available.Reason.pp reason)
|
2018-01-21 21:36:30 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Generals |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
2018-02-13 10:36:15 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
let name t = t.name
|
2018-02-13 10:36:15 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
let kind t = t.kind
|
|
|
|
let synopsis t = t.synopsis
|
|
|
|
let archives t = t.archives
|
|
|
|
let plugins t = t.plugins
|
|
|
|
let jsoo_runtime t = t.jsoo_runtime
|
2018-02-28 19:04:02 +00:00
|
|
|
let unique_id t = t.unique_id
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
let src_dir t = t.src_dir
|
|
|
|
let obj_dir t = t.obj_dir
|
2018-02-13 10:36:15 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
let is_local t = Path.is_local t.obj_dir
|
2018-02-13 10:36:15 +00:00
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
let status t = t.status
|
2018-01-21 21:36:30 +00:00
|
|
|
|
2018-03-16 03:10:22 +00:00
|
|
|
let package t =
|
|
|
|
match t.status with
|
|
|
|
| Installed ->
|
|
|
|
Some (Findlib.root_package_name t.name
|
|
|
|
|> Package.Name.of_string)
|
|
|
|
| Public p -> Some p.name
|
|
|
|
| Private _ ->
|
|
|
|
None
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let to_id t : Id.t =
|
2018-02-20 11:46:10 +00:00
|
|
|
{ unique_id = t.unique_id
|
|
|
|
; path = t.src_dir
|
|
|
|
; name = t.name
|
|
|
|
}
|
2017-02-02 10:31:36 +00:00
|
|
|
|
2018-03-01 11:53:27 +00:00
|
|
|
module Set = Set.Make(
|
|
|
|
struct
|
|
|
|
type nonrec t = t
|
|
|
|
let compare x y = compare x.unique_id y.unique_id
|
|
|
|
end)
|
|
|
|
|
2018-03-16 05:22:38 +00:00
|
|
|
module Map = Map.Make(
|
|
|
|
struct
|
|
|
|
type nonrec t = t
|
|
|
|
let compare x y = compare x.unique_id y.unique_id
|
|
|
|
end)
|
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
module L = struct
|
|
|
|
type nonrec t = t list
|
2016-12-02 13:54:32 +00:00
|
|
|
|
2018-03-01 18:45:20 +00:00
|
|
|
let to_iflags dirs =
|
|
|
|
Arg_spec.S
|
|
|
|
(Path.Set.fold dirs ~init:[] ~f:(fun dir acc ->
|
|
|
|
Arg_spec.Path dir :: A "-I" :: acc)
|
|
|
|
|> List.rev)
|
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
let include_paths ts ~stdlib_dir =
|
2018-02-25 16:35:25 +00:00
|
|
|
let dirs =
|
|
|
|
List.fold_left ts ~init:Path.Set.empty ~f:(fun acc t ->
|
|
|
|
Path.Set.add acc (obj_dir t))
|
|
|
|
in
|
|
|
|
Path.Set.remove dirs stdlib_dir
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
let include_flags ts ~stdlib_dir =
|
2018-03-01 18:45:20 +00:00
|
|
|
to_iflags (include_paths ts ~stdlib_dir)
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-03-01 18:45:20 +00:00
|
|
|
let c_include_paths ts ~stdlib_dir =
|
2018-02-20 11:46:10 +00:00
|
|
|
let dirs =
|
|
|
|
List.fold_left ts ~init:Path.Set.empty ~f:(fun acc t ->
|
2018-02-25 16:35:25 +00:00
|
|
|
Path.Set.add acc t.src_dir)
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
2018-03-01 18:45:20 +00:00
|
|
|
Path.Set.remove dirs stdlib_dir
|
|
|
|
|
|
|
|
let c_include_flags ts ~stdlib_dir =
|
|
|
|
to_iflags (c_include_paths ts ~stdlib_dir)
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
let link_flags ts ~mode ~stdlib_dir =
|
|
|
|
Arg_spec.S
|
|
|
|
(c_include_flags ts ~stdlib_dir ::
|
|
|
|
List.map ts ~f:(fun t -> Arg_spec.Deps (Mode.Dict.get t.archives mode)))
|
|
|
|
|
2018-03-01 18:45:20 +00:00
|
|
|
let compile_and_link_flags ~compile ~link ~mode ~stdlib_dir =
|
|
|
|
let dirs =
|
|
|
|
Path.Set.union
|
|
|
|
( include_paths compile ~stdlib_dir)
|
|
|
|
(c_include_paths link ~stdlib_dir)
|
|
|
|
in
|
|
|
|
Arg_spec.S
|
|
|
|
(to_iflags dirs ::
|
|
|
|
List.map link ~f:(fun t ->
|
|
|
|
Arg_spec.Deps (Mode.Dict.get t.archives mode)))
|
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
let jsoo_runtime_files ts =
|
|
|
|
List.concat_map ts ~f:(fun t -> t.jsoo_runtime)
|
|
|
|
|
|
|
|
let archive_files ts ~mode ~ext_lib =
|
|
|
|
List.concat_map ts ~f:(fun t ->
|
|
|
|
Mode.Dict.get t.archives mode @
|
|
|
|
List.map (Mode.Dict.get t.foreign_archives mode)
|
|
|
|
~f:(Path.extend_basename ~suffix:ext_lib))
|
|
|
|
|
|
|
|
let remove_dups l =
|
|
|
|
let rec loop acc l seen =
|
|
|
|
match l with
|
|
|
|
| [] -> acc
|
|
|
|
| x :: l ->
|
2018-02-25 16:35:25 +00:00
|
|
|
if Int_set.mem seen x.unique_id then
|
2018-02-20 11:46:10 +00:00
|
|
|
loop acc l seen
|
|
|
|
else
|
2018-02-25 16:35:25 +00:00
|
|
|
loop (x :: acc) l (Int_set.add seen x.unique_id)
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
|
|
|
loop [] l Int_set.empty
|
|
|
|
end
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Sub-systems |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
|
|
|
module Sub_system = struct
|
|
|
|
type t = sub_system = ..
|
|
|
|
|
|
|
|
module type S = sig
|
|
|
|
module Info : Jbuild.Sub_system_info.S
|
|
|
|
type t
|
|
|
|
type sub_system += T of t
|
|
|
|
val instantiate
|
|
|
|
: resolve:(Loc.t * string -> (lib, exn) result)
|
|
|
|
-> get:(lib -> t option)
|
2018-02-28 19:04:02 +00:00
|
|
|
-> lib
|
2018-02-23 09:17:37 +00:00
|
|
|
-> Info.t
|
|
|
|
-> t
|
|
|
|
val to_sexp : (t -> Syntax.Version.t * Sexp.t) option
|
|
|
|
end
|
|
|
|
|
|
|
|
module type S' = sig
|
|
|
|
include S
|
|
|
|
val for_instance : t Sub_system0.s
|
|
|
|
val get : lib -> t option
|
|
|
|
end
|
|
|
|
|
|
|
|
let all = Sub_system_name.Table.create ~default_value:None
|
|
|
|
|
|
|
|
module Register(M : S) = struct
|
|
|
|
let get lib =
|
|
|
|
Option.map (Sub_system_name.Map.find lib.sub_systems M.Info.name)
|
2018-02-28 19:04:02 +00:00
|
|
|
~f:(fun (lazy (Sub_system0.Instance.T ((module X), t))) ->
|
2018-02-23 09:17:37 +00:00
|
|
|
match X.T t with
|
|
|
|
| M.T t -> t
|
|
|
|
| _ -> assert false)
|
|
|
|
|
|
|
|
let () =
|
|
|
|
let module M = struct
|
|
|
|
include M
|
|
|
|
let for_instance = (module M : Sub_system0.S with type t = t)
|
|
|
|
let get = get
|
|
|
|
end in
|
|
|
|
Sub_system_name.Table.set all ~key:M.Info.name
|
|
|
|
~data:(Some (module M : S'))
|
|
|
|
end
|
|
|
|
|
2018-02-28 19:04:02 +00:00
|
|
|
let instantiate name info lib ~resolve =
|
|
|
|
let impl = Option.value_exn (Sub_system_name.Table.get all name) in
|
|
|
|
let (module M : S') = impl in
|
|
|
|
match info with
|
|
|
|
| M.Info.T info ->
|
|
|
|
Sub_system0.Instance.T
|
|
|
|
(M.for_instance, M.instantiate ~resolve ~get:M.get lib info)
|
|
|
|
| _ -> assert false
|
2018-02-23 09:17:37 +00:00
|
|
|
|
|
|
|
let dump_config lib =
|
2018-02-28 19:04:02 +00:00
|
|
|
Sub_system_name.Map.filter_map lib.sub_systems ~f:(fun (lazy inst) ->
|
|
|
|
let (Sub_system0.Instance.T ((module M), t)) = inst in
|
2018-02-23 09:17:37 +00:00
|
|
|
match M.to_sexp with
|
|
|
|
| None -> None
|
|
|
|
| Some f -> Some (f t))
|
|
|
|
end
|
|
|
|
|
2018-02-20 11:46:10 +00:00
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Library name resolution and transitive closure |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
|
|
|
let gen_unique_id =
|
|
|
|
let next = ref 0 in
|
|
|
|
fun () ->
|
|
|
|
let n = !next in
|
|
|
|
next := n + 1;
|
|
|
|
n
|
|
|
|
|
|
|
|
(* Dependency stack used while resolving the dependencies of a library
|
|
|
|
that was just returned by the [resolve] callback *)
|
|
|
|
module Dep_stack = struct
|
|
|
|
type t =
|
2018-02-23 09:17:37 +00:00
|
|
|
{ stack : Id.t list
|
2018-02-20 11:46:10 +00:00
|
|
|
; seen : Int_set.t
|
|
|
|
}
|
|
|
|
|
|
|
|
let empty =
|
|
|
|
{ stack = []
|
|
|
|
; seen = Int_set.empty
|
|
|
|
}
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let to_required_by t ~stop_at =
|
|
|
|
let stop_at = stop_at.stack in
|
|
|
|
let rec loop acc l =
|
|
|
|
if l == stop_at then
|
|
|
|
List.rev acc
|
|
|
|
else
|
|
|
|
match l with
|
|
|
|
| [] -> assert false
|
|
|
|
| { Id.path; name; _ } :: l ->
|
|
|
|
loop (Dep_path.Entry.Library (path, name) :: acc) l
|
|
|
|
in
|
|
|
|
loop [] t.stack
|
|
|
|
|
|
|
|
let dependency_cycle t (last : Id.t) =
|
2018-02-25 16:35:25 +00:00
|
|
|
assert (Int_set.mem t.seen last.unique_id);
|
2018-02-20 11:46:10 +00:00
|
|
|
let rec build_loop acc stack =
|
|
|
|
match stack with
|
|
|
|
| [] -> assert false
|
2018-02-23 09:17:37 +00:00
|
|
|
| (x : Id.t) :: stack ->
|
2018-02-20 11:46:10 +00:00
|
|
|
let acc = (x.path, x.name) :: acc in
|
|
|
|
if x.unique_id = last.unique_id then
|
|
|
|
acc
|
|
|
|
else
|
|
|
|
build_loop acc stack
|
|
|
|
in
|
|
|
|
let loop = build_loop [(last.path, last.name)] t.stack in
|
2018-02-23 09:17:37 +00:00
|
|
|
Error (Dependency_cycle loop)
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
let create_and_push t name path =
|
|
|
|
let unique_id = gen_unique_id () in
|
2018-02-23 09:17:37 +00:00
|
|
|
let init = { Id. unique_id; name; path } in
|
2018-02-20 11:46:10 +00:00
|
|
|
(init,
|
|
|
|
{ stack = init :: t.stack
|
2018-02-25 16:35:25 +00:00
|
|
|
; seen = Int_set.add t.seen unique_id
|
2018-02-20 11:46:10 +00:00
|
|
|
})
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let push t (x : Id.t) : (_, _) result =
|
2018-02-25 16:35:25 +00:00
|
|
|
if Int_set.mem t.seen x.unique_id then
|
2018-02-20 11:46:10 +00:00
|
|
|
Error (dependency_cycle t x)
|
2018-02-13 10:36:15 +00:00
|
|
|
else
|
2018-02-20 11:46:10 +00:00
|
|
|
Ok { stack = x :: t.stack
|
2018-02-25 16:35:25 +00:00
|
|
|
; seen = Int_set.add t.seen x.unique_id
|
2018-02-20 11:46:10 +00:00
|
|
|
}
|
|
|
|
end
|
2018-02-13 10:36:15 +00:00
|
|
|
|
2018-03-12 17:02:28 +00:00
|
|
|
let check_private_deps ~(lib : lib) ~loc ~allow_private_deps =
|
2018-03-12 17:53:00 +00:00
|
|
|
if (not allow_private_deps) && Status.is_private lib.status then
|
2018-03-12 17:02:28 +00:00
|
|
|
Result.Error (Error (
|
|
|
|
Private_deps_not_allowed { private_dep = lib ; pd_loc = loc }))
|
2018-03-12 17:53:00 +00:00
|
|
|
else
|
2018-03-12 17:02:28 +00:00
|
|
|
Ok lib
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let already_in_table (info : Info.t) name x =
|
|
|
|
let to_sexp = Sexp.To_sexp.(pair Path.sexp_of_t string) in
|
|
|
|
let sexp =
|
|
|
|
match x with
|
2018-02-28 18:50:48 +00:00
|
|
|
| St_initializing x ->
|
2018-02-23 09:17:37 +00:00
|
|
|
Sexp.List [Sexp.unsafe_atom_of_string "Initializing";
|
|
|
|
Path.sexp_of_t x.path]
|
2018-02-28 18:50:48 +00:00
|
|
|
| St_found t ->
|
|
|
|
List [Sexp.unsafe_atom_of_string "Found";
|
|
|
|
Path.sexp_of_t t.src_dir]
|
|
|
|
| St_not_found ->
|
|
|
|
Sexp.unsafe_atom_of_string "Not_found"
|
|
|
|
| St_hidden (_, { path; reason; _ }) ->
|
2018-02-23 09:17:37 +00:00
|
|
|
List [Sexp.unsafe_atom_of_string "Hidden";
|
2018-02-28 18:50:48 +00:00
|
|
|
Path.sexp_of_t path; Sexp.atom reason]
|
2018-02-23 09:17:37 +00:00
|
|
|
in
|
|
|
|
Sexp.code_error
|
|
|
|
"Lib_db.DB: resolver returned name that's already in the table"
|
|
|
|
[ "name" , Sexp.atom name
|
|
|
|
; "returned_lib" , to_sexp (info.src_dir, name)
|
|
|
|
; "conflicting_with", sexp
|
|
|
|
]
|
|
|
|
|
2018-02-28 18:50:48 +00:00
|
|
|
let result_of_resolve_status = function
|
|
|
|
| St_initializing _ -> assert false
|
|
|
|
| St_found x -> Ok x
|
|
|
|
| St_not_found -> Error Error.Library_not_available.Reason.Not_found
|
|
|
|
| St_hidden (_, hidden) -> Error (Hidden hidden)
|
|
|
|
|
|
|
|
let rec instantiate db name (info : Info.t) ~stack ~hidden =
|
|
|
|
let id, stack =
|
|
|
|
Dep_stack.create_and_push stack name info.src_dir
|
|
|
|
in
|
|
|
|
Option.iter (Hashtbl.find db.table name) ~f:(fun x ->
|
|
|
|
already_in_table info name x);
|
|
|
|
(* Add [id] to the table, to detect loops *)
|
|
|
|
Hashtbl.add db.table name (St_initializing id);
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-03-12 16:38:23 +00:00
|
|
|
let allow_private_deps = Status.is_private info.status in
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let requires, pps, resolved_selects =
|
2018-03-12 16:38:23 +00:00
|
|
|
resolve_user_deps db info.requires ~allow_private_deps ~pps:info.pps ~stack
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
|
|
|
let ppx_runtime_deps =
|
2018-03-12 16:38:23 +00:00
|
|
|
resolve_simple_deps db info.ppx_runtime_deps ~allow_private_deps ~stack
|
2016-12-15 11:20:46 +00:00
|
|
|
in
|
2018-02-20 11:46:10 +00:00
|
|
|
let map_error x =
|
|
|
|
Result.map_error x ~f:(fun e ->
|
2018-02-23 09:17:37 +00:00
|
|
|
Dep_path.prepend_exn e (Library (info.src_dir, name)))
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
|
|
|
let requires = map_error requires in
|
|
|
|
let ppx_runtime_deps = map_error ppx_runtime_deps in
|
2018-03-12 16:38:23 +00:00
|
|
|
let resolve (loc, name) =
|
|
|
|
resolve_dep db name ~allow_private_deps ~loc ~stack in
|
2018-02-28 18:50:48 +00:00
|
|
|
let t =
|
|
|
|
{ loc = info.loc
|
|
|
|
; name = name
|
|
|
|
; unique_id = id.unique_id
|
|
|
|
; kind = info.kind
|
|
|
|
; status = info.status
|
|
|
|
; src_dir = info.src_dir
|
|
|
|
; obj_dir = info.obj_dir
|
|
|
|
; version = info.version
|
|
|
|
; synopsis = info.synopsis
|
|
|
|
; archives = info.archives
|
|
|
|
; plugins = info.plugins
|
|
|
|
; foreign_archives = info.foreign_archives
|
|
|
|
; jsoo_runtime = info.jsoo_runtime
|
|
|
|
; requires = requires
|
|
|
|
; ppx_runtime_deps = ppx_runtime_deps
|
|
|
|
; pps = pps
|
|
|
|
; resolved_selects = resolved_selects
|
|
|
|
; optional = info.optional
|
|
|
|
; user_written_deps = Info.user_written_deps info
|
2018-02-28 19:04:02 +00:00
|
|
|
; sub_systems = Sub_system_name.Map.empty
|
2018-02-28 18:50:48 +00:00
|
|
|
}
|
2018-02-23 09:17:37 +00:00
|
|
|
in
|
2018-02-28 19:04:02 +00:00
|
|
|
t.sub_systems <-
|
|
|
|
Sub_system_name.Map.mapi info.sub_systems ~f:(fun name info ->
|
|
|
|
lazy (Sub_system.instantiate name info t ~resolve));
|
2018-02-13 10:36:15 +00:00
|
|
|
|
2018-02-28 18:50:48 +00:00
|
|
|
let res =
|
|
|
|
let hidden =
|
|
|
|
match hidden with
|
|
|
|
| None ->
|
|
|
|
Option.some_if
|
|
|
|
(info.optional &&
|
|
|
|
not (Result.is_ok t.requires && Result.is_ok t.ppx_runtime_deps))
|
|
|
|
"optional with unavailable dependencies"
|
|
|
|
| Some _ -> hidden
|
|
|
|
in
|
|
|
|
match hidden with
|
|
|
|
| None -> St_found t
|
|
|
|
| Some reason ->
|
|
|
|
St_hidden (t, { name; path = t.src_dir; reason })
|
|
|
|
in
|
|
|
|
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)
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-02-28 18:50:48 +00:00
|
|
|
and find_even_when_hidden db name =
|
|
|
|
match find_internal db name ~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 =
|
2018-02-20 11:46:10 +00:00
|
|
|
match Hashtbl.find db.table name with
|
2018-02-28 18:50:48 +00:00
|
|
|
| Some x -> x
|
|
|
|
| None -> resolve_name db name ~stack
|
|
|
|
|
2018-03-12 16:38:23 +00:00
|
|
|
and resolve_dep db name ~allow_private_deps ~loc ~stack : (t, exn) result =
|
2018-02-28 18:50:48 +00:00
|
|
|
match find_internal db name ~stack with
|
|
|
|
| St_initializing id ->
|
|
|
|
Error (Dep_stack.dependency_cycle stack id)
|
2018-03-12 17:02:28 +00:00
|
|
|
| St_found lib -> check_private_deps ~lib ~loc ~allow_private_deps
|
2018-02-28 18:50:48 +00:00
|
|
|
| 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 }))
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
and resolve_name db name ~stack =
|
|
|
|
match db.resolve name with
|
2018-02-28 18:50:48 +00:00
|
|
|
| Redirect (db', name') -> begin
|
|
|
|
let db' = Option.value db' ~default:db in
|
|
|
|
match find_internal db' name' ~stack with
|
|
|
|
| St_initializing _ as x -> x
|
|
|
|
| x ->
|
|
|
|
Hashtbl.add db.table name x;
|
|
|
|
x
|
|
|
|
end
|
|
|
|
| Found info ->
|
|
|
|
instantiate db name info ~stack ~hidden:None
|
|
|
|
| Not_found ->
|
2018-02-20 11:46:10 +00:00
|
|
|
let res =
|
|
|
|
match db.parent with
|
2018-02-28 18:50:48 +00:00
|
|
|
| None -> St_not_found
|
|
|
|
| Some db -> find_internal db name ~stack
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
2018-02-28 18:50:48 +00:00
|
|
|
Hashtbl.add db.table name res;
|
2018-02-20 11:46:10 +00:00
|
|
|
res
|
2018-02-28 18:50:48 +00:00
|
|
|
| Hidden (info, hidden) ->
|
|
|
|
match
|
|
|
|
match db.parent with
|
|
|
|
| None -> St_not_found
|
|
|
|
| Some db -> find_internal db name ~stack
|
|
|
|
with
|
|
|
|
| St_found _ as x ->
|
|
|
|
Hashtbl.add db.table name x;
|
|
|
|
x
|
|
|
|
| _ ->
|
|
|
|
instantiate db name info ~stack ~hidden:(Some hidden)
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
and available_internal db name ~stack =
|
2018-03-12 16:38:23 +00:00
|
|
|
match resolve_dep db name ~allow_private_deps:true ~loc:Loc.none ~stack with
|
2018-03-05 15:05:03 +00:00
|
|
|
| Ok _ -> true
|
|
|
|
| Error _ -> false
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-03-12 16:38:23 +00:00
|
|
|
and resolve_simple_deps db names ~allow_private_deps ~stack =
|
2018-03-05 15:05:03 +00:00
|
|
|
let rec loop acc = function
|
|
|
|
| [] -> Ok (List.rev acc)
|
|
|
|
| (loc, name) :: names ->
|
2018-03-12 16:38:23 +00:00
|
|
|
resolve_dep db name ~allow_private_deps ~loc ~stack >>= fun x ->
|
2018-03-05 15:05:03 +00:00
|
|
|
loop (x :: acc) names
|
|
|
|
in
|
|
|
|
loop [] names
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-03-12 16:38:23 +00:00
|
|
|
and resolve_complex_deps db deps ~allow_private_deps ~stack =
|
2018-03-05 15:05:03 +00:00
|
|
|
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 =
|
2018-03-12 16:38:23 +00:00
|
|
|
resolve_dep db name ~allow_private_deps ~loc ~stack >>| fun x -> [x]
|
2018-03-05 15:05:03 +00:00
|
|
|
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
|
|
|
|
None
|
|
|
|
else
|
|
|
|
match
|
|
|
|
let deps =
|
|
|
|
String_set.fold required ~init:[] ~f:(fun x acc ->
|
|
|
|
(Loc.none, x) :: acc)
|
|
|
|
in
|
2018-03-12 16:38:23 +00:00
|
|
|
resolve_simple_deps ~allow_private_deps db deps ~stack
|
2018-03-05 15:05:03 +00:00
|
|
|
with
|
|
|
|
| Ok ts -> Some (ts, file)
|
|
|
|
| Error _ -> None)
|
|
|
|
with
|
|
|
|
| Some (ts, file) ->
|
|
|
|
(Ok ts, Ok file)
|
|
|
|
| None ->
|
|
|
|
let e = { Error.No_solution_found_for_select.loc } in
|
|
|
|
(Error (Error (No_solution_found_for_select e)),
|
|
|
|
Error e)
|
|
|
|
in
|
|
|
|
(res, { Resolved_select. src_fn; dst_fn = result_fn } :: acc_selects)
|
|
|
|
in
|
|
|
|
let res =
|
|
|
|
match res, acc_res with
|
|
|
|
| Ok l, Ok acc -> Ok (List.rev_append l acc)
|
|
|
|
| (Error _ as res), _
|
|
|
|
| _, (Error _ as res) -> res
|
|
|
|
in
|
|
|
|
(res, acc_selects))
|
|
|
|
in
|
|
|
|
let res =
|
|
|
|
match res with
|
|
|
|
| Ok l -> Ok (List.rev l)
|
|
|
|
| Error _ -> res
|
|
|
|
in
|
|
|
|
(res, resolved_selects)
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-03-12 16:38:23 +00:00
|
|
|
and resolve_deps db deps ~allow_private_deps ~stack =
|
2018-03-05 15:05:03 +00:00
|
|
|
match (deps : Info.Deps.t) with
|
2018-03-12 16:38:23 +00:00
|
|
|
| Simple names ->
|
2018-03-12 17:02:28 +00:00
|
|
|
(resolve_simple_deps db names ~allow_private_deps ~stack, [])
|
2018-03-12 16:38:23 +00:00
|
|
|
| Complex names ->
|
|
|
|
resolve_complex_deps ~allow_private_deps db names ~stack
|
|
|
|
|
|
|
|
and resolve_user_deps db deps ~allow_private_deps ~pps ~stack =
|
|
|
|
let deps, resolved_selects =
|
|
|
|
resolve_deps db deps ~allow_private_deps ~stack in
|
2018-03-05 15:05:03 +00:00
|
|
|
let deps, pps =
|
|
|
|
match pps with
|
|
|
|
| [] -> (deps, Ok [])
|
2018-03-12 18:06:58 +00:00
|
|
|
| first :: others as pps ->
|
|
|
|
(* Location of the list of ppx rewriters *)
|
|
|
|
let loc =
|
|
|
|
let last = Option.value (List.last others) ~default:first in
|
|
|
|
{ (fst first) with stop = (fst last).stop }
|
|
|
|
in
|
2018-03-05 15:05:03 +00:00
|
|
|
let pps =
|
|
|
|
let pps = (pps : (Loc.t * Jbuild.Pp.t) list :> (Loc.t * string) list) in
|
2018-03-12 17:02:28 +00:00
|
|
|
resolve_simple_deps db pps ~allow_private_deps:true ~stack
|
|
|
|
>>= fun pps ->
|
2018-03-05 16:11:27 +00:00
|
|
|
closure_with_overlap_checks None pps ~stack
|
2018-03-05 15:05:03 +00:00
|
|
|
in
|
|
|
|
let deps =
|
2018-03-12 18:06:58 +00:00
|
|
|
let rec check_runtime_deps acc pps = function
|
2018-03-12 17:02:28 +00:00
|
|
|
| [] -> loop acc pps
|
|
|
|
| lib :: ppx_rts ->
|
|
|
|
check_private_deps ~lib ~loc ~allow_private_deps >>= fun rt ->
|
2018-03-12 18:06:58 +00:00
|
|
|
check_runtime_deps (rt :: acc) pps ppx_rts
|
2018-03-12 17:02:28 +00:00
|
|
|
and loop acc = function
|
2018-03-05 15:05:03 +00:00
|
|
|
| [] -> Ok acc
|
|
|
|
| pp :: pps ->
|
|
|
|
pp.ppx_runtime_deps >>= fun rt_deps ->
|
2018-03-12 18:06:58 +00:00
|
|
|
check_runtime_deps acc pps rt_deps
|
2018-02-28 18:50:48 +00:00
|
|
|
in
|
2018-03-05 15:05:03 +00:00
|
|
|
deps >>= fun deps ->
|
|
|
|
pps >>= fun pps ->
|
|
|
|
loop deps pps
|
|
|
|
in
|
|
|
|
(deps, pps)
|
|
|
|
in
|
|
|
|
(deps, pps, resolved_selects)
|
2018-02-23 09:17:37 +00:00
|
|
|
|
2018-03-05 16:11:27 +00:00
|
|
|
and closure_with_overlap_checks db ts ~stack =
|
2018-03-05 15:05:03 +00:00
|
|
|
let visited = ref String_map.empty in
|
|
|
|
let res = ref [] in
|
|
|
|
let orig_stack = stack in
|
|
|
|
let rec loop t ~stack =
|
|
|
|
match String_map.find !visited t.name with
|
|
|
|
| Some (t', stack') ->
|
|
|
|
if t.unique_id = t'.unique_id then
|
|
|
|
Ok ()
|
|
|
|
else
|
|
|
|
let req_by = Dep_stack.to_required_by ~stop_at:orig_stack in
|
|
|
|
Error
|
|
|
|
(Error (Conflict { lib1 = (t', req_by stack')
|
|
|
|
; lib2 = (t , req_by stack )
|
|
|
|
}))
|
|
|
|
| None ->
|
|
|
|
visited := String_map.add !visited t.name (t, stack);
|
2018-03-05 16:11:27 +00:00
|
|
|
(match db with
|
|
|
|
| None -> Ok ()
|
|
|
|
| Some db ->
|
|
|
|
match find_internal db t.name ~stack with
|
|
|
|
| St_found t' ->
|
|
|
|
if t.unique_id = t'.unique_id then
|
|
|
|
Ok ()
|
|
|
|
else begin
|
|
|
|
let req_by = Dep_stack.to_required_by stack ~stop_at:orig_stack in
|
|
|
|
Error
|
|
|
|
(Error (Overlap
|
|
|
|
{ in_workspace = t'
|
|
|
|
; installed = (t, req_by)
|
|
|
|
}))
|
|
|
|
end
|
|
|
|
| _ -> assert false)
|
|
|
|
>>= fun () ->
|
2018-03-05 15:05:03 +00:00
|
|
|
Dep_stack.push stack (to_id t) >>= fun stack ->
|
|
|
|
t.requires >>= fun deps ->
|
|
|
|
iter deps ~stack >>| fun () ->
|
|
|
|
res := t :: !res
|
|
|
|
and iter ts ~stack =
|
|
|
|
match ts with
|
|
|
|
| [] -> Ok ()
|
|
|
|
| t :: ts ->
|
|
|
|
loop t ~stack >>= fun () ->
|
|
|
|
iter ts ~stack
|
|
|
|
in
|
|
|
|
iter ts ~stack >>| fun () ->
|
|
|
|
List.rev !res
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-03-05 16:11:27 +00:00
|
|
|
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
|
2018-02-23 09:17:37 +00:00
|
|
|
|
|
|
|
let to_exn res =
|
2018-02-20 11:46:10 +00:00
|
|
|
match res with
|
|
|
|
| Ok x -> x
|
2018-02-23 09:17:37 +00:00
|
|
|
| Error e -> raise e
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
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)
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
module Compile = struct
|
|
|
|
module Resolved_select = Resolved_select
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
type nonrec t =
|
2018-03-30 20:55:44 +00:00
|
|
|
{ direct_requires : t list Or_exn.t
|
|
|
|
; requires : t list Or_exn.t
|
|
|
|
; pps : t list Or_exn.t
|
2018-02-23 09:17:37 +00:00
|
|
|
; resolved_selects : Resolved_select.t list
|
|
|
|
; optional : bool
|
|
|
|
; user_written_deps : Jbuild.Lib_deps.t
|
2018-02-28 19:04:02 +00:00
|
|
|
; sub_systems : Sub_system0.Instance.t Lazy.t Sub_system_name.Map.t
|
2018-02-23 09:17:37 +00:00
|
|
|
}
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-03-05 16:11:27 +00:00
|
|
|
let for_lib db (t : lib) =
|
2018-02-23 09:17:37 +00:00
|
|
|
{ direct_requires = t.requires
|
2018-03-05 16:11:27 +00:00
|
|
|
; requires = t.requires >>= closure_with_overlap_checks db
|
2018-02-23 09:17:37 +00:00
|
|
|
; resolved_selects = t.resolved_selects
|
|
|
|
; pps = t.pps
|
|
|
|
; optional = t.optional
|
|
|
|
; user_written_deps = t.user_written_deps
|
|
|
|
; sub_systems = t.sub_systems
|
|
|
|
}
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let direct_requires t = t.direct_requires
|
|
|
|
let requires t = t.requires
|
|
|
|
let resolved_selects t = t.resolved_selects
|
|
|
|
let pps t = t.pps
|
|
|
|
let optional t = t.optional
|
|
|
|
let user_written_deps t = t.user_written_deps
|
|
|
|
let sub_systems t =
|
|
|
|
Sub_system_name.Map.values t.sub_systems
|
2018-02-28 19:04:02 +00:00
|
|
|
|> List.map ~f:(fun (lazy (Sub_system0.Instance.T ((module M), t))) ->
|
|
|
|
M.T t)
|
2018-02-20 11:46:10 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Databases |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
|
|
|
module DB = struct
|
2018-02-28 18:50:48 +00:00
|
|
|
module Resolve_result = struct
|
|
|
|
type t = resolve_result =
|
|
|
|
| Not_found
|
|
|
|
| Found of Info.t
|
|
|
|
| Hidden of Info.t * string
|
|
|
|
| Redirect of db option * string
|
2018-02-20 11:46:10 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
type t = db
|
|
|
|
|
|
|
|
let create ?parent ~resolve ~all () =
|
|
|
|
{ parent
|
|
|
|
; resolve
|
|
|
|
; table = Hashtbl.create 1024
|
|
|
|
; all = Lazy.from_fun all
|
|
|
|
}
|
|
|
|
|
|
|
|
let create_from_library_stanzas ?parent stanzas =
|
|
|
|
let map =
|
|
|
|
List.concat_map stanzas ~f:(fun (dir, (conf : Jbuild.Library.t)) ->
|
|
|
|
let info = Info.of_library_stanza ~dir conf in
|
|
|
|
match conf.public with
|
|
|
|
| None ->
|
2018-02-28 18:50:48 +00:00
|
|
|
[(conf.name, Resolve_result.Found info)]
|
2018-02-20 11:46:10 +00:00
|
|
|
| Some p ->
|
|
|
|
if p.name = conf.name then
|
2018-02-28 18:50:48 +00:00
|
|
|
[(p.name, Found info)]
|
2018-02-20 11:46:10 +00:00
|
|
|
else
|
2018-02-28 18:50:48 +00:00
|
|
|
[ p.name , Found info
|
|
|
|
; conf.name, Redirect (None, p.name)
|
2018-02-20 11:46:10 +00:00
|
|
|
])
|
2018-02-25 16:35:25 +00:00
|
|
|
|> String_map.of_list
|
2018-02-20 11:46:10 +00:00
|
|
|
|> function
|
|
|
|
| Ok x -> x
|
2018-02-28 18:50:48 +00:00
|
|
|
| Error (name, _, _) ->
|
|
|
|
match
|
|
|
|
List.filter_map stanzas ~f:(fun (_, (conf : Jbuild.Library.t)) ->
|
|
|
|
if name = conf.name ||
|
|
|
|
match conf.public with
|
|
|
|
| None -> false
|
|
|
|
| Some p -> name = p.name
|
|
|
|
then Some conf.buildable.loc
|
|
|
|
else None)
|
|
|
|
with
|
|
|
|
| [] | [_] -> assert false
|
|
|
|
| loc1 :: loc2 :: _ ->
|
|
|
|
die "Library %S is defined twice:\n\
|
|
|
|
- %s\n\
|
|
|
|
- %s"
|
|
|
|
name
|
|
|
|
(Loc.to_file_colon_line loc1)
|
|
|
|
(Loc.to_file_colon_line loc2)
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
|
|
|
create () ?parent
|
|
|
|
~resolve:(fun name ->
|
2018-02-25 16:35:25 +00:00
|
|
|
match String_map.find map name with
|
2018-02-28 18:50:48 +00:00
|
|
|
| None -> Not_found
|
|
|
|
| Some x -> x)
|
2018-02-20 11:46:10 +00:00
|
|
|
~all:(fun () -> String_map.keys map)
|
|
|
|
|
|
|
|
let create_from_findlib findlib =
|
|
|
|
create ()
|
|
|
|
~resolve:(fun name ->
|
|
|
|
match Findlib.find findlib name with
|
2018-02-28 18:50:48 +00:00
|
|
|
| Ok pkg -> Found (Info.of_findlib_package pkg)
|
2018-02-20 11:46:10 +00:00
|
|
|
| Error e ->
|
|
|
|
match e with
|
2018-02-28 18:50:48 +00:00
|
|
|
| Not_found -> Not_found
|
2018-02-20 11:46:10 +00:00
|
|
|
| Hidden pkg ->
|
2018-02-28 18:50:48 +00:00
|
|
|
Hidden (Info.of_findlib_package pkg,
|
|
|
|
"unsatisfied 'exist_if'"))
|
2018-02-20 11:46:10 +00:00
|
|
|
~all:(fun () ->
|
|
|
|
Findlib.all_packages findlib
|
|
|
|
|> List.map ~f:Findlib.Package.name)
|
|
|
|
|
|
|
|
let find = find
|
2018-02-28 18:50:48 +00:00
|
|
|
let find_even_when_hidden = find_even_when_hidden
|
2018-02-20 11:46:10 +00:00
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let resolve t (loc, name) =
|
2018-02-20 11:46:10 +00:00
|
|
|
match find t name with
|
2018-02-23 09:17:37 +00:00
|
|
|
| Ok _ as res -> res
|
2018-02-20 11:46:10 +00:00
|
|
|
| Error reason ->
|
2018-02-23 09:17:37 +00:00
|
|
|
Error (Error (Library_not_available
|
|
|
|
{ loc
|
|
|
|
; name
|
|
|
|
; reason
|
|
|
|
}))
|
|
|
|
|
|
|
|
let find_many =
|
|
|
|
let rec loop t acc = function
|
|
|
|
| [] -> Ok (List.rev acc)
|
|
|
|
| name :: names ->
|
|
|
|
resolve t (Loc.none, name) >>= fun lib ->
|
|
|
|
loop t (lib ::acc) names
|
|
|
|
in
|
|
|
|
fun t names -> loop t [] names
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
let available t name = available_internal t name ~stack:Dep_stack.empty
|
|
|
|
|
2018-03-05 16:11:27 +00:00
|
|
|
let get_compile_info t ?(allow_overlaps=false) name =
|
2018-02-28 18:50:48 +00:00
|
|
|
match find_even_when_hidden t name with
|
|
|
|
| None ->
|
2018-02-23 09:17:37 +00:00
|
|
|
Sexp.code_error "Lib.DB.get_compile_info got library that doesn't exist"
|
|
|
|
[ "name", Sexp.To_sexp.string name ]
|
2018-03-05 16:11:27 +00:00
|
|
|
| Some lib ->
|
|
|
|
let t = Option.some_if (not allow_overlaps) t in
|
|
|
|
Compile.for_lib t lib
|
2018-02-23 09:17:37 +00:00
|
|
|
|
2018-03-05 16:11:27 +00:00
|
|
|
let resolve_user_written_deps t ?(allow_overlaps=false) deps ~pps =
|
2018-02-23 09:17:37 +00:00
|
|
|
let res, pps, resolved_selects =
|
2018-02-20 11:46:10 +00:00
|
|
|
resolve_user_deps t (Info.Deps.of_lib_deps deps) ~pps
|
2018-03-12 16:38:23 +00:00
|
|
|
~stack:Dep_stack.empty ~allow_private_deps:true
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
2018-03-05 16:11:27 +00:00
|
|
|
let requires =
|
|
|
|
res
|
|
|
|
>>=
|
|
|
|
closure_with_overlap_checks (Option.some_if (not allow_overlaps) t)
|
|
|
|
in
|
2018-02-23 09:17:37 +00:00
|
|
|
{ Compile.
|
|
|
|
direct_requires = res
|
2018-03-05 16:11:27 +00:00
|
|
|
; requires
|
2018-02-23 09:17:37 +00:00
|
|
|
; pps
|
|
|
|
; resolved_selects
|
|
|
|
; optional = false
|
|
|
|
; user_written_deps = deps
|
|
|
|
; sub_systems = Sub_system_name.Map.empty
|
|
|
|
}
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
let resolve_pps t pps =
|
2018-03-12 16:38:23 +00:00
|
|
|
resolve_simple_deps t ~allow_private_deps:true
|
2018-02-23 09:17:37 +00:00
|
|
|
(pps : (Loc.t *Jbuild.Pp.t) list :> (Loc.t * string) list)
|
2018-02-20 11:46:10 +00:00
|
|
|
~stack:Dep_stack.empty
|
|
|
|
|
|
|
|
let rec all ?(recursive=false) t =
|
|
|
|
let l =
|
2018-03-01 11:53:27 +00:00
|
|
|
List.fold_left (Lazy.force t.all) ~f:(fun libs name ->
|
2018-02-20 11:46:10 +00:00
|
|
|
match find t name with
|
2018-03-01 11:53:27 +00:00
|
|
|
| Ok x -> Set.add libs x
|
|
|
|
| Error _ -> libs) ~init:Set.empty
|
2018-02-20 11:46:10 +00:00
|
|
|
in
|
|
|
|
match recursive, t.parent with
|
2018-03-01 11:53:27 +00:00
|
|
|
| true, Some t -> Set.union (all ~recursive t) l
|
2018-02-20 11:46:10 +00:00
|
|
|
| _ -> l
|
|
|
|
end
|
|
|
|
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| META files |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
|
|
|
module Meta = struct
|
|
|
|
let to_names ts =
|
|
|
|
List.fold_left ts ~init:String_set.empty ~f:(fun acc t ->
|
2018-02-25 16:35:25 +00:00
|
|
|
String_set.add acc t.name)
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
(* For the deprecated method, we need to put all the runtime
|
|
|
|
dependencies of the transitive closure.
|
|
|
|
|
|
|
|
We need to do this because [ocamlfind ocamlc -package ppx_foo]
|
|
|
|
will not look for the transitive dependencies of [foo], and the
|
|
|
|
runtime dependencies might be attached to a dependency of [foo]
|
|
|
|
rather than [foo] itself.
|
|
|
|
|
|
|
|
Sigh... *)
|
2018-02-23 09:17:37 +00:00
|
|
|
let ppx_runtime_deps_for_deprecated_method t =
|
|
|
|
closure_exn [t]
|
|
|
|
|> List.concat_map ~f:ppx_runtime_deps_exn
|
2018-02-20 11:46:10 +00:00
|
|
|
|> to_names
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let requires t = to_names (requires_exn t)
|
|
|
|
let ppx_runtime_deps t = to_names (ppx_runtime_deps_exn t)
|
2018-02-20 11:46:10 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
(* +-----------------------------------------------------------------+
|
|
|
|
| Error reporting |
|
|
|
|
+-----------------------------------------------------------------+ *)
|
|
|
|
|
2018-02-23 09:17:37 +00:00
|
|
|
let report_lib_error ppf (e : Error.t) =
|
2018-02-20 11:46:10 +00:00
|
|
|
match e with
|
2018-02-23 09:17:37 +00:00
|
|
|
| Library_not_available { loc = _; name; reason } ->
|
2018-02-20 11:46:10 +00:00
|
|
|
Format.fprintf ppf
|
2018-02-23 09:17:37 +00:00
|
|
|
"@{<error>Error@}: Library %S %a.@\n"
|
2018-02-20 11:46:10 +00:00
|
|
|
name
|
|
|
|
Error.Library_not_available.Reason.pp reason
|
|
|
|
| Conflict { lib1 = (lib1, rb1); lib2 = (lib2, rb2) } ->
|
|
|
|
Format.fprintf ppf
|
2018-03-05 18:06:41 +00:00
|
|
|
"@[<v>@{<error>Error@}: Conflict between the following libraries:@,\
|
2018-02-23 09:17:37 +00:00
|
|
|
- %S in %s@,\
|
|
|
|
\ %a@,\
|
|
|
|
- %S in %s@,\
|
|
|
|
\ %a@,\
|
|
|
|
This cannot work.@\n"
|
2018-02-20 11:46:10 +00:00
|
|
|
lib1.name (Path.to_string_maybe_quoted lib1.src_dir)
|
2018-02-23 09:17:37 +00:00
|
|
|
Dep_path.Entries.pp rb1
|
2018-02-20 11:46:10 +00:00
|
|
|
lib2.name (Path.to_string_maybe_quoted lib2.src_dir)
|
2018-02-23 09:17:37 +00:00
|
|
|
Dep_path.Entries.pp rb2
|
2018-03-05 16:11:27 +00:00
|
|
|
| Overlap { in_workspace = lib1; installed = (lib2, rb2) } ->
|
|
|
|
Format.fprintf ppf
|
|
|
|
"@[<v>@{<error>Error@}: Conflict between the following libraries:@,\
|
|
|
|
- %S in %s@,\
|
|
|
|
- %S in %s@,\
|
|
|
|
\ %a@,\
|
|
|
|
This is not allowed.@\n"
|
|
|
|
lib1.name (Path.to_string_maybe_quoted lib1.src_dir)
|
|
|
|
lib2.name (Path.to_string_maybe_quoted lib2.src_dir)
|
|
|
|
Dep_path.Entries.pp rb2
|
2018-02-20 11:46:10 +00:00
|
|
|
| No_solution_found_for_select { loc } ->
|
|
|
|
Format.fprintf ppf
|
|
|
|
"%a@{<error>Error@}: No solution found for this select form.\n"
|
|
|
|
Loc.print loc
|
|
|
|
| Dependency_cycle cycle ->
|
|
|
|
Format.fprintf ppf
|
|
|
|
"@{<error>Error@}: Dependency cycle detected between the \
|
2018-03-09 20:43:57 +00:00
|
|
|
following libraries:@\n\
|
2018-02-23 09:17:37 +00:00
|
|
|
@[<v>%a@]\n"
|
2018-02-20 11:46:10 +00:00
|
|
|
(Format.pp_print_list (fun ppf (path, name) ->
|
|
|
|
Format.fprintf ppf "-> %S in %s"
|
|
|
|
name (Path.to_string_maybe_quoted path)))
|
|
|
|
cycle
|
2018-03-12 17:58:54 +00:00
|
|
|
| Private_deps_not_allowed t ->
|
2018-03-12 16:38:23 +00:00
|
|
|
Format.fprintf ppf
|
2018-03-12 17:58:54 +00:00
|
|
|
"@{<error>Error@}: Library %S is private, it cannot be a dependency of \
|
2018-03-12 17:02:28 +00:00
|
|
|
a public library.\nYou need to give %S a public name.\n"
|
2018-03-12 16:38:23 +00:00
|
|
|
t.private_dep.name
|
2018-03-12 17:02:28 +00:00
|
|
|
t.private_dep.name
|
2018-02-20 11:46:10 +00:00
|
|
|
|
|
|
|
let () =
|
2018-02-23 09:17:37 +00:00
|
|
|
Report_error.register (fun exn ->
|
2018-02-20 11:46:10 +00:00
|
|
|
match exn with
|
2018-02-23 09:17:37 +00:00
|
|
|
| Error e ->
|
|
|
|
let loc, hint =
|
|
|
|
match e with
|
|
|
|
| Library_not_available { loc; _ } ->
|
|
|
|
(Some loc,
|
|
|
|
match !Clflags.external_lib_deps_hint with
|
|
|
|
| [] -> (* during bootstrap *) None
|
|
|
|
| l ->
|
|
|
|
Some (List.map l ~f:quote_for_shell |> String.concat ~sep:" "))
|
2018-03-12 17:58:54 +00:00
|
|
|
| Private_deps_not_allowed t ->
|
|
|
|
(Some t.pd_loc, None)
|
2018-02-23 09:17:37 +00:00
|
|
|
| _ -> (None, None)
|
|
|
|
in
|
|
|
|
Some
|
|
|
|
{ Report_error.
|
|
|
|
loc
|
|
|
|
; hint
|
|
|
|
; pp = (fun ppf -> report_lib_error ppf e)
|
|
|
|
; backtrace = false
|
|
|
|
}
|
|
|
|
| _ -> None)
|