From 91f6a67850ecf96eab84e85b6b4ae39ab66880af Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 30 Jan 2018 19:44:55 +0800 Subject: [PATCH 1/6] Add ability to look up scopes by external name --- src/lib_db.ml | 18 ++++++++++++++---- src/lib_db.mli | 4 ++++ 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/src/lib_db.ml b/src/lib_db.ml index 9dd24c4e..b04cc506 100644 --- a/src/lib_db.ml +++ b/src/lib_db.ml @@ -17,6 +17,7 @@ type t = instalable_internal_libs : Lib.Internal.t String_map.t ; local_public_libs : Path.t String_map.t ; anonymous_root : Path.t + ; by_scope_name : (string, scope) Hashtbl.t } let rec internal_name_scope t ~dir = @@ -273,15 +274,19 @@ let create findlib ~scopes ~root internal_libraries = ; instalable_internal_libs = String_map.empty ; local_public_libs ; anonymous_root = root + ; by_scope_name = Hashtbl.create 1024 } in (* Initializes the scopes, including [Path.root] so that when there are no .opam files in parent directories, the scope is the whole workspace. *) List.iter scopes ~f:(fun (scope : Jbuild.Scope.t) -> - Hashtbl.add t.by_internal_name ~key:scope.root - ~data:{ libs = String_map.empty - ; scope - }); + let lib_scope = { libs = String_map.empty; scope } in + Option.iter scope.name ~f:(fun name -> + assert (name <> ""); + assert (not (Hashtbl.mem t.by_scope_name name)); + Hashtbl.add t.by_scope_name ~key:name ~data:lib_scope; + ); + Hashtbl.add t.by_internal_name ~key:scope.root ~data:lib_scope); List.iter internal_libraries ~f:(fun ((dir, lib) as internal) -> let scope = internal_name_scope t ~dir in scope.libs <- String_map.add scope.libs ~key:lib.Library.name ~data:internal; @@ -326,3 +331,8 @@ let anonymous_scope t = lib_db = t ; scope = internal_name_scope t ~dir:t.anonymous_root } + +let find_scope_by_name_exn t ~name = + match Hashtbl.find t.by_scope_name name with + | None -> raise (Code_error (sprintf "Invalid scope '%s'" name)) + | Some scope -> { Scope.scope ; lib_db = t } diff --git a/src/lib_db.mli b/src/lib_db.mli index c5ac4c63..dec60eb6 100644 --- a/src/lib_db.mli +++ b/src/lib_db.mli @@ -87,3 +87,7 @@ val anonymous_scope : t -> Scope.t (** Contains only publicly, and external (findlib) libraries *) val external_scope : t -> Scope.t + +(** Find scope by the their explicit names (opam package names) [""] corresponds + to the anonymous scope *) +val find_scope_by_name_exn : t -> name:string -> Scope.t From ce65e27045e537018d0850b0fe62389851ad63bf Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 30 Jan 2018 20:12:26 +0800 Subject: [PATCH 2/6] Add Lib_db.Scope.name --- src/lib_db.ml | 3 +++ src/lib_db.mli | 1 + 2 files changed, 4 insertions(+) diff --git a/src/lib_db.ml b/src/lib_db.ml index b04cc506..3b5b1b72 100644 --- a/src/lib_db.ml +++ b/src/lib_db.ml @@ -145,6 +145,9 @@ module Scope = struct Some { dst_fn = result_fn; src_fn }) let root t = t.scope.scope.root + let name t = + Option.value ~default:"" t.scope.scope.name + let resolve t = (* TODO do something with required_by here *) Jbuild.Scope.resolve t.data.scope.scope diff --git a/src/lib_db.mli b/src/lib_db.mli index dec60eb6..99a200f5 100644 --- a/src/lib_db.mli +++ b/src/lib_db.mli @@ -34,6 +34,7 @@ module Scope : sig val lib_is_available : t with_required_by -> string -> bool val root : t -> Path.t + val name : t -> string val resolve : t with_required_by -> string -> (Package.t, string) result From 1013db83b5142e397862e7fa803c71659a60de1d Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 30 Jan 2018 20:12:38 +0800 Subject: [PATCH 3/6] Add Lib.public_name --- src/lib.ml | 4 ++++ src/lib.mli | 2 ++ 2 files changed, 6 insertions(+) diff --git a/src/lib.ml b/src/lib.ml index 6c768eed..51ea3e30 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -101,3 +101,7 @@ let remove_dups_preserve_order libs = in loop String_set.empty libs [] ;; + +let public_name = function + | External pkg -> Some pkg.name + | Internal (_, lib) -> Option.map lib.public ~f:(fun p -> p.name) diff --git a/src/lib.mli b/src/lib.mli index 2b43d611..8f1dc0cb 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -33,3 +33,5 @@ val remove_dups_preserve_order : t list -> t list (*val ppx_runtime_libraries : t list -> String_set.t *) + +val public_name : t -> string option From dcb3845fc492e12f388f5bbb29d6faa7c496c6f5 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 30 Jan 2018 20:17:47 +0800 Subject: [PATCH 4/6] Associate the empty scope name to the anonymous scope --- src/lib_db.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/lib_db.ml b/src/lib_db.ml index 3b5b1b72..c8dc7352 100644 --- a/src/lib_db.ml +++ b/src/lib_db.ml @@ -289,7 +289,10 @@ let create findlib ~scopes ~root internal_libraries = assert (not (Hashtbl.mem t.by_scope_name name)); Hashtbl.add t.by_scope_name ~key:name ~data:lib_scope; ); - Hashtbl.add t.by_internal_name ~key:scope.root ~data:lib_scope); + Hashtbl.add t.by_internal_name ~key:scope.root ~data:lib_scope + ); + let anon_scope = internal_name_scope t ~dir:t.anonymous_root in + Hashtbl.add t.by_scope_name ~key:"" ~data:anon_scope; List.iter internal_libraries ~f:(fun ((dir, lib) as internal) -> let scope = internal_name_scope t ~dir in scope.libs <- String_map.add scope.libs ~key:lib.Library.name ~data:internal; From a29f144bc1050a7d8bff3a6e13889e189515c3ea Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 30 Jan 2018 20:18:22 +0800 Subject: [PATCH 5/6] Use correct scopes for generating ppx preprocessors Use the intenral scope whenever there's an internal lib in the preprocessors. Otherwise use the external scope. --- src/gen_rules.ml | 5 ++-- src/lib_db.ml | 2 +- src/merlin.ml | 14 +++++------ src/merlin.mli | 7 +++++- src/super_context.ml | 54 +++++++++++++++++++++++++++++++++++-------- src/super_context.mli | 6 ++++- 6 files changed, 67 insertions(+), 21 deletions(-) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 8fd8b8ab..2a7b5500 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -862,7 +862,7 @@ Add it to your jbuild file to remove this warning. { m with source_dirs = Path.Set.add (Path.relative src_dir ".") m.source_dirs }) - |> Option.iter ~f:(Merlin.add_rules sctx ~dir:ctx_dir); + |> Option.iter ~f:(Merlin.add_rules sctx ~dir:ctx_dir ~scope); Option.iter (Utop.exe_stanzas stanzas) ~f:(fun (exe, all_modules) -> let dir = Utop.utop_exe_dir ~dir:ctx_dir in let merlin = executables_rules exe ~dir ~all_modules ~scope in @@ -1003,7 +1003,8 @@ Add it to your jbuild file to remove this warning. else pps in - let ppx_exe = SC.PP.get_ppx_driver sctx pps in + let scope = Lib_db.find_scope' (SC.libs sctx) ~dir in + let ppx_exe = SC.PP.get_ppx_driver sctx ~scope pps in [ppx_exe] in List.concat diff --git a/src/lib_db.ml b/src/lib_db.ml index c8dc7352..6c2c925f 100644 --- a/src/lib_db.ml +++ b/src/lib_db.ml @@ -340,5 +340,5 @@ let anonymous_scope t = let find_scope_by_name_exn t ~name = match Hashtbl.find t.by_scope_name name with - | None -> raise (Code_error (sprintf "Invalid scope '%s'" name)) + | None -> die "Invalid scope '%s'" name | Some scope -> { Scope.scope ; lib_db = t } diff --git a/src/merlin.ml b/src/merlin.ml index 8a1a1e64..b95ea275 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -12,12 +12,12 @@ type t = ; source_dirs: Path.Set.t } -let ppx_flags sctx ~dir:_ ~src_dir:_ { preprocess; libname; _ } = +let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } = match preprocess with | Pps { pps; flags } -> - let exe = SC.PP.get_ppx_driver sctx pps in + let exe = SC.PP.get_ppx_driver sctx ~scope pps in let command = - List.map (Path.to_absolute_filename exe + List.map (Path.to_absolute_filename exe :: "--as-ppx" :: SC.PP.cookie_library_name libname @ flags) @@ -27,7 +27,7 @@ let ppx_flags sctx ~dir:_ ~src_dir:_ { preprocess; libname; _ } = [sprintf "FLG -ppx %s" (Filename.quote command)] | _ -> [] -let dot_merlin sctx ~dir ({ requires; flags; _ } as t) = +let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) = match Path.drop_build_context dir with | Some remaindir -> let merlin_file = Path.relative dir ".merlin" in @@ -46,7 +46,7 @@ let dot_merlin sctx ~dir ({ requires; flags; _ } as t) = SC.add_rule sctx ~mode:Promote_but_delete_on_clean ( requires &&& flags >>^ (fun (libs, flags) -> - let ppx_flags = ppx_flags sctx ~dir ~src_dir:remaindir t in + let ppx_flags = ppx_flags sctx ~dir ~scope ~src_dir:remaindir t in let internals, externals = List.fold_left libs ~init:([], []) ~f:(fun (internals, externals) -> function @@ -117,6 +117,6 @@ let merge_all = function | [] -> None | init::ts -> Some (List.fold_left ~init ~f:merge_two ts) -let add_rules sctx ~dir merlin = +let add_rules sctx ~dir ~scope merlin = if (SC.context sctx).merlin then - dot_merlin sctx ~dir merlin + dot_merlin sctx ~dir ~scope merlin diff --git a/src/merlin.mli b/src/merlin.mli index e3d12961..26c99661 100644 --- a/src/merlin.mli +++ b/src/merlin.mli @@ -11,5 +11,10 @@ type t = val merge_all : t list -> t option (** Add rules for generating the .merlin in a directory *) -val add_rules : Super_context.t -> dir:Path.t -> t -> unit +val add_rules + : Super_context.t + -> dir:Path.t + -> scope:Lib_db.Scope.t Lib_db.with_required_by + -> t + -> unit diff --git a/src/super_context.ml b/src/super_context.ml index bc69442b..ff0f1d73 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -853,6 +853,12 @@ module PP = struct | [key] -> let ppx_dir = Path.relative sctx.ppx_dir key in let exe = Path.relative ppx_dir "ppx.exe" in + let (key, scope) = + match String.rsplit2 key ~on:'@' with + | None -> + (key, Libs.external_scope sctx) + | Some (key, scope) -> + (key, Lib_db.find_scope_by_name_exn sctx.libs ~name:scope) in let names = match key with | "+none+" -> [] @@ -866,27 +872,57 @@ module PP = struct in let scope = { Lib_db. - data = Lib_db.anonymous_scope sctx.libs + data = scope ; required_by = [sprintf "required by (pps (%s))" (String.concat names ~sep:", ")] } in build_ppx_driver sctx names ~scope ~dep_kind:Required ~target:exe ~driver | _ -> () - let get_ppx_driver sctx pps = - let names = + let get_ppx_driver sctx ~scope pps = + let (driver, names) = match List.rev_map pps ~f:Pp.to_string with - | [] -> [] - | driver :: rest -> - List.sort rest ~cmp:String.compare @ [driver] + | [] -> (None, []) + | driver :: rest -> (Some driver, rest) in + let sctx = host_sctx sctx in + let public_name name = + match Lib_db.Scope.find scope name with + | None -> Some name (* XXX unknown but assume it's public *) + | Some lib -> Lib.public_name lib in + let (driver_private, driver) = + match driver with + | None -> (false, None) + | Some driver -> + begin match public_name driver with + | None -> (true, Some driver) + | Some driver -> (false, Some driver) + end in + let (libs, has_private_libs) = + List.fold_left ~f:(fun (libs, has_private_libs) lib -> + match public_name lib with + | None -> (lib :: libs, true) + | Some pub_name -> (pub_name :: libs, has_private_libs) + ) ~init:([], driver_private) names in + let libs = List.sort ~cmp:String.compare libs in + let names = + match driver with + | None -> libs + | Some driver -> libs @ [driver] in let key = match names with | [] -> "+none+" | _ -> String.concat names ~sep:"+" in let sctx = host_sctx sctx in - let ppx_dir = Path.relative sctx.ppx_dir key in + let ppx_dir = + Path.relative sctx.ppx_dir ( + if has_private_libs then ( + sprintf "%s@%s" key (Lib_db.Scope.name scope.data) + ) else ( + key + ) + ) in Path.relative ppx_dir "ppx.exe" let target_var = String_with_vars.virt_var __POS__ "@" @@ -971,7 +1007,7 @@ module PP = struct ~scope) ) | Pps { pps; flags } -> - let ppx_exe = get_ppx_driver sctx pps in + let ppx_exe = get_ppx_driver sctx ~scope pps in Module.iter ast ~f:(fun kind src -> let src_path = Path.relative dir src.name in let args = @@ -1035,7 +1071,7 @@ module PP = struct lint_module ~ast ~source:m; ast | Pps { pps; flags } -> - let ppx_exe = get_ppx_driver sctx pps in + let ppx_exe = get_ppx_driver sctx ~scope pps in let ast = setup_reason_rules sctx ~dir m in lint_module ~ast ~source:m; let uses_ppx_driver = uses_ppx_driver ~pps in diff --git a/src/super_context.mli b/src/super_context.mli index e1064ada..788c620d 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -216,7 +216,11 @@ module PP : sig -> Module.t String_map.t (** Get a path to a cached ppx driver *) - val get_ppx_driver : t -> Pp.t list -> Path.t + val get_ppx_driver + : t + -> scope:Lib_db.Scope.t Lib_db.with_required_by + -> Pp.t list + -> Path.t (** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not [None] *) From 721c80273a5a8359aa35b8a785b54cbb772f6c46 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 30 Jan 2018 20:19:02 +0800 Subject: [PATCH 6/6] Update ppx scope tests --- .../test-cases/ppx-rewriter/run.t | 2 +- .../test-cases/scope-ppx-bug/run.t | 25 ++++++++++++++++--- 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/test/blackbox-tests/test-cases/ppx-rewriter/run.t b/test/blackbox-tests/test-cases/ppx-rewriter/run.t index 6aedd1a7..fdc70578 100644 --- a/test/blackbox-tests/test-cases/ppx-rewriter/run.t +++ b/test/blackbox-tests/test-cases/ppx-rewriter/run.t @@ -3,7 +3,7 @@ ocamlc ppx/fooppx.{cmi,cmo,cmt} ocamlopt ppx/fooppx.{cmx,o} ocamlopt ppx/fooppx.{a,cmxa} - ocamlopt .ppx/fooppx/ppx.exe + ocamlopt .ppx/fooppx@/ppx.exe ppx w_omp_driver.pp.ml ocamldep w_omp_driver.depends.ocamldep-output ocamlc w_omp_driver.{cmi,cmo,cmt} diff --git a/test/blackbox-tests/test-cases/scope-ppx-bug/run.t b/test/blackbox-tests/test-cases/scope-ppx-bug/run.t index 24e1daf9..2c5f09c5 100644 --- a/test/blackbox-tests/test-cases/scope-ppx-bug/run.t +++ b/test/blackbox-tests/test-cases/scope-ppx-bug/run.t @@ -1,5 +1,22 @@ $ $JBUILDER build -j1 --root . @install - Error: External library "a_kernel" not found. - -> required by "required by (pps (a_kernel))" - Hint: try: jbuilder external-lib-deps --missing --root . @install - [1] + ocamldep a/ppx/a.depends.ocamldep-output + ocamlc a/ppx/a.{cmi,cmo,cmt} + ocamldep a/kernel/a_kernel.depends.ocamldep-output + ocamlc a/kernel/a_kernel.{cmi,cmo,cmt} + ocamlopt a/ppx/a.{cmx,o} + ocamlc a/ppx/a.cma + ocamlopt a/kernel/a_kernel.{cmx,o} + ocamlc a/kernel/a_kernel.cma + ocamlopt a/ppx/a.{a,cmxa} + ocamlopt a/kernel/a_kernel.{a,cmxa} + ocamlopt a/ppx/a.cmxs + ocamlopt a/kernel/a_kernel.cmxs + ocamlopt .ppx/a.kernel/ppx.exe + ocamlopt .ppx/a/ppx.exe + ppx b/b.pp.ml + ocamldep b/b.depends.ocamldep-output + ocamlc b/b.{cmi,cmo,cmt} + ocamlopt b/b.{cmx,o} + ocamlc b/b.cma + ocamlopt b/b.{a,cmxa} + ocamlopt b/b.cmxs