Merge pull request #462 from rgrinberg/scope-ppx-bug-new-scopes

Fix scoping related ppx bug

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

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)

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

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 =
@@ -144,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
@@ -273,15 +277,22 @@ 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 <pkg>.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
+    let lib_scope = { libs = String_map.empty; scope } in
-      ~data:{ libs = String_map.empty
+    Option.iter scope.name ~f:(fun name ->
-            ; scope
+      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
+  );
+  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;
@@ -326,3 +337,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 -> die "Invalid scope '%s'" name
+  | Some scope -> { Scope.scope ; lib_db = t }

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
 
@@ -87,3 +88,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

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

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
 

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 get_ppx_driver sctx ~scope pps =
-    let names =
+    let (driver, names) =
       match List.rev_map pps ~f:Pp.to_string with
-      | [] -> []
+      | [] -> (None, [])
-      | driver :: rest ->
+      | driver :: rest -> (Some driver, rest)
-        List.sort rest ~cmp:String.compare @ [driver]
     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

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] *)

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}

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.
+      ocamldep a/ppx/a.depends.ocamldep-output
-  -> required by "required by (pps (a_kernel))"
+        ocamlc a/ppx/a.{cmi,cmo,cmt}
-  Hint: try: jbuilder external-lib-deps --missing --root . @install
+      ocamldep a/kernel/a_kernel.depends.ocamldep-output
-  [1]
+        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