diff --git a/src/lib.ml b/src/lib.ml index 8d44808b..c475fab8 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -2,196 +2,6 @@ open Import open! Stdune open Result.O -(* +-----------------------------------------------------------------+ - | Raw library information | - +-----------------------------------------------------------------+ *) - -module Status = struct - type t = - | Installed - | Public of Package.t - | Private of Dune_project.Name.t - - let pp ppf t = - Format.pp_print_string ppf - (match t with - | Installed -> "installed" - | Public _ -> "public" - | Private name -> - sprintf "private (%s)" (Dune_project.Name.to_string_hum name)) - - let is_private = function - | Private _ -> true - | Installed | Public _ -> false -end - -module Info : sig - module Deps : sig - type t = - | Simple of (Loc.t * Lib_name.t) list - | Complex of Dune_file.Lib_dep.t list - - val of_lib_deps : Dune_file.Lib_deps.t -> t - end - - type t = private - { loc : Loc.t - ; kind : Dune_file.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 (** [.a/.lib/...] files *) - ; jsoo_runtime : Path.t list - ; requires : Deps.t - ; ppx_runtime_deps : (Loc.t * Lib_name.t) list - ; pps : (Loc.t * Dune_file.Pp.t) list - ; optional : bool - ; virtual_deps : (Loc.t * Lib_name.t) list - ; dune_version : Syntax.Version.t option - ; sub_systems : Dune_file.Sub_system_info.t Sub_system_name.Map.t - } - - val of_library_stanza - : dir:Path.t - -> ext_lib:string - -> Dune_file.Library.t - -> t - - val of_findlib_package : Findlib.Package.t -> t - - val user_written_deps : t -> Dune_file.Lib_deps.t -end = struct - module Deps = struct - type t = - | Simple of (Loc.t * Lib_name.t) list - | Complex of Dune_file.Lib_dep.t list - - let of_lib_deps deps = - let rec loop acc (deps : Dune_file.Lib_dep.t list) = - match deps with - | [] -> Some (List.rev acc) - | Direct x :: deps -> loop (x :: acc) deps - | Select _ :: _ -> None - in - match loop [] deps with - | Some l -> Simple l - | None -> Complex deps - - let to_lib_deps = function - | Simple l -> List.map l ~f:Dune_file.Lib_dep.direct - | Complex l -> l - end - - type t = - { loc : Loc.t - ; kind : Dune_file.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 - ; ppx_runtime_deps : (Loc.t * Lib_name.t) list - ; pps : (Loc.t * Dune_file.Pp.t) list - ; optional : bool - ; virtual_deps : (Loc.t * Lib_name.t) list - ; dune_version : Syntax.Version.t option - ; sub_systems : Dune_file.Sub_system_info.t Sub_system_name.Map.t - } - - let user_written_deps t = - List.fold_left (t.virtual_deps @ t.ppx_runtime_deps) - ~init:(Deps.to_lib_deps t.requires) - ~f:(fun acc s -> Dune_file.Lib_dep.Direct s :: acc) - - let of_library_stanza ~dir ~ext_lib (conf : Dune_file.Library.t) = - let archive_file ext = - Path.relative dir (Lib_name.Local.to_string conf.name ^ ext) in - let archive_files ~f_ext = - Mode.Dict.of_func (fun ~mode -> [archive_file (f_ext mode)]) - 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 (Dune_project.name conf.project) - | Some p -> Public p.package - in - let foreign_archives = - let stubs = - if Dune_file.Library.has_stubs conf then - [Dune_file.Library.stubs_archive conf ~dir ~ext_lib] - else - [] - in - { Mode.Dict. - byte = stubs - ; native = - Path.relative dir (Lib_name.Local.to_string conf.name ^ ext_lib) - :: 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 - ; virtual_deps = conf.virtual_deps - ; requires = Deps.of_lib_deps conf.buildable.libraries - ; ppx_runtime_deps = conf.ppx_runtime_libraries - ; pps = Dune_file.Preprocess_map.pps conf.buildable.preprocess - ; sub_systems = conf.sub_systems - ; dune_version = Some conf.dune_version - } - - let of_findlib_package pkg = - let module P = Findlib.Package in - 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 fn - in - { loc = loc - ; 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 - ; requires = Simple (List.map (P.requires pkg) ~f:add_loc) - ; ppx_runtime_deps = List.map (P.ppx_runtime_deps pkg) ~f:add_loc - ; pps = [] - ; virtual_deps = [] - ; optional = false - ; status = Installed - ; (* We don't know how these are named for external libraries *) - foreign_archives = Mode.Dict.make_both [] - ; sub_systems = sub_systems - ; dune_version = None - } -end - (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) @@ -264,7 +74,7 @@ module Id = struct end type t = - { info : Info.t + { info : Lib_info.t ; name : Lib_name.t ; unique_id : int ; requires : t list Or_exn.t @@ -304,8 +114,8 @@ and error = and resolve_result = | Not_found - | Found of Info.t - | Hidden of Info.t * string + | Found of Lib_info.t + | Hidden of Lib_info.t * string | Redirect of db option * Lib_name.t and conflict = @@ -635,13 +445,14 @@ module Dep_stack = struct end let check_private_deps lib ~loc ~allow_private_deps = - if (not allow_private_deps) && Status.is_private lib.info.status then + if (not allow_private_deps) && Lib_info.Status.is_private lib.info.status + then Result.Error (Error ( Private_deps_not_allowed { private_dep = lib ; pd_loc = loc })) else Ok lib -let already_in_table (info : Info.t) name x = +let already_in_table (info : Lib_info.t) name x = let to_sexp = Sexp.To_sexp.(pair Path.to_sexp Lib_name.to_sexp) in let sexp = match x with @@ -670,7 +481,7 @@ let result_of_resolve_status = function | 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 rec instantiate db name (info : Lib_info.t) ~stack ~hidden = let id, stack = Dep_stack.create_and_push stack name info.src_dir in @@ -679,7 +490,7 @@ 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 allow_private_deps = Lib_info.Status.is_private info.status in let requires, pps, resolved_selects = resolve_user_deps db info.requires ~allow_private_deps ~pps:info.pps ~stack @@ -703,7 +514,7 @@ let rec instantiate db name (info : Info.t) ~stack ~hidden = ; ppx_runtime_deps ; pps ; resolved_selects - ; user_written_deps = Info.user_written_deps info + ; user_written_deps = Lib_info.user_written_deps info ; sub_systems = Sub_system_name.Map.empty } in @@ -787,9 +598,8 @@ and resolve_name db name ~stack = instantiate db name info ~stack ~hidden:(Some hidden) and available_internal db (name : Lib_name.t) ~stack = - match resolve_dep db name ~allow_private_deps:true ~loc:Loc.none ~stack with - | Ok _ -> true - | Error _ -> false + resolve_dep db name ~allow_private_deps:true ~loc:Loc.none ~stack + |> Result.is_ok and resolve_simple_deps db (names : ((Loc.t * Lib_name.t) list)) ~allow_private_deps ~stack = Result.List.map names ~f:(fun (loc, name) -> @@ -848,7 +658,7 @@ and resolve_complex_deps db deps ~allow_private_deps ~stack = (res, resolved_selects) and resolve_deps db deps ~allow_private_deps ~stack = - match (deps : Info.Deps.t) with + match (deps : Lib_info.Deps.t) with | Simple names -> (resolve_simple_deps db names ~allow_private_deps ~stack, []) | Complex names -> @@ -991,8 +801,8 @@ module DB = struct module Resolve_result = struct type t = resolve_result = | Not_found - | Found of Info.t - | Hidden of Info.t * string + | Found of Lib_info.t + | Hidden of Lib_info.t * string | Redirect of db option * Lib_name.t end @@ -1008,7 +818,7 @@ module DB = struct let create_from_library_stanzas ?parent ~ext_lib stanzas = let map = List.concat_map stanzas ~f:(fun (dir, (conf : Dune_file.Library.t)) -> - let info = Info.of_library_stanza ~dir ~ext_lib conf in + let info = Lib_info.of_library_stanza ~dir ~ext_lib conf in match conf.public with | None -> [Dune_file.Library.best_name conf, Resolve_result.Found info] @@ -1053,18 +863,18 @@ module DB = struct create () ~resolve:(fun name -> match Findlib.find findlib name with - | Ok pkg -> Found (Info.of_findlib_package pkg) + | Ok pkg -> Found (Lib_info.of_findlib_package pkg) | Error e -> match e with | Not_found -> if external_lib_deps_mode then Found - (Info.of_findlib_package + (Lib_info.of_findlib_package (Findlib.dummy_package findlib ~name)) else Not_found | Hidden pkg -> - Hidden (Info.of_findlib_package pkg, + Hidden (Lib_info.of_findlib_package pkg, "unsatisfied 'exist_if'")) ~all:(fun () -> Findlib.all_packages findlib @@ -1099,7 +909,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 + resolve_user_deps t (Lib_info.Deps.of_lib_deps deps) ~pps ~stack:Dep_stack.empty ~allow_private_deps:true in let requires = diff --git a/src/lib.mli b/src/lib.mli index 87570595..c414103e 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -37,16 +37,7 @@ module Set : Set.S with type elt = t module Map : Map.S with type key = t -module Status : sig - type t = - | Installed - | Public of Package.t - | Private of Dune_project.Name.t - - val pp : t Fmt.t -end - -val status : t -> Status.t +val status : t -> Lib_info.Status.t val package : t -> Package.Name.t option @@ -87,13 +78,6 @@ module Lib_and_module : sig end -(** {1 Raw library descriptions} *) - -(** Information about a library *) -module Info : sig - type t -end - (** {1 Errors} *) module Error : sig @@ -215,8 +199,8 @@ module DB : sig module Resolve_result : sig type nonrec t = | Not_found - | Found of Info.t - | Hidden of Info.t * string + | Found of Lib_info.t + | Hidden of Lib_info.t * string | Redirect of t option * Lib_name.t end diff --git a/src/lib_info.ml b/src/lib_info.ml new file mode 100644 index 00000000..39908449 --- /dev/null +++ b/src/lib_info.ml @@ -0,0 +1,147 @@ +open Stdune + +module Status = struct + type t = + | Installed + | Public of Package.t + | Private of Dune_project.Name.t + + let pp ppf t = + Format.pp_print_string ppf + (match t with + | Installed -> "installed" + | Public _ -> "public" + | Private name -> + sprintf "private (%s)" (Dune_project.Name.to_string_hum name)) + + let is_private = function + | Private _ -> true + | Installed | Public _ -> false +end + + +module Deps = struct + type t = + | Simple of (Loc.t * Lib_name.t) list + | Complex of Dune_file.Lib_dep.t list + + let of_lib_deps deps = + let rec loop acc (deps : Dune_file.Lib_dep.t list) = + match deps with + | [] -> Some (List.rev acc) + | Direct x :: deps -> loop (x :: acc) deps + | Select _ :: _ -> None + in + match loop [] deps with + | Some l -> Simple l + | None -> Complex deps + + let to_lib_deps = function + | Simple l -> List.map l ~f:Dune_file.Lib_dep.direct + | Complex l -> l +end + +type t = + { loc : Loc.t + ; kind : Dune_file.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 + ; ppx_runtime_deps : (Loc.t * Lib_name.t) list + ; pps : (Loc.t * Dune_file.Pp.t) list + ; optional : bool + ; virtual_deps : (Loc.t * Lib_name.t) list + ; dune_version : Syntax.Version.t option + ; sub_systems : Dune_file.Sub_system_info.t Sub_system_name.Map.t + } + +let user_written_deps t = + List.fold_left (t.virtual_deps @ t.ppx_runtime_deps) + ~init:(Deps.to_lib_deps t.requires) + ~f:(fun acc s -> Dune_file.Lib_dep.Direct s :: acc) + +let of_library_stanza ~dir ~ext_lib (conf : Dune_file.Library.t) = + let archive_file ext = + Path.relative dir (Lib_name.Local.to_string conf.name ^ ext) in + let archive_files ~f_ext = + Mode.Dict.of_func (fun ~mode -> [archive_file (f_ext mode)]) + 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 (Dune_project.name conf.project) + | Some p -> Public p.package + in + let foreign_archives = + let stubs = + if Dune_file.Library.has_stubs conf then + [Dune_file.Library.stubs_archive conf ~dir ~ext_lib] + else + [] + in + { Mode.Dict. + byte = stubs + ; native = + Path.relative dir (Lib_name.Local.to_string conf.name ^ ext_lib) + :: 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 + ; virtual_deps = conf.virtual_deps + ; requires = Deps.of_lib_deps conf.buildable.libraries + ; ppx_runtime_deps = conf.ppx_runtime_libraries + ; pps = Dune_file.Preprocess_map.pps conf.buildable.preprocess + ; sub_systems = conf.sub_systems + ; dune_version = Some conf.dune_version + } + +let of_findlib_package pkg = + let module P = Findlib.Package in + 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 fn + in + { loc = loc + ; 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 + ; requires = Simple (List.map (P.requires pkg) ~f:add_loc) + ; ppx_runtime_deps = List.map (P.ppx_runtime_deps pkg) ~f:add_loc + ; pps = [] + ; virtual_deps = [] + ; optional = false + ; status = Installed + ; (* We don't know how these are named for external libraries *) + foreign_archives = Mode.Dict.make_both [] + ; sub_systems = sub_systems + ; dune_version = None + } diff --git a/src/lib_info.mli b/src/lib_info.mli new file mode 100644 index 00000000..f3512b43 --- /dev/null +++ b/src/lib_info.mli @@ -0,0 +1,53 @@ +(** {1 Raw library descriptions} *) + +open Stdune + +module Status : sig + type t = + | Installed + | Public of Package.t + | Private of Dune_project.Name.t + + val pp : t Fmt.t + + val is_private : t -> bool +end + +module Deps : sig + type t = + | Simple of (Loc.t * Lib_name.t) list + | Complex of Dune_file.Lib_dep.t list + + val of_lib_deps : Dune_file.Lib_deps.t -> t +end + +type t = private + { loc : Loc.t + ; kind : Dune_file.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 (** [.a/.lib/...] files *) + ; jsoo_runtime : Path.t list + ; requires : Deps.t + ; ppx_runtime_deps : (Loc.t * Lib_name.t) list + ; pps : (Loc.t * Dune_file.Pp.t) list + ; optional : bool + ; virtual_deps : (Loc.t * Lib_name.t) list + ; dune_version : Syntax.Version.t option + ; sub_systems : Dune_file.Sub_system_info.t Sub_system_name.Map.t + } + +val of_library_stanza + : dir:Path.t + -> ext_lib:string + -> Dune_file.Library.t + -> t + +val of_findlib_package : Findlib.Package.t -> t + +val user_written_deps : t -> Dune_file.Lib_deps.t diff --git a/src/link_time_code_gen.ml b/src/link_time_code_gen.ml index 762dbfbb..a65f3d5a 100644 --- a/src/link_time_code_gen.ml +++ b/src/link_time_code_gen.ml @@ -23,7 +23,7 @@ let libraries_link ~name ~mode cctx libs = after findlib.dynload a module containing the info *) let libs = List.filter - ~f:(fun lib -> match Lib.status lib with | Lib.Status.Private _ -> false | _ -> true) + ~f:(fun lib -> not (Lib_info.Status.is_private (Lib.status lib))) libs in let preds = Variant.Set.add Findlib.Package.preds (Mode.variant mode) in