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.
This commit is contained in:
parent
dcb3845fc4
commit
a29f144bc1
|
@ -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
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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] *)
|
||||
|
|
Loading…
Reference in New Issue