From b35fbbd7b28d34df1bdbe30218785346f8c43d1a Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 28 Feb 2018 16:32:55 +0000 Subject: [PATCH] Abstract the ppx driver system - remove hard-coded knowledge of ocaml-migrate-parsetree and ppx_driver - get the exact driver parameters directly from the driver itself Signed-off-by: Jeremie Dimino --- CHANGES.md | 4 +- doc/advanced-topics.rst | 38 -- doc/jbuild.rst | 5 - dune.opam | 6 +- src/inline_tests.ml | 2 +- src/install_rules.ml | 26 +- src/jbuild.ml | 23 +- src/jbuild.mli | 3 +- src/lib.ml | 14 +- src/lib.mli | 2 +- src/merlin.ml | 19 +- src/merlin.mli | 2 +- src/preprocessing.ml | 398 +++++++++++------- src/preprocessing.mli | 7 +- src/sub_system.ml | 19 +- src/sub_system_intf.ml | 3 +- .../test-cases/ppx-rewriter/run.t | 2 +- .../test-cases/scope-ppx-bug/a/kernel/dune | 1 + 18 files changed, 319 insertions(+), 255 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 7f7d85c0..808e8793 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -56,6 +56,9 @@ next - In dune files, add support for block strings, allowing to nicely format blocks of texts (#837, @diml) +- Remove hard-coded knowledge of ppx_driver and + ocaml-migrate-parsetree (#576, @diml) + 1.0+beta20 (10/04/2018) ----------------------- @@ -176,7 +179,6 @@ next - Add a hack to be able to build ppxlib, until beta20 which will have generic support for ppx drivers - 1.0+beta18 (25/02/2018) ----------------------- diff --git a/doc/advanced-topics.rst b/doc/advanced-topics.rst index 6d045c20..d29d975f 100644 --- a/doc/advanced-topics.rst +++ b/doc/advanced-topics.rst @@ -30,44 +30,6 @@ Jbuilder you can write the folliwing ``META.foo.template`` file: # JBUILDER_GEN blah = "..." -.. _custom-driver: - -Using a custom ppx driver -========================= - -You can use a custom ppx driver by putting it as the last library in ``(pps -...)`` forms. An example of alternative driver is `ppx_driver -`__. To use it instead of -``ocaml-migrate-parsetree.driver-main``, simply write ``ppx_driver.runner`` as -the last library: - -.. code:: scheme - - (preprocess (pps (ppx_sexp_conv ppx_bin_prot ppx_driver.runner))) - -Driver expectation ------------------- - -Jbuilder will invoke the executable resulting from linking the libraries -given in the ``(pps ...)`` form as follows: - -.. code:: bash - - ppx.exe --dump-ast -o \ - [--cookie library-name=""] [--impl|--intf] - -Where ```` is either an implementation (``.ml``) or -interface (``.mli``) OCaml source file. The command is expected to write -a binary OCaml AST in ````. - -Additionally, it is expected that if the executable is invoked with -``--as-ppx`` as its first argument, then it will behave as a standard -ppx rewriter as passed to ``-ppx`` option of OCaml. This is for two -reasons: - -- to improve interoperability with build systems other than Jbuilder -- so that it can be used with merlin - Findlib integration and limitations =================================== diff --git a/doc/jbuild.rst b/doc/jbuild.rst index 0319a580..ea0a3618 100644 --- a/doc/jbuild.rst +++ b/doc/jbuild.rst @@ -1045,11 +1045,6 @@ dependencies. Note that it is important that all these libraries are linked with ``-linkall``. Jbuilder automatically uses ``-linkall`` when the ``(kind ...)`` field is set to ``ppx_rewriter`` or ``ppx_deriver``. -It is guaranteed that the last library in the list will be linked last. You can -use this feature to use a custom ppx driver. By default Jbuilder will use -``ocaml-migrate-parsetree.driver-main``. See the section about -:ref:`custom-driver` for more details. - Per module preprocessing specification ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/dune.opam b/dune.opam index 8f7d0071..fcedfdf7 100644 --- a/dune.opam +++ b/dune.opam @@ -12,4 +12,8 @@ build: [ ["./boot.exe" "-j" jobs] ] available: [ ocaml-version >= "4.02.3" ] -conflicts: [ "jbuilder" {!= "transition"} ] +conflicts: [ + "jbuilder" {!= "transition"} + "ppx_driver" {< "v0.10.3"} + "ocaml-migrate-parsetree" {< "1.0.8"} +] diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 55ae48e4..df47cb84 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -77,7 +77,7 @@ module Backend = struct (List.map info.extends ~f:(fun ((loc, name) as x) -> resolve x >>= fun lib -> - match get lib with + match get ~loc lib with | None -> Error (Loc.exnf loc "%S is not an %s" name (desc ~plural:false)) diff --git a/src/install_rules.ml b/src/install_rules.ml index d6887cf4..167d3dea 100644 --- a/src/install_rules.ml +++ b/src/install_rules.ml @@ -130,7 +130,7 @@ module Gen(P : Install_params) = struct >>> Build.write_file_dyn meta))) - let lib_install_files ~dir ~sub_dir ~scope ~name (lib : Library.t) = + let lib_install_files ~dir ~sub_dir ~name (lib : Library.t) = let obj_dir = Utils.library_object_directory ~dir lib.name in let make_entry section ?dst fn = Install.Entry.make section fn @@ -184,25 +184,7 @@ module Gen(P : Install_params) = struct match lib.kind with | Normal | Ppx_deriver -> [] | Ppx_rewriter -> - let pps = [(lib.buildable.loc, Pp.of_string lib.name)] in - let pps = - (* This is a temporary hack until we get a standard driver *) - let deps = - List.concat_map lib.buildable.libraries ~f:Lib_dep.to_lib_names - in - if List.exists deps ~f:(function - | "ppx_driver" | "ppx_type_conv" -> true - | _ -> false) then - pps @ [match Scope.name scope with - | Named "ppxlib" -> - Loc.none, Pp.of_string "ppxlib.runner" - | _ -> - Loc.none, Pp.of_string "ppx_driver.runner"] - else - pps - in - let ppx_exe = Preprocessing.get_ppx_driver sctx ~scope pps in - [ppx_exe] + [Preprocessing.get_ppx_driver_for_public_lib sctx ~name] in List.concat [ List.map files ~f:(make_entry Lib ) @@ -292,10 +274,10 @@ module Gen(P : Install_params) = struct let init_install () = let entries_per_package = List.concat_map (SC.stanzas_to_consider_for_install sctx) - ~f:(fun (dir, scope, stanza) -> + ~f:(fun (dir, _scope, stanza) -> match stanza with | Library ({ public = Some { package; sub_dir; name; _ }; _ } as lib) -> - List.map (lib_install_files ~dir ~sub_dir ~scope ~name lib) + List.map (lib_install_files ~dir ~sub_dir ~name lib) ~f:(fun x -> package.name, x) | Install { section; files; package}-> List.map files ~f:(fun { Install_conf. src; dst } -> diff --git a/src/jbuild.ml b/src/jbuild.ml index 3526e321..09947c98 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -249,7 +249,7 @@ module Dep_conf = struct end module Preprocess = struct - type pps = { pps : (Loc.t * Pp.t) list; flags : string list } + type pps = { loc : Loc.t; pps : (Loc.t * Pp.t) list; flags : string list } type t = | No_preprocessing | Action of Loc.t * Action.Unexpanded.t @@ -258,11 +258,24 @@ module Preprocess = struct let t = sum [ cstr "no_preprocessing" nil No_preprocessing - ; cstr "action" (located Action.Unexpanded.t @> nil) - (fun (loc, x) -> Action (loc, x)) - ; cstr "pps" (list Pp_or_flags.t @> nil) (fun l -> + ; cstr "action" (located Action.Unexpanded.t @> nil) (fun (loc, x) -> + Action (loc, x)) + ; cstr "pps" (cstr_loc (list Pp_or_flags.t @> nil)) (fun loc l -> let pps, flags = Pp_or_flags.split l in - Pps { pps; flags }) + let pps = + (* Compatibility hacks. We can remove them when switching + to Dune and make these cases errors. *) + match pps with + | [] -> + [(loc, Pp.of_string "ocaml-migrate-parsetree")] + | _ -> + List.map pps ~f:(fun ((loc, pp) as x) -> + match Pp.to_string pp with + | "ppx_driver.runner" -> (loc, Pp.of_string "ppx_driver") + | "ppxlib.runner" -> (loc, Pp.of_string "ppxlib") + | _ -> x) + in + Pps { loc; pps; flags }) ] let pps = function diff --git a/src/jbuild.mli b/src/jbuild.mli index cc633719..19b9e2cf 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -19,7 +19,8 @@ end module Preprocess : sig type pps = - { pps : (Loc.t * Pp.t) list + { loc : Loc.t + ; pps : (Loc.t * Pp.t) list ; flags : string list } diff --git a/src/lib.ml b/src/lib.ml index a29b25d8..29065eb1 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -456,8 +456,8 @@ module Sub_system = struct type t type sub_system += T of t val instantiate - : resolve:(Loc.t * string -> (lib, exn) result) - -> get:(lib -> t option) + : resolve:(Loc.t * string -> lib Or_exn.t) + -> get:(loc:Loc.t -> lib -> t option) -> lib -> Info.t -> t @@ -495,8 +495,14 @@ module Sub_system = struct let (module M : S') = impl in match info with | M.Info.T info -> + let get ~loc lib' = + if lib.unique_id = lib'.unique_id then + Loc.fail loc "Library %S depends on itself" lib.name + else + M.get lib' + in Sub_system0.Instance.T - (M.for_instance, M.instantiate ~resolve ~get:M.get lib info) + (M.for_instance, M.instantiate ~resolve ~get lib info) | _ -> assert false let dump_config lib = @@ -697,7 +703,7 @@ and find_internal db name ~stack : status = | Some x -> x | None -> resolve_name db name ~stack -and resolve_dep db name ~allow_private_deps ~loc ~stack : (t, exn) result = +and resolve_dep db name ~allow_private_deps ~loc ~stack : t Or_exn.t = match find_internal db name ~stack with | St_initializing id -> Error (Dep_stack.dependency_cycle stack id) diff --git a/src/lib.mli b/src/lib.mli index 682a1be4..d70ef8c9 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -318,7 +318,7 @@ module Sub_system : sig type sub_system += T of t val instantiate : resolve:(Loc.t * string -> lib Or_exn.t) - -> get:(lib -> t option) + -> get:(loc:Loc.t -> lib -> t option) -> lib -> Info.t -> t diff --git a/src/merlin.ml b/src/merlin.ml index e779e2b8..01f27ee2 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -18,8 +18,8 @@ module Preprocess = struct | Other, Other -> Other | Pps _, Other -> a | Other, Pps _ -> b - | Pps { pps = pps1; flags = flags1 }, - Pps { pps = pps2; flags = flags2 } -> + | Pps { loc = _; pps = pps1; flags = flags1 }, + Pps { loc = _; pps = pps2; flags = flags2 } -> match match List.compare flags1 flags2 ~compare:String.compare with | Eq -> @@ -98,12 +98,15 @@ let add_source_dir t dir = let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } = match preprocess with - | Pps { pps; flags } -> - let exe = Preprocessing.get_ppx_driver sctx ~scope pps in - (Path.to_absolute_filename exe - :: "--as-ppx" - :: Preprocessing.cookie_library_name libname - @ flags) + | Pps { loc = _; pps; flags } -> begin + match Preprocessing.get_ppx_driver sctx ~scope pps with + | Ok exe -> + (Path.to_absolute_filename exe + :: "--as-ppx" + :: Preprocessing.cookie_library_name libname + @ flags) + | Error _ -> [] + end | Other -> [] let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) = diff --git a/src/merlin.mli b/src/merlin.mli index 1963cd93..943bb210 100644 --- a/src/merlin.mli +++ b/src/merlin.mli @@ -5,7 +5,7 @@ open Import type t val make - : ?requires:(Lib.t list, exn) result + : ?requires:Lib.t list Or_exn.t -> ?flags:(unit, string list) Build.t -> ?preprocess:Jbuild.Preprocess.t -> ?libname:string diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 08c53350..ec4236e8 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -16,91 +16,158 @@ let pped_module ~dir m ~f = f kind (Path.relative dir file.name) (Path.relative dir pp_fname); { file with name = pp_fname }) -let migrate_driver_main = "ocaml-migrate-parsetree.driver-main" +module Driver = struct + module M = struct + module Info = struct + let name = Sub_system_name.make "ppx.driver" + type t = + { loc : Loc.t + ; flags : Ordered_set_lang.Unexpanded.t + ; lint_flags : Ordered_set_lang.Unexpanded.t + ; main : string + ; replaces : (Loc.t * string) list + } + + type Jbuild.Sub_system_info.t += T of t + + let loc t = t.loc + + open Sexp.Of_sexp + + let short = None + let parse = + record + (record_loc >>= fun loc -> + Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> + Ordered_set_lang.Unexpanded.field "lint_flags" >>= fun lint_flags -> + field "main" string >>= fun main -> + field "replaces" (list (located string)) ~default:[] + >>= fun replaces -> + return + { loc + ; flags + ; lint_flags + ; main + ; replaces + }) + + let parsers = + Syntax.Versioned_parser.make + [ (1, 0), + { Jbuild.Sub_system_info. + short + ; parse + } + ] + end + + type t = + { info : Info.t + ; lib : Lib.t + ; replaces : t list Or_exn.t + } + + let desc ~plural = "ppx driver" ^ if plural then "s" else "" + let desc_article = "a" + + let lib t = t.lib + let replaces t = t.replaces + + let instantiate ~resolve ~get lib (info : Info.t) = + { info + ; lib + ; replaces = + let open Result.O in + Result.all + (List.map info.replaces + ~f:(fun ((loc, name) as x) -> + resolve x >>= fun lib -> + match get ~loc lib with + | None -> + Error (Loc.exnf loc "%S is not a %s" name + (desc ~plural:false)) + | Some t -> Ok t)) + } + + let to_sexp t = + let open Sexp.To_sexp in + let f x = string (Lib.name x.lib) in + ((1, 0), + record + [ "flags" , Ordered_set_lang.Unexpanded.sexp_of_t + t.info.flags + ; "lint_flags" , Ordered_set_lang.Unexpanded.sexp_of_t + t.info.lint_flags + ; "main" , string t.info.main + ; "replaces" , list f (Result.ok_exn t.replaces) + ]) + end + include M + include Sub_system.Register_backend(M) +end let ppx_exe sctx ~key = Path.relative (SC.build_dir sctx) (".ppx/" ^ key ^ "/ppx.exe") +let no_driver_error pps = + let has name = + List.exists pps ~f:(fun lib -> Lib.name lib = name) + in + match + List.find ["ocaml-migrate-parsetree"; "ppxlib"; "ppx_driver"] ~f:has + with + | Some name -> + sprintf + "No ppx driver found.\n\ + Hint: Try upgrading or reinstalling %S." name + | None -> + sprintf + "No ppx driver found.\n\ + It seems that these ppx rewriters are not compatible with jbuilder." + let build_ppx_driver sctx ~lib_db ~dep_kind ~target pps = let ctx = SC.context sctx in let mode = Context.best_mode ctx in let compiler = Option.value_exn (Context.compiler ctx mode) in - let pps = pps @ [Pp.of_string migrate_driver_main] in - let driver, libs = - let resolved_pps = - Lib.DB.resolve_pps lib_db - (List.map pps ~f:(fun x -> (Loc.none, x))) + let driver_and_libs = + let open Result.O in + Result.map_error ~f:(fun e -> (* Extend the dependency stack as we don't have locations at this point *) - |> Result.map_error ~f:(fun e -> - Dep_path.prepend_exn e - (Preprocess (pps : Jbuild.Pp.t list :> string list))) - in - let driver = - match resolved_pps with - | Ok l -> List.last l - | Error _ -> None - in - (driver, - Result.bind resolved_pps ~f:Lib.closure - |> Result.map ~f:Build.return - |> Build.of_result) - in - let libs = - Build.record_lib_deps ~kind:dep_kind - (List.map pps ~f:(fun pp -> Lib_dep.of_pp (Loc.none, pp))) - >>> - libs - in - let libs = - (* Put the driver back at the end, just before migrate_driver_main *) - match driver with - | None -> libs - | Some driver -> - libs >>^ fun libs -> - let libs, drivers = - List.partition_map libs ~f:(fun lib -> - if lib == driver || Lib.name lib = migrate_driver_main then - Right lib - else - Left lib) - in - let user_driver, migrate_driver = - List.partition_map drivers ~f:(fun lib -> - if Lib.name lib = migrate_driver_main then - Right lib - else - Left lib) - in - libs @ user_driver @ migrate_driver - in - (* Provide a better error for migrate_driver_main given that this - is an implicit dependency *) - let libs = - match Lib.DB.available lib_db migrate_driver_main with - | false -> - Build.fail { fail = fun () -> - die "@{Error@}: I couldn't find '%s'.\n\ - I need this library in order to use ppx rewriters.\n\ - See the manual for details.\n\ - Hint: opam install ocaml-migrate-parsetree" - migrate_driver_main - } - >>> - libs - | true -> - libs + Dep_path.prepend_exn e + (Preprocess (pps : Jbuild.Pp.t list :> string list))) + (Lib.DB.resolve_pps lib_db + (List.map pps ~f:(fun x -> (Loc.none, x))) + >>= Lib.closure + >>= fun resolved_pps -> + Driver.select_replaceable_backend resolved_pps ~loc:Loc.none + ~replaces:Driver.replaces + ~no_backend_error:no_driver_error + >>| fun driver -> + (driver, resolved_pps)) in + (* CR-someday diml: what we should do is build the .cmx/.cmo once + and for all at the point where the driver is defined. *) + let ml = Path.relative (Option.value_exn (Path.parent target)) "ppx.ml" in SC.add_rule sctx - (libs + (Build.of_result_map driver_and_libs ~f:(fun (driver, _) -> + Build.return (sprintf "let () = %s ()\n" driver.info.main)) >>> - Build.dyn_paths - (Build.arr - (Lib.L.archive_files ~mode ~ext_lib:ctx.ext_lib)) + Build.write_file_dyn ml); + SC.add_rule sctx + (Build.record_lib_deps ~kind:dep_kind (Lib_deps.of_pps pps) + >>> + Build.of_result_map driver_and_libs ~f:(fun (_, libs) -> + Build.paths (Lib.L.archive_files libs ~mode ~ext_lib:ctx.ext_lib)) >>> Build.run ~context:ctx (Ok compiler) [ A "-o" ; Target target - ; Dyn (Lib.L.link_flags ~mode ~stdlib_dir:ctx.stdlib_dir) + ; Arg_spec.of_result + (Result.map driver_and_libs ~f:(fun (_driver, libs) -> + Lib.L.compile_and_link_flags ~mode ~stdlib_dir:ctx.stdlib_dir + ~compile:libs + ~link:libs)) + ; Dep ml ]) let gen_rules sctx components = @@ -122,47 +189,23 @@ let gen_rules sctx components = build_ppx_driver sctx pps ~lib_db ~dep_kind:Required ~target:exe | _ -> () -let get_ppx_driver sctx ~scope pps = - let driver, names = - match List.rev_map pps ~f:(fun (_loc, pp) -> Pp.to_string pp) with - | [] -> (None, []) - | driver :: rest -> (Some driver, rest) - in - let sctx = SC.host sctx in - let name_and_scope_for_key name = - match Lib.DB.find (Scope.libs scope) name with - | Error _ -> - (* XXX unknown but assume it's public *) - (name, None) - | Ok lib -> - (Lib.name lib, - match Lib.status lib with - | Private scope_name -> Some scope_name - | Public _ | Installed -> None) - in - let driver, scope_for_key = - match driver with - | None -> (None, None) - | Some driver -> - let name, scope_for_key = name_and_scope_for_key driver in - (Some name, scope_for_key) - in - let names, scope_for_key = - List.fold_left names ~init:([], scope_for_key) - ~f:(fun (names, scope_for_key) lib -> - let name, scope_for_key' = name_and_scope_for_key lib in - (name :: names, - match scope_for_key, scope_for_key' with - | Some a, Some b -> assert (a = b); scope_for_key - | Some _, None -> scope_for_key - | None , Some _ -> scope_for_key' - | None , None -> None)) - in - let names = List.sort ~compare:String.compare names in +let ppx_driver_exe sctx libs = let names = - match driver with - | None -> names - | Some driver -> names @ [driver] + List.rev_map libs ~f:Lib.name + |> List.sort ~compare:String.compare + in + let scope_for_key = + List.fold_left libs ~init:None ~f:(fun acc lib -> + let scope_for_key = + match Lib.status lib with + | Private scope_name -> Some scope_name + | Public _ | Installed -> None + in + match acc, scope_for_key with + | Some a, Some b -> assert (a = b); acc + | Some _, None -> acc + | None , Some _ -> scope_for_key + | None , None -> None) in let key = match names with @@ -174,9 +217,23 @@ let get_ppx_driver sctx ~scope pps = | None -> key | Some scope_name -> SC.Scope_key.to_string key scope_name in - let sctx = SC.host sctx in ppx_exe sctx ~key +let get_ppx_driver_for_public_lib sctx ~name = + ppx_exe sctx ~key:name + +let get_ppx_driver sctx ~loc ~scope pps = + let sctx = SC.host sctx in + let open Result.O in + Lib.DB.resolve_pps (Scope.libs scope) pps + >>= fun libs -> + Lib.closure libs + >>= + Driver.select_replaceable_backend ~loc ~replaces:Driver.replaces + ~no_backend_error:no_driver_error + >>= fun driver -> + Ok (ppx_driver_exe sctx libs, driver) + let target_var = String_with_vars.virt_var __POS__ "@" let root_var = String_with_vars.virt_var __POS__ "ROOT" @@ -206,22 +263,14 @@ let setup_reason_rules sctx ~dir (m : Module.t) = SC.add_rule sctx (rule f.name ml.name); ml) -let uses_ppx_driver ~pps = - match (List.last pps : (_ * Pp.t) option :> (_ * string) option) with - | Some (_, ("ppx_driver.runner" | "ppxlib.runner")) -> true - | Some _ | None -> false - -let promote_correction ~uses_ppx_driver fn build = - if not uses_ppx_driver then - build - else - Build.progn - [ build - ; Build.return - (Action.diff ~optional:true - fn - (Path.extend_basename fn ~suffix:".ppx-corrected")) - ] +let promote_correction fn build ~suffix = + Build.progn + [ build + ; Build.return + (Action.diff ~optional:true + fn + (Path.extend_basename fn ~suffix)) + ] let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope = Staged.stage ( let alias = Build_system.Alias.lint ~dir in @@ -251,34 +300,42 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope = Staged.stage ( ~dep_kind ~targets:(Static []) ~scope))) - | Pps { pps; flags } -> - let ppx_exe = get_ppx_driver sctx ~scope pps in - let uses_ppx_driver = uses_ppx_driver ~pps in + | Pps { loc; pps; flags } -> let args : _ Arg_spec.t = S [ As flags ; As (cookie_library_name lib_name) - (* This hack is needed until -null is standard: - https://github.com/ocaml-ppx/ocaml-migrate-parsetree/issues/35 - *) - ; As (if uses_ppx_driver then - [ "-null"; "-diff-cmd"; "-" ] - else - []) ] in + let corrected_suffix = ".lint-corrected" in + let driver_and_flags = + let open Result.O in + get_ppx_driver sctx ~loc ~scope pps >>| fun (exe, driver) -> + (exe, + let extra_vars = + String_map.singleton "corrected-suffix" + (Action.Var_expansion.Strings ([corrected_suffix], Split)) + in + Build.memoize "ppx flags" + (SC.expand_and_eval_set sctx driver.info.lint_flags + ~scope + ~dir + ~extra_vars + ~standard:(Build.return []))) + in (fun ~source ~ast -> Module.iter ast ~f:(fun kind src -> - let args = - [ args - ; Ml_kind.ppx_driver_flag kind - ; Dep (Path.relative dir src.name) - ] - in add_alias src.name - (promote_correction ~uses_ppx_driver + (promote_correction ~suffix:corrected_suffix (Option.value_exn (Module.file ~dir source kind)) - (Build.run ~context:(SC.context sctx) (Ok ppx_exe) args)) - ))) + (Build.of_result_map driver_and_flags ~f:(fun (exe, flags) -> + flags >>> + Build.run ~context:(SC.context sctx) + (Ok exe) + [ args + ; Ml_kind.ppx_driver_flag kind + ; Dep (Path.relative dir src.name) + ; Dyn (fun x -> As x) + ])))))) in fun ~(source : Module.t) ~ast -> Per_module.get lint source.name ~source ~ast) @@ -325,31 +382,49 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess |> setup_reason_rules sctx ~dir in if lint then lint_module ~ast ~source:m; ast) - | Pps { pps; flags } -> - let ppx_exe = get_ppx_driver sctx ~scope pps in - let uses_ppx_driver = uses_ppx_driver ~pps in + | Pps { loc; pps; flags } -> let args : _ Arg_spec.t = S [ As flags - ; A "--dump-ast" ; As (cookie_library_name lib_name) - ; As (if uses_ppx_driver then ["-diff-cmd"; "-"] else []) ] in + let corrected_suffix = ".ppx-corrected" in + let driver_and_flags = + let open Result.O in + get_ppx_driver sctx ~loc ~scope pps >>| fun (exe, driver) -> + (exe, + let extra_vars = + String_map.singleton "corrected-suffix" + (Action.Var_expansion.Strings ([corrected_suffix], Split)) + in + Build.memoize "ppx flags" + (SC.expand_and_eval_set sctx driver.info.flags + ~scope + ~dir + ~extra_vars + ~standard:(Build.return []))) + in (fun m ~lint -> let ast = setup_reason_rules sctx ~dir m in if lint then lint_module ~ast ~source:m; pped_module ast ~dir ~f:(fun kind src dst -> SC.add_rule sctx - (promote_correction ~uses_ppx_driver + (promote_correction ~suffix:corrected_suffix (Option.value_exn (Module.file m ~dir kind)) - (preprocessor_deps + (preprocessor_deps >>^ ignore >>> - Build.run ~context:(SC.context sctx) - (Ok ppx_exe) - [ args - ; A "-o"; Target dst - ; Ml_kind.ppx_driver_flag kind; Dep src - ]))))) + Build.of_result_map driver_and_flags + ~targets:[dst] + ~f:(fun (exe, flags) -> + flags + >>> + Build.run ~context:(SC.context sctx) + (Ok exe) + [ args + ; A "-o"; Target dst + ; Ml_kind.ppx_driver_flag kind; Dep src + ; Dyn (fun x -> As x) + ])))))) let pp_modules t ?(lint=true) modules = Module.Name.Map.map modules ~f:(fun (m : Module.t) -> @@ -357,3 +432,10 @@ let pp_modules t ?(lint=true) modules = let pp_module_as t ?(lint=true) name m = Per_module.get t name m ~lint + +let get_ppx_driver sctx ~scope pps = + let sctx = SC.host sctx in + let open Result.O in + Lib.DB.resolve_pps (Scope.libs scope) pps + >>| fun libs -> + ppx_driver_exe sctx libs diff --git a/src/preprocessing.mli b/src/preprocessing.mli index a9db9201..74ece24b 100644 --- a/src/preprocessing.mli +++ b/src/preprocessing.mli @@ -37,9 +37,14 @@ val pp_module_as (** Get a path to a cached ppx driver *) val get_ppx_driver - : Super_context.t + : Super_context.t -> scope:Scope.t -> (Loc.t * Jbuild.Pp.t) list + -> Path.t Or_exn.t + +val get_ppx_driver_for_public_lib + : Super_context.t + -> name:string -> Path.t (** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not diff --git a/src/sub_system.ml b/src/sub_system.ml index adb24c61..2d1d214f 100644 --- a/src/sub_system.ml +++ b/src/sub_system.ml @@ -43,15 +43,20 @@ module Register_backend(M : Backend) = struct (M.desc ~plural:false)) | Some t -> Ok t - let written_by_user_or_scan ~loc ~written_by_user ~to_scan = + let written_by_user_or_scan ~loc ~written_by_user ~to_scan ~no_backend_error = match match written_by_user with | Some l -> l | None -> List.filter_map to_scan ~f:get with - | [] -> - Error - (Loc.exnf loc "No %s found." (M.desc ~plural:false)) + | [] -> begin + match no_backend_error with + | Some f -> + Error (Loc.exnf loc "%s" (f to_scan)) + | None -> + Error + (Loc.exnf loc "No %s found." (M.desc ~plural:false)) + end | l -> Ok l let too_many_backends ~loc backends = @@ -68,6 +73,7 @@ module Register_backend(M : Backend) = struct let select_extensible_backends ~loc ?written_by_user ~extends to_scan = let open Result.O in written_by_user_or_scan ~loc ~written_by_user ~to_scan + ~no_backend_error:None >>= fun backends -> top_closure backends ~deps:extends >>= fun backends -> @@ -82,9 +88,10 @@ module Register_backend(M : Backend) = struct else Error (too_many_backends ~loc roots) - let select_replaceable_backend ~loc ?written_by_user ~replaces to_scan = + let select_replaceable_backend ~loc ?written_by_user ~replaces + ?no_backend_error to_scan = let open Result.O in - written_by_user_or_scan ~loc ~written_by_user ~to_scan + written_by_user_or_scan ~loc ~written_by_user ~to_scan ~no_backend_error >>= fun backends -> Result.concat_map backends ~f:replaces >>= fun replaced_backends -> diff --git a/src/sub_system_intf.ml b/src/sub_system_intf.ml index 6de0d79b..0a4159ad 100644 --- a/src/sub_system_intf.ml +++ b/src/sub_system_intf.ml @@ -12,7 +12,7 @@ module type S = sig (** Create an instance of the sub-system *) val instantiate : resolve:(Loc.t * string -> Lib.t Or_exn.t) - -> get:(Lib.t -> t option) + -> get:(loc:Loc.t -> Lib.t -> t option) -> Lib.t -> Info.t -> t @@ -67,6 +67,7 @@ module type Registered_backend = sig : loc:Loc.t -> ?written_by_user:t list -> replaces:(t -> t list Or_exn.t) + -> ?no_backend_error:(Lib.t list -> string) -> Lib.t list -> t Or_exn.t end diff --git a/test/blackbox-tests/test-cases/ppx-rewriter/run.t b/test/blackbox-tests/test-cases/ppx-rewriter/run.t index f055be4c..96b19eec 100644 --- a/test/blackbox-tests/test-cases/ppx-rewriter/run.t +++ b/test/blackbox-tests/test-cases/ppx-rewriter/run.t @@ -10,7 +10,7 @@ ocamlopt .w_omp_driver.eobjs/w_omp_driver.{cmx,o} ocamlopt w_omp_driver.exe $ dune build ./w_ppx_driver.exe --display short - ocamlopt .ppx/ppx_driver.runner/ppx.exe + ocamlopt .ppx/ppx_driver/ppx.exe ppx w_ppx_driver.pp.ml ocamldep w_ppx_driver.pp.ml.d ocamlc .w_ppx_driver.eobjs/w_ppx_driver.{cmi,cmo,cmt} diff --git a/test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/dune b/test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/dune index 5144628d..33269f9a 100644 --- a/test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/dune +++ b/test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/dune @@ -3,4 +3,5 @@ (library ((name a_kernel) (public_name a.kernel) + (libraries (ocaml-migrate-parsetree)) (kind ppx_rewriter)))