From 8b81f43733c390bd83cb64aaaab5d222f780edc9 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 17 Sep 2019 19:54:56 +0900 Subject: [PATCH] Add support for re_exports constructor Signed-off-by: Rudi Grinberg --- src/dune/dune_package.ml | 24 +++---- src/dune/dune_package.mli | 1 - src/dune/findlib/findlib.ml | 6 +- src/dune/lib.ml | 70 +++++++++---------- src/dune/lib_dep.ml | 33 ++++++--- src/dune/lib_dep.mli | 6 ++ src/dune/lib_info.ml | 32 ++++----- src/dune/lib_info.mli | 7 +- src/dune_lang/encoder.mli | 2 + .../test-cases/re-exported-deps/run.t | 8 +-- 10 files changed, 99 insertions(+), 90 deletions(-) diff --git a/src/dune/dune_package.ml b/src/dune/dune_package.ml index c9e445fa2c96..b679a63fea79 100644 --- a/src/dune/dune_package.ml +++ b/src/dune/dune_package.ml @@ -14,10 +14,9 @@ module Lib = struct { info : Path.t Lib_info.t ; modules : Modules.t option ; main_module_name : Module_name.t option - ; requires : (Loc.t * Lib_name.t) list } - let make ~info ~main_module_name ~requires ~modules = + let make ~info ~main_module_name ~modules = let obj_dir = Lib_info.obj_dir info in let dir = Obj_dir.dir obj_dir in let map_path p = @@ -27,13 +26,13 @@ module Lib = struct p in let info = Lib_info.map_path info ~f:map_path in - { info; main_module_name; requires; modules } + { info; main_module_name; modules } let dir_of_name name = let _, components = Lib_name.split name in Path.Local.L.relative Path.Local.root components - let encode ~package_root { info; requires; main_module_name; modules } = + let encode ~package_root { info; main_module_name; modules } = let open Dune_lang.Encoder in let no_loc f (_loc, x) = f x in let path = Dpath.Local.encode ~dir:package_root in @@ -55,10 +54,10 @@ module Lib = struct let ppx_runtime_deps = Lib_info.ppx_runtime_deps info in let default_implementation = Lib_info.default_implementation info in let special_builtin_support = Lib_info.special_builtin_support info in - let re_exports = Lib_info.re_exports info in let archives = Lib_info.archives info in let sub_systems = Lib_info.sub_systems info in let plugins = Lib_info.plugins info in + let requires = Lib_info.requires info in let foreign_archives = Lib_info.foreign_archives info in let foreign_objects = match Lib_info.foreign_objects info with @@ -78,7 +77,7 @@ module Lib = struct ; paths "foreign_objects" foreign_objects ; mode_paths "foreign_archives" foreign_archives ; paths "jsoo_runtime" jsoo_runtime - ; libs "requires" requires + ; Lib_info.Deps.field_encode requires ~name:"requires" ; libs "ppx_runtime_deps" ppx_runtime_deps ; field_o "implements" (no_loc Lib_name.encode) implements ; field_l "known_implementations" @@ -93,7 +92,6 @@ module Lib = struct ; field_o "special_builtin_support" Dune_file.Library.Special_builtin_support.encode special_builtin_support - ; field_l "re_exports" (no_loc Lib_name.encode) re_exports ] @ ( Sub_system_name.Map.to_list sub_systems |> List.map ~f:(fun (name, info) -> @@ -136,7 +134,7 @@ module Lib = struct and+ foreign_objects = paths "foreign_objects" and+ foreign_archives = mode_paths "foreign_archives" and+ jsoo_runtime = paths "jsoo_runtime" - and+ requires = libs "requires" + and+ requires = field_l "requires" Lib_dep.decode and+ ppx_runtime_deps = libs "ppx_runtime_deps" and+ virtual_ = field_b "virtual" and+ known_implementations = @@ -154,10 +152,6 @@ module Lib = struct field_o "special_builtin_support" ( Dune_lang.Syntax.since Stanza.syntax (1, 10) >>> Dune_file.Library.Special_builtin_support.decode ) - and+ re_exports = - field_l "re_exports" - ( Dune_lang.Syntax.since Stanza.syntax (2, 0) - >>> located Lib_name.decode ) in let known_implementations = Variant.Map.of_list_exn known_implementations @@ -172,7 +166,6 @@ module Lib = struct Dune_file.Library.Inherited.This main_module_name in let foreign_objects = Lib_info.Source.External foreign_objects in - let requires = Lib_info.Deps.Simple requires in let jsoo_archive = None in let pps = [] in let virtual_deps = [] in @@ -189,15 +182,16 @@ module Lib = struct Option.map modules ~f:Modules.wrapped |> Option.map ~f:(fun w -> Dune_file.Library.Inherited.This w) in + let requires = Lib_info.Deps.Complex requires in Lib_info.create ~loc ~name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ~synopsis ~main_module_name ~sub_systems ~requires ~foreign_objects ~plugins ~archives ~ppx_runtime_deps ~foreign_archives ~jsoo_runtime ~jsoo_archive ~pps ~enabled ~virtual_deps ~dune_version ~virtual_ ~implements ~variant ~known_implementations ~default_implementation ~modes ~wrapped - ~special_builtin_support ~re_exports + ~special_builtin_support in - { info; requires; main_module_name; modules }) + { info; main_module_name; modules }) let modules t = t.modules diff --git a/src/dune/dune_package.mli b/src/dune/dune_package.mli index 3f70ad4e2cf1..b92c20c3ceb6 100644 --- a/src/dune/dune_package.mli +++ b/src/dune/dune_package.mli @@ -18,7 +18,6 @@ module Lib : sig val make : info:Path.t Lib_info.t -> main_module_name:Module_name.t option - -> requires:(Loc.t * Lib_name.t) list -> modules:Modules.t option -> t end diff --git a/src/dune/findlib/findlib.ml b/src/dune/findlib/findlib.ml index 5573c02938c7..c177f27aadb3 100644 --- a/src/dune/findlib/findlib.ml +++ b/src/dune/findlib/findlib.ml @@ -280,18 +280,14 @@ module Package = struct let known_implementations = P.Map.empty in let default_implementation = None in let wrapped = None in - let re_exports = [] in Lib_info.create ~loc ~name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ~synopsis ~main_module_name ~sub_systems ~requires ~foreign_objects ~plugins ~archives ~ppx_runtime_deps ~foreign_archives ~jsoo_runtime ~jsoo_archive ~pps ~enabled ~virtual_deps ~dune_version ~virtual_ ~implements ~variant ~known_implementations ~default_implementation ~modes ~wrapped ~special_builtin_support - ~re_exports in - Dune_package.Lib.make ~info - ~requires:(List.map ~f:add_loc (requires t)) - ~modules:None ~main_module_name:None + Dune_package.Lib.make ~info ~modules:None ~main_module_name:None (* XXX remove *) diff --git a/src/dune/lib.ml b/src/dune/lib.ml index d2f642e48a73..5bf66caa2f74 100644 --- a/src/dune/lib.ml +++ b/src/dune/lib.ml @@ -919,7 +919,10 @@ module rec Resolve : sig -> allow_private_deps:bool -> pps:(Loc.t * Lib_name.t) list -> stack:Dep_stack.t - -> lib list Or_exn.t * lib list Or_exn.t * Resolved_select.t list + -> lib list Or_exn.t + * lib list Or_exn.t + * Resolved_select.t list + * lib list Or_exn.t val closure_with_overlap_checks : db option @@ -1003,7 +1006,7 @@ end = struct Lib_info.known_implementations info |> Variant.Map.map ~f:resolve_impl )) in - let requires, pps, resolved_selects = + let requires, pps, resolved_selects, re_exports = let pps = Lib_info.pps info in Lib_info.requires info |> resolve_user_deps db ~allow_private_deps ~pps ~stack @@ -1016,10 +1019,6 @@ end = struct let+ requires = requires in impl :: requires in - let re_exports : t list Or_exn.t = - Lib_info.re_exports info - |> resolve_simple_deps db ~allow_private_deps ~stack - in let ppx_runtime_deps = Lib_info.ppx_runtime_deps info |> resolve_simple_deps db ~allow_private_deps ~stack @@ -1141,18 +1140,23 @@ end = struct List.rev !res let 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 = + let res, resolved_selects, re_exports = + List.fold_left deps ~init:(Ok [], [], Ok []) + ~f:(fun (acc_res, acc_selects, acc_re_exports) dep -> + let res, acc_selects, acc_re_exports = match (dep : Lib_dep.t) with - | Re_export _ -> assert false + | Re_export (loc, name) -> + let acc_re_exports = + resolve_dep db name ~allow_private_deps ~loc ~stack + >>| List.singleton + in + (acc_res, acc_selects, acc_re_exports) | Direct (loc, name) -> let res = resolve_dep db name ~allow_private_deps ~loc ~stack >>| List.singleton in - (res, acc_selects) + (res, acc_selects, acc_re_exports) | Select { result_fn; choices; loc } -> let res, src_fn = match @@ -1182,7 +1186,7 @@ end = struct in ( res , { Resolved_select.src_fn; dst_fn = result_fn } :: acc_selects - ) + , acc_re_exports ) in let res = match (res, acc_res) with @@ -1191,29 +1195,20 @@ end = struct |_, (Error _ as res) -> res in - (res, acc_selects)) - in - let res = - match res with - | Ok l -> Ok (List.rev l) - | Error _ -> res + (res, acc_selects, acc_re_exports)) in - (res, resolved_selects) + let res = Result.map ~f:List.rev res in + let re_exports = Result.map ~f:List.rev re_exports in + (res, resolved_selects, re_exports) let resolve_deps db deps ~allow_private_deps ~stack = - (* Compute transitive closure *) - let libs, selects = - match (deps : Lib_info.Deps.t) with - | Simple names -> - (resolve_simple_deps db names ~allow_private_deps ~stack, []) - | Complex names -> - resolve_complex_deps db names ~allow_private_deps ~stack - in - (* Find implementations for virtual libraries. *) - (libs, selects) + match (deps : Lib_info.Deps.t) with + | Simple names -> + (resolve_simple_deps db names ~allow_private_deps ~stack, [], Ok []) + | Complex names -> resolve_complex_deps db names ~allow_private_deps ~stack let resolve_user_deps db deps ~allow_private_deps ~pps ~stack = - let deps, resolved_selects = + let deps, resolved_selects, re_exports = resolve_deps db deps ~allow_private_deps ~stack in let deps, pps = @@ -1248,7 +1243,7 @@ end = struct (deps, pps) in let deps = deps >>= re_exports_closure in - (deps, pps, resolved_selects) + (deps, pps, resolved_selects, re_exports) (* Compute transitive closure of libraries to figure which ones will trigger their default implementation. @@ -1751,7 +1746,7 @@ module DB = struct else Required ) in - let res, pps, resolved_selects = + let res, pps, resolved_selects, _re_exports = Resolve.resolve_user_deps t (Lib_info.Deps.of_lib_deps deps) ~pps ~stack:Dep_stack.empty ~allow_private_deps:true @@ -1899,9 +1894,12 @@ let to_dune_lib ({ info; _ } as lib) ~modules ~foreign_objects ~dir = let requires = add_loc requires in let+ re_exports = lib.re_exports in let re_exports = List.map ~f:(fun t -> (Loc.none, t.name)) re_exports in - let info = Lib_info.set_re_exports info re_exports in - Dune_package.Lib.make ~info ~requires ~modules:(Some modules) - ~main_module_name + let requires = + List.map ~f:Lib_dep.direct requires + @ List.map ~f:Lib_dep.re_export re_exports + in + let info = Lib_info.set_requires info (Complex requires) in + Dune_package.Lib.make ~info ~modules:(Some modules) ~main_module_name module Local : sig type t = private lib diff --git a/src/dune/lib_dep.ml b/src/dune/lib_dep.ml index 5e03f1db7128..122e46f15c7e 100644 --- a/src/dune/lib_dep.ml +++ b/src/dune/lib_dep.ml @@ -10,9 +10,9 @@ module Select = struct let dyn_of_choice { required; forbidden; file } = let open Dyn.Encoder in record - [ "required", Lib_name.Set.to_dyn required - ; "forbidden", Lib_name.Set.to_dyn forbidden - ; "file", string file + [ ("required", Lib_name.Set.to_dyn required) + ; ("forbidden", Lib_name.Set.to_dyn forbidden) + ; ("file", string file) ] type t = @@ -21,11 +21,11 @@ module Select = struct ; loc : Loc.t } - let to_dyn { result_fn ; choices ; loc = _ } = + let to_dyn { result_fn; choices; loc = _ } = let open Dyn.Encoder in record - [ "result_fn", string result_fn - ; "choices", list dyn_of_choice choices + [ ("result_fn", string result_fn) + ; ("choices", list dyn_of_choice choices) ] end @@ -38,11 +38,13 @@ let to_dyn = let open Dyn.Encoder in function | Direct (_, name) -> Lib_name.to_dyn name - | Re_export (_, name) -> constr "re_export" [Lib_name.to_dyn name] - | Select s -> constr "select" [Select.to_dyn s] + | Re_export (_, name) -> constr "re_export" [ Lib_name.to_dyn name ] + | Select s -> constr "select" [ Select.to_dyn s ] let direct x = Direct x +let re_export x = Re_export x + let to_lib_names = function | Direct (_, s) |Re_export (_, s) -> @@ -110,3 +112,18 @@ let decode = ~else_: (let+ loc, name = located Lib_name.decode in Direct (loc, name)) + +let encode = + let open Dune_lang.Encoder in + function + | Direct (_, name) -> Lib_name.encode name + | Re_export (_, name) -> constr "re_export" Lib_name.encode name + | Select select -> + Code_error.raise "Lib_dep.encode: cannot encode select" + [ ("select", Select.to_dyn select) ] + +module L = struct + let field_encode t ~name = + let open Dune_lang.Encoder in + field_l name encode t +end diff --git a/src/dune/lib_dep.mli b/src/dune/lib_dep.mli index 71058c570b5c..34c1ba408844 100644 --- a/src/dune/lib_dep.mli +++ b/src/dune/lib_dep.mli @@ -25,8 +25,14 @@ val to_dyn : t -> Dyn.t val direct : Loc.t * Lib_name.t -> t +val re_export : Loc.t * Lib_name.t -> t + val to_lib_names : t -> Lib_name.t list val decode : t Dune_lang.Decoder.t val encode : t Dune_lang.Encoder.t + +module L : sig + val field_encode : t list -> name:string -> Dune_lang.Encoder.field +end diff --git a/src/dune/lib_info.ml b/src/dune/lib_info.ml index a6240754435f..45e02bfdfba6 100644 --- a/src/dune/lib_info.ml +++ b/src/dune/lib_info.ml @@ -37,8 +37,9 @@ module Deps = struct match deps with | [] -> Some (List.rev acc) | Direct x :: deps -> loop (x :: acc) deps - | Re_export _ :: deps -> loop acc deps - | Select _ :: _ -> None + | Re_export _ :: _ + |Select _ :: _ -> + None in match loop [] deps with | Some l -> Simple l @@ -51,9 +52,16 @@ module Deps = struct let to_dyn = let open Dyn.Encoder in function - | Simple xs -> - constr "Simple" [list Lib_name.to_dyn (List.map ~f:snd xs)] - | Complex ld -> constr "Complex" [list Lib_dep.to_dyn ld] + | Simple xs -> constr "Simple" [ list Lib_name.to_dyn (List.map ~f:snd xs) ] + | Complex ld -> constr "Complex" [ list Lib_dep.to_dyn ld ] + + let field_encode t ~name = + let t = + match t with + | Simple l -> List.map ~f:Lib_dep.direct l + | Complex l -> l + in + Lib_dep.L.field_encode t ~name end module Source = struct @@ -107,7 +115,6 @@ type 'path t = ; modes : Mode.Dict.Set.t ; special_builtin_support : Dune_file.Library.Special_builtin_support.t option - ; re_exports : (Loc.t * Lib_name.t) list } let name t = t.name @@ -168,8 +175,6 @@ let main_module_name t = t.main_module_name let orig_src_dir t = t.orig_src_dir -let re_exports t = t.re_exports - let best_src_dir t = Option.value ~default:t.src_dir t.orig_src_dir let set_version t version = { t with version } @@ -189,7 +194,7 @@ let set_sub_systems t sub_systems = { t with sub_systems } let set_foreign_objects t foreign_objects = { t with foreign_objects = External foreign_objects } -let set_re_exports t re_exports = { t with re_exports } +let set_requires t requires = { t with requires } let user_written_deps t = List.fold_left (t.virtual_deps @ t.ppx_runtime_deps) @@ -286,11 +291,6 @@ let of_library_stanza ~dir None in let requires = Deps.of_lib_deps conf.buildable.libraries in - let re_exports = - List.filter_map conf.buildable.libraries ~f:(function - | Re_export l -> Some l - | _ -> None) - in { loc = conf.buildable.loc ; name ; kind = conf.kind @@ -322,7 +322,6 @@ let of_library_stanza ~dir ; modes ; wrapped = Some conf.wrapped ; special_builtin_support = conf.special_builtin_support - ; re_exports } let create ~loc ~name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version @@ -330,7 +329,7 @@ let create ~loc ~name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ~plugins ~archives ~ppx_runtime_deps ~foreign_archives ~jsoo_runtime ~jsoo_archive ~pps ~enabled ~virtual_deps ~dune_version ~virtual_ ~implements ~variant ~known_implementations ~default_implementation ~modes - ~wrapped ~special_builtin_support ~re_exports = + ~wrapped ~special_builtin_support = { loc ; name ; kind @@ -362,7 +361,6 @@ let create ~loc ~name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ; modes ; wrapped ; special_builtin_support - ; re_exports } type external_ = Path.t t diff --git a/src/dune/lib_info.mli b/src/dune/lib_info.mli index 50f36e007094..aa2d5fdcbedc 100644 --- a/src/dune/lib_info.mli +++ b/src/dune/lib_info.mli @@ -30,6 +30,8 @@ module Deps : sig val of_lib_deps : Dune_file.Lib_deps.t -> t val to_dyn : t -> Dyn.t + + val field_encode : t -> name:string -> Dune_lang.Encoder.field end (** For values like modules that need to be evaluated to be fetched *) @@ -107,8 +109,6 @@ val orig_src_dir : 'path t -> 'path option val version : _ t -> string option -val re_exports : _ t -> (Loc.t * Lib_name.t) list - (** Directory where the source files for the library are located. Returns the original src dir when it exists *) val best_src_dir : 'path t -> 'path @@ -146,7 +146,7 @@ val set_sub_systems : 'a t -> Sub_system_info.t Sub_system_name.Map.t -> 'a t val set_foreign_objects : Path.t t -> Path.t list -> Path.t t -val set_re_exports : 'a t -> (Loc.t * Lib_name.t) list -> 'a t +val set_requires : 'a t -> Deps.t -> 'a t val map_path : 'a t -> f:('a -> 'a) -> 'a t @@ -182,5 +182,4 @@ val create : -> modes:Mode.Dict.Set.t -> wrapped:Wrapped.t Dune_file.Library.Inherited.t option -> special_builtin_support:Dune_file.Library.Special_builtin_support.t option - -> re_exports:(Loc.t * Lib_name.t) list -> 'a t diff --git a/src/dune_lang/encoder.mli b/src/dune_lang/encoder.mli index 865ecdd0c1bb..72f1375ee786 100644 --- a/src/dune_lang/encoder.mli +++ b/src/dune_lang/encoder.mli @@ -6,6 +6,8 @@ val sexp : T.t t val record : (string * T.t) list -> T.t +val constr : string -> 'a t -> 'a t + type field val field : diff --git a/test/blackbox-tests/test-cases/re-exported-deps/run.t b/test/blackbox-tests/test-cases/re-exported-deps/run.t index 27de0f0a4f9a..9487e32cd054 100644 --- a/test/blackbox-tests/test-cases/re-exported-deps/run.t +++ b/test/blackbox-tests/test-cases/re-exported-deps/run.t @@ -16,20 +16,20 @@ transtive deps expressed in the dune-package (archives (byte aaa/aaa.cma) (native aaa/aaa.cmxa)) (plugins (byte aaa/aaa.cma) (native aaa/aaa.cmxs)) (foreign_archives (native aaa/aaa$ext_lib)) + (requires (re_export pkg.bbb)) (main_module_name Aaa) (modes byte native) - (modules (singleton (name Aaa) (obj_name aaa) (visibility public) (impl))) - (re_exports pkg.bbb)) + (modules (singleton (name Aaa) (obj_name aaa) (visibility public) (impl)))) (library (name pkg.bbb) (kind normal) (archives (byte bbb/bbb.cma) (native bbb/bbb.cmxa)) (plugins (byte bbb/bbb.cma) (native bbb/bbb.cmxs)) (foreign_archives (native bbb/bbb$ext_lib)) + (requires (re_export pkg.ccc)) (main_module_name Bbb) (modes byte native) - (modules (singleton (name Bbb) (obj_name bbb) (visibility public) (impl))) - (re_exports pkg.ccc)) + (modules (singleton (name Bbb) (obj_name bbb) (visibility public) (impl)))) (library (name pkg.ccc) (kind normal)