From 9b409da35226754e79e48facdadefbeb0ad620f9 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 4 Sep 2018 11:20:46 +0400 Subject: [PATCH] Add virtual implementation info to lib info Only support internal vlibs and implementations for now Signed-off-by: Rudi Grinberg --- src/dir_contents.ml | 3 +-- src/dune_file.ml | 10 +++++++--- src/dune_file.mli | 3 ++- src/lib.ml | 30 ++++++++++++++++++++++++++---- src/lib_info.ml | 31 +++++++++++++++++++++++++++++++ src/lib_info.mli | 19 +++++++++++++++++++ src/module.ml | 3 +++ src/module.mli | 2 ++ 8 files changed, 91 insertions(+), 10 deletions(-) diff --git a/src/dir_contents.ml b/src/dir_contents.ml index f02001a0..8217fc52 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -231,8 +231,7 @@ end = struct let make (lib : Library.t) ~dir (modules : Module.Name_map.t) ~virtual_modules = - let main_module_name = - Module.Name.of_string (Lib_name.Local.to_string lib.name) in + let main_module_name = Library.main_module_name lib in let (modules, wrapped_compat) = let wrap_modules modules = let open Module.Name.Infix in diff --git a/src/dune_file.ml b/src/dune_file.ml index ac3a52d0..4aeb1d50 100644 --- a/src/dune_file.ml +++ b/src/dune_file.ml @@ -916,7 +916,7 @@ module Library = struct ; no_keep_locs : bool ; dune_version : Syntax.Version.t ; virtual_modules : Ordered_set_lang.t option - ; implements : (Loc.t * string) option + ; implements : (Loc.t * Lib_name.t) option } let dparse = @@ -958,7 +958,7 @@ module Library = struct and implements = field_o "implements" ( Syntax.since Variants.syntax (0, 1) - >>= fun () -> (located string)) + >>= fun () -> located Lib_name.dparse) in let name = let open Syntax.Version.Infix in @@ -993,7 +993,8 @@ module Library = struct of_sexp_errorf (Ordered_set_lang.loc virtual_modules |> Option.value_exn) - "A library cannot be both virtual and implement %s" impl); + "A library cannot be both virtual and implement %s" + (Lib_name.to_string impl)); begin match virtual_modules, wrapped, implements with | Some _, Some (loc, Wrapped.Simple false), _ -> of_sexp_error loc "A virtual library must be wrapped" @@ -1052,6 +1053,9 @@ module Library = struct | Some p -> snd p.name let is_virtual t = Option.is_some t.virtual_modules + + let main_module_name t = + Module.Name.of_local_lib_name t.name end module Install_conf = struct diff --git a/src/dune_file.mli b/src/dune_file.mli index e025649a..2a25307c 100644 --- a/src/dune_file.mli +++ b/src/dune_file.mli @@ -250,7 +250,7 @@ module Library : sig ; no_keep_locs : bool ; dune_version : Syntax.Version.t ; virtual_modules : Ordered_set_lang.t option - ; implements : (Loc.t * string) option + ; implements : (Loc.t * Lib_name.t) option } val has_stubs : t -> bool @@ -259,6 +259,7 @@ module Library : sig val archive : t -> dir:Path.t -> ext:string -> Path.t val best_name : t -> Lib_name.t val is_virtual : t -> bool + val main_module_name : t -> Module.Name.t end module Install_conf : sig diff --git a/src/lib.ml b/src/lib.ml index c475fab8..ce3ba6d9 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -82,6 +82,7 @@ type t = ; pps : t list Or_exn.t ; resolved_selects : Resolved_select.t list ; user_written_deps : Dune_file.Lib_deps.t + ; implements : t Or_exn.t option ; (* This is mutable to avoid this error: {[ @@ -492,11 +493,33 @@ let rec instantiate db name (info : Lib_info.t) ~stack ~hidden = let allow_private_deps = Lib_info.Status.is_private info.status in + let resolve (loc, name) = + resolve_dep db (name : Lib_name.t) ~allow_private_deps ~loc ~stack in + + let implements = Option.map info.implements ~f:resolve in + let requires, pps, resolved_selects = resolve_user_deps db info.requires ~allow_private_deps ~pps:info.pps ~stack in + let requires = + match implements with + | None -> requires + | Some implements -> + implements >>= fun implements -> + implements.requires >>= fun irequires -> + requires >>| fun requires -> + L.remove_dups (List.rev_append irequires requires) + in let ppx_runtime_deps = - resolve_simple_deps db info.ppx_runtime_deps ~allow_private_deps ~stack + let ppx_rd = + resolve_simple_deps db info.ppx_runtime_deps ~allow_private_deps ~stack in + match implements with + | None -> ppx_rd + | Some implements -> + implements >>= fun implements -> + implements.ppx_runtime_deps >>= fun ippx_rd -> + ppx_rd >>| fun ppx_rd -> + L.remove_dups (List.rev_append ippx_rd ppx_rd) in let map_error x = Result.map_error x ~f:(fun e -> @@ -504,8 +527,6 @@ let rec instantiate db name (info : Lib_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 : Lib_name.t) ~allow_private_deps ~loc ~stack in let t = { info ; name @@ -516,6 +537,7 @@ let rec instantiate db name (info : Lib_info.t) ~stack ~hidden = ; resolved_selects ; user_written_deps = Lib_info.user_written_deps info ; sub_systems = Sub_system_name.Map.empty + ; implements } in t.sub_systems <- @@ -702,7 +724,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack = in (deps, pps, resolved_selects) - and closure_with_overlap_checks db ts ~stack = +and closure_with_overlap_checks db ts ~stack = let visited = ref Lib_name.Map.empty in let res = ref [] in let orig_stack = stack in diff --git a/src/lib_info.ml b/src/lib_info.ml index 39908449..69665355 100644 --- a/src/lib_info.ml +++ b/src/lib_info.ml @@ -41,6 +41,23 @@ module Deps = struct | Complex l -> l end +module Virtual = struct + module Modules = struct + type t = + | Unexpanded + end + + module Dep_graph = struct + type t = + | Local + end + + type t = + { modules : Modules.t + ; dep_graph : Dep_graph.t + } +end + type t = { loc : Loc.t ; kind : Dune_file.Library.Kind.t @@ -60,6 +77,8 @@ type t = ; 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 + ; virtual_ : Virtual.t option + ; implements : (Loc.t * Lib_name.t) option } let user_written_deps t = @@ -96,6 +115,14 @@ let of_library_stanza ~dir ~ext_lib (conf : Dune_file.Library.t) = :: stubs } in + let virtual_ = + Option.map conf.virtual_modules ~f:(fun _ -> + { Virtual. + modules = Virtual.Modules.Unexpanded + ; dep_graph = Virtual.Dep_graph.Local + } + ) + in { loc = conf.buildable.loc ; kind = conf.kind ; src_dir = dir @@ -114,6 +141,8 @@ let of_library_stanza ~dir ~ext_lib (conf : Dune_file.Library.t) = ; pps = Dune_file.Preprocess_map.pps conf.buildable.preprocess ; sub_systems = conf.sub_systems ; dune_version = Some conf.dune_version + ; virtual_ + ; implements = conf.implements } let of_findlib_package pkg = @@ -144,4 +173,6 @@ let of_findlib_package pkg = foreign_archives = Mode.Dict.make_both [] ; sub_systems = sub_systems ; dune_version = None + ; virtual_ = None + ; implements = None } diff --git a/src/lib_info.mli b/src/lib_info.mli index f3512b43..e70e4bd8 100644 --- a/src/lib_info.mli +++ b/src/lib_info.mli @@ -21,6 +21,23 @@ module Deps : sig val of_lib_deps : Dune_file.Lib_deps.t -> t end +module Virtual : sig + module Modules : sig + type t = private + | Unexpanded + end + + module Dep_graph : sig + type t = private + | Local + end + + type t = private + { modules : Modules.t + ; dep_graph : Dep_graph.t + } +end + type t = private { loc : Loc.t ; kind : Dune_file.Library.Kind.t @@ -40,6 +57,8 @@ type t = private ; 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 + ; virtual_ : Virtual.t option + ; implements : (Loc.t * Lib_name.t) option } val of_library_stanza diff --git a/src/module.ml b/src/module.ml index 80492ce4..1dc8ad78 100644 --- a/src/module.ml +++ b/src/module.ml @@ -28,6 +28,9 @@ module Name = struct module Map = String.Map module Top_closure = Top_closure.String module Infix = Comparable.Operators(T) + + let of_local_lib_name s = + of_string (Lib_name.Local.to_string s) end module Syntax = struct diff --git a/src/module.mli b/src/module.mli index 87abc39b..32a58b0d 100644 --- a/src/module.mli +++ b/src/module.mli @@ -24,6 +24,8 @@ module Name : sig module Top_closure : Top_closure.S with type key := t module Infix : Comparable.OPS with type t = t + + val of_local_lib_name : Lib_name.Local.t -> t end module Syntax : sig