From f580abb04f729005759a08e4394e8312ee6b92fc Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 28 Feb 2018 16:32:55 +0000 Subject: [PATCH 1/8] 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 7f7d85c0025..808e879337c 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 6d045c204b8..d29d975fb15 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 0319a580aac..ea0a361803e 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 8f7d0071e5e..fcedfdf7028 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 31d9ea5b44a..fb490d49fe4 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 d6887cf45e6..167d3dea161 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 3526e321a6e..09947c98692 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 cc633719c22..19b9e2cf0d9 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 a29b25d8fd2..29065eb1848 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 682a1be4b7d..d70ef8c985c 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 e779e2b8bed..01f27ee2314 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 1963cd93d38..943bb21009b 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 a56e188c7e4..7984b75c974 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -21,91 +21,158 @@ let pped_module ~dir (m : Module.t) ~f = ; intf = Option.map m.intf ~f:(pped_file Intf) } -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 + (Build.of_result_map driver_and_libs ~f:(fun (driver, _) -> + Build.return (sprintf "let () = %s ()\n" driver.info.main)) + >>> + Build.write_file_dyn ml); SC.add_rule sctx - (libs + (Build.record_lib_deps ~kind:dep_kind (Lib_deps.of_pps pps) >>> - Build.dyn_paths - (Build.arr - (Lib.L.archive_files ~mode ~ext_lib:ctx.ext_lib)) + 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 = @@ -127,47 +194,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 @@ -179,9 +222,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" @@ -216,22 +273,14 @@ let setup_reason_rules sctx ~dir (m : Module.t) = ; intf = Option.map m.intf ~f:to_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 @@ -261,34 +310,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) @@ -335,31 +392,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) -> @@ -367,3 +442,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 a9db9201990..74ece24b73a 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 adb24c6102a..2d1d214fd54 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 6de0d79bd0b..0a4159ad780 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 f055be4c478..96b19eecfd9 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 5144628dbcf..33269f9aefa 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))) From b05ea02aea60b5bb3da0f9dc9235dd707dc0ebc2 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Sat, 2 Jun 2018 16:20:41 +0100 Subject: [PATCH 2/8] Add List.assoc Signed-off-by: Jeremie Dimino --- src/main.ml | 2 +- src/stdune/list.ml | 5 +++++ src/stdune/list.mli | 2 ++ src/utils.ml | 6 +++--- test/blackbox-tests/cram.mll | 6 +++--- 5 files changed, 14 insertions(+), 7 deletions(-) diff --git a/src/main.ml b/src/main.ml index 2c70393d1ec..56d38f499c9 100644 --- a/src/main.ml +++ b/src/main.ml @@ -218,7 +218,7 @@ let bootstrap () = Arg.Symbol (List.map Config.Display.all ~f:fst, fun s -> - display := Some (List.assoc s Config.Display.all)) + display := List.assoc Config.Display.all s) in let concurrency = ref None in let concurrency_arg x = diff --git a/src/stdune/list.ml b/src/stdune/list.ml index 06c7cb7df66..5342445f887 100644 --- a/src/stdune/list.ml +++ b/src/stdune/list.ml @@ -97,3 +97,8 @@ let rec compare a b ~compare:f : Ordering.t = match (f x y : Ordering.t) with | Eq -> compare a b ~compare:f | ne -> ne + +let rec assoc t x = + match t with + | [] -> None + | (k, v) :: t -> if x = k then Some v else assoc t x diff --git a/src/stdune/list.mli b/src/stdune/list.mli index 4cfe2dfdd5c..c636079c8c0 100644 --- a/src/stdune/list.mli +++ b/src/stdune/list.mli @@ -36,3 +36,5 @@ val sort : 'a t -> compare:('a -> 'a -> Ordering.t) -> 'a t val stable_sort : 'a t -> compare:('a -> 'a -> Ordering.t) -> 'a t val compare : 'a t -> 'a t -> compare:('a -> 'a -> Ordering.t) -> Ordering.t + +val assoc : ('a * 'b) t -> 'a -> 'b option diff --git a/src/utils.ml b/src/utils.ml index 065e4556bde..c8fb0a8b09f 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -60,9 +60,9 @@ let signal_name = ] in fun n -> - match List.assoc n table with - | exception Not_found -> sprintf "%d\n" n - | s -> s + match List.assoc table n with + | None -> sprintf "%d\n" n + | Some s -> s type target_kind = | Regular of string * Path.t diff --git a/test/blackbox-tests/cram.mll b/test/blackbox-tests/cram.mll index ddc953bf076..fdfc0e0d120 100644 --- a/test/blackbox-tests/cram.mll +++ b/test/blackbox-tests/cram.mll @@ -24,9 +24,9 @@ and postprocess tbl b = parse | eof { Buffer.contents b } | ([^ '/'] as c) (ext as e) { Buffer.add_char b c; - begin match List.assoc e tbl with - | res -> Buffer.add_string b res - | exception Not_found -> Buffer.add_string b e + begin match List.assoc tbl e with + | Some res -> Buffer.add_string b res + | None -> Buffer.add_string b e end; postprocess tbl b lexbuf } From 5f47100c42b82140e39dc6acf96f0c846cc12461 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Fri, 1 Jun 2018 19:44:50 +0100 Subject: [PATCH 3/8] Restore old ppx behavior for directories with jbuild files Signed-off-by: Jeremie Dimino --- CHANGES.md | 2 +- dune.opam | 2 - src/file_tree.ml | 52 ++- src/file_tree.mli | 17 +- src/gen_rules.ml | 49 +-- src/install_rules.ml | 35 +- src/jbuild.ml | 13 - src/jbuild_load.ml | 50 ++- src/jbuild_load.mli | 11 +- src/merlin.ml | 12 +- src/merlin.mli | 1 + src/preprocessing.ml | 323 ++++++++++++------ src/preprocessing.mli | 3 + src/super_context.ml | 36 +- src/super_context.mli | 14 +- .../test-cases/github644/{dune => jbuild} | 0 .../blackbox-tests/test-cases/github644/run.t | 4 +- .../test-cases/ppx-rewriter/{dune => jbuild} | 0 .../ppx-rewriter/ppx/{dune => jbuild} | 0 .../test-cases/ppx-rewriter/run.t | 4 +- .../private-rewriter/{dune => jbuild} | 0 .../private-runtime-deps/{dune => jbuild} | 0 .../test-cases/private-public-overlap/run.t | 6 +- .../scope-ppx-bug/a/kernel/{dune => jbuild} | 1 - .../scope-ppx-bug/a/ppx/{dune => jbuild} | 0 .../scope-ppx-bug/b/{dune => jbuild} | 0 .../test-cases/scope-ppx-bug/run.t | 4 +- 27 files changed, 431 insertions(+), 208 deletions(-) rename test/blackbox-tests/test-cases/github644/{dune => jbuild} (100%) rename test/blackbox-tests/test-cases/ppx-rewriter/{dune => jbuild} (100%) rename test/blackbox-tests/test-cases/ppx-rewriter/ppx/{dune => jbuild} (100%) rename test/blackbox-tests/test-cases/private-public-overlap/private-rewriter/{dune => jbuild} (100%) rename test/blackbox-tests/test-cases/private-public-overlap/private-runtime-deps/{dune => jbuild} (100%) rename test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/{dune => jbuild} (70%) rename test/blackbox-tests/test-cases/scope-ppx-bug/a/ppx/{dune => jbuild} (100%) rename test/blackbox-tests/test-cases/scope-ppx-bug/b/{dune => jbuild} (100%) diff --git a/CHANGES.md b/CHANGES.md index 808e879337c..231139f096a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -57,7 +57,7 @@ next format blocks of texts (#837, @diml) - Remove hard-coded knowledge of ppx_driver and - ocaml-migrate-parsetree (#576, @diml) + ocaml-migrate-parsetree when using a `dune` file (#576, @diml) 1.0+beta20 (10/04/2018) ----------------------- diff --git a/dune.opam b/dune.opam index fcedfdf7028..f87556a7719 100644 --- a/dune.opam +++ b/dune.opam @@ -14,6 +14,4 @@ build: [ available: [ ocaml-version >= "4.02.3" ] conflicts: [ "jbuilder" {!= "transition"} - "ppx_driver" {< "v0.10.3"} - "ocaml-migrate-parsetree" {< "1.0.8"} ] diff --git a/src/file_tree.ml b/src/file_tree.ml index 9e881888aa5..460938a0161 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -1,6 +1,19 @@ open! Import module Dune_file = struct + module Kind = struct + type t = Dune | Jbuild + + let of_basename = function + | "dune" -> Dune + | "jbuild" -> Jbuild + | _ -> assert false + + let lexer = function + | Dune -> Sexp.Lexer.token + | Jbuild -> Sexp.Lexer.jbuild_token + end + module Plain = struct type t = { path : Path.t @@ -8,12 +21,20 @@ module Dune_file = struct } end + module Contents = struct + type t = + | Plain of Plain.t + | Ocaml_script of Path.t + end + type t = - | Plain of Plain.t - | Ocaml_script of Path.t + { contents : Contents.t + ; kind : Kind.t + } - let path = function - | Plain x -> x.path + let path t = + match t.contents with + | Plain x -> x.path | Ocaml_script p -> p let extract_ignored_subdirs = @@ -47,14 +68,19 @@ module Dune_file = struct in (ignored_subdirs, sexps) - let load ?lexer file = + let load file ~kind = Io.with_lexbuf_from_file file ~f:(fun lb -> - if Dune_lexer.is_script lb then - (Ocaml_script file, String.Set.empty) - else - let sexps = Usexp.Parser.parse lb ?lexer ~mode:Many in - let ignored_subdirs, sexps = extract_ignored_subdirs sexps in - (Plain { path = file; sexps }, ignored_subdirs)) + let contents, ignored_subdirs = + if Dune_lexer.is_script lb then + (Contents.Ocaml_script file, String.Set.empty) + else + let sexps = + Usexp.Parser.parse lb ~lexer:(Kind.lexer kind) ~mode:Many + in + let ignored_subdirs, sexps = extract_ignored_subdirs sexps in + (Plain { path = file; sexps }, ignored_subdirs) + in + ({ contents; kind }, ignored_subdirs)) end let load_jbuild_ignore path = @@ -195,9 +221,7 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path = | [fn] -> let dune_file, ignored_subdirs = Dune_file.load (Path.relative path fn) - ~lexer:(match fn with - | "jbuild" -> Sexp.Lexer.jbuild_token - | _ -> Sexp.Lexer.token) + ~kind:(Dune_file.Kind.of_basename fn) in (Some dune_file, ignored_subdirs) | _ -> diff --git a/src/file_tree.mli b/src/file_tree.mli index 192e048f93a..c95f2f906bd 100644 --- a/src/file_tree.mli +++ b/src/file_tree.mli @@ -3,6 +3,12 @@ open! Import module Dune_file : sig + module Kind : sig + type t = Dune | Jbuild + + val lexer : t -> Sexp.Lexer.t + end + module Plain : sig (** [sexps] is mutable as we get rid of the S-expressions once they have been parsed, in order to release the memory as soon @@ -13,9 +19,16 @@ module Dune_file : sig } end + module Contents : sig + type t = + | Plain of Plain.t + | Ocaml_script of Path.t + end + type t = - | Plain of Plain.t - | Ocaml_script of Path.t + { contents : Contents.t + ; kind : Kind.t + } val path : t -> Path.t end diff --git a/src/gen_rules.ml b/src/gen_rules.ml index bd48a3cdf62..146dccbbb48 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -542,7 +542,7 @@ module Gen(P : Install_rules.Params) = struct let alias_module_build_sandbox = ctx.version < (4, 03, 0) let library_rules (lib : Library.t) ~modules_partitioner ~dir ~files ~scope - ~compile_info = + ~compile_info ~dir_kind = let obj_dir = Utils.library_object_directory ~dir lib.name in let requires = Lib.Compile.requires compile_info in let dep_kind = if lib.optional then Build.Optional else Required in @@ -559,6 +559,7 @@ module Gen(P : Install_rules.Params) = struct lib.buildable.preprocessor_deps) ~lint:lib.buildable.lint ~lib_name:(Some lib.name) + ~dir_kind in let modules = Preprocessing.pp_modules pp modules in @@ -789,7 +790,8 @@ module Gen(P : Install_rules.Params) = struct ~libname:lib.name ~objs_dirs:(Path.Set.singleton obj_dir) - let library_rules (lib : Library.t) ~modules_partitioner ~dir ~files ~scope = + let library_rules (lib : Library.t) ~modules_partitioner ~dir ~files ~scope + ~dir_kind : Merlin.t = let compile_info = Lib.DB.get_compile_info (Scope.libs scope) lib.name ~allow_overlaps:lib.buildable.allow_overlapping_dependencies @@ -797,13 +799,14 @@ module Gen(P : Install_rules.Params) = struct SC.Libs.gen_select_rules sctx compile_info ~dir; SC.Libs.with_lib_deps sctx compile_info ~dir ~f:(fun () -> - library_rules lib ~modules_partitioner ~dir ~files ~scope ~compile_info) + library_rules lib ~modules_partitioner ~dir ~files ~scope ~compile_info + ~dir_kind) (* +-----------------------------------------------------------------+ | Executables stuff | +-----------------------------------------------------------------+ *) - let executables_rules ~dir ~all_modules + let executables_rules ~dir ~all_modules ~dir_kind ~modules_partitioner ~scope ~compile_info (exes : Executables.t) = let requires = Lib.Compile.requires compile_info in @@ -822,6 +825,7 @@ module Gen(P : Install_rules.Params) = struct ~preprocessor_deps ~lint:exes.buildable.lint ~lib_name:None + ~dir_kind in let modules = Module.Name.Map.map modules ~f:(fun m -> @@ -907,7 +911,8 @@ module Gen(P : Install_rules.Params) = struct ~objs_dirs:(Path.Set.singleton obj_dir) let executables_rules ~dir ~all_modules - ~modules_partitioner ~scope (exes : Executables.t) = + ~modules_partitioner ~scope ~dir_kind + (exes : Executables.t) : Merlin.t = let compile_info = Lib.DB.resolve_user_written_deps (Scope.libs scope) exes.buildable.libraries @@ -918,7 +923,7 @@ module Gen(P : Install_rules.Params) = struct SC.Libs.with_lib_deps sctx compile_info ~dir ~f:(fun () -> executables_rules exes ~dir ~all_modules - ~modules_partitioner ~scope ~compile_info) + ~modules_partitioner ~scope ~compile_info ~dir_kind) (* +-----------------------------------------------------------------+ | Aliases | @@ -961,7 +966,7 @@ module Gen(P : Install_rules.Params) = struct | Stanza | +-----------------------------------------------------------------+ *) - let gen_rules { SC.Dir_with_jbuild. src_dir; ctx_dir; stanzas; scope } = + let gen_rules { SC.Dir_with_jbuild. src_dir; ctx_dir; stanzas; scope; kind } = (* This interprets "rule" and "copy_files" stanzas. *) let files = text_files ~dir:ctx_dir in let all_modules = modules_by_dir ~dir:ctx_dir in @@ -971,10 +976,11 @@ module Gen(P : Install_rules.Params) = struct let dir = ctx_dir in match (stanza : Stanza.t) with | Library lib -> - Some (library_rules lib ~dir ~files ~scope ~modules_partitioner) + Some (library_rules lib ~dir ~files ~scope ~modules_partitioner + ~dir_kind:kind) | Executables exes -> Some (executables_rules exes ~dir ~all_modules ~scope - ~modules_partitioner) + ~modules_partitioner ~dir_kind:kind) | Alias alias -> alias_rules alias ~dir ~scope; None @@ -990,7 +996,7 @@ module Gen(P : Install_rules.Params) = struct | _ -> None) in Option.iter (Merlin.merge_all merlins) ~f:(fun m -> - Merlin.add_rules sctx ~dir:ctx_dir ~scope + Merlin.add_rules sctx ~dir:ctx_dir ~scope ~dir_kind:kind (Merlin.add_source_dir m src_dir)); Utop.setup sctx ~dir:ctx_dir ~scope ~libs:( List.filter_map stanzas ~f:(function @@ -1089,17 +1095,18 @@ let gen ~contexts ~build_system match only_packages with | None -> stanzas | Some pkgs -> - List.map stanzas ~f:(fun (dir, pkgs_ctx, stanzas) -> - (dir, - pkgs_ctx, - List.filter stanzas ~f:(fun stanza -> - match (stanza : Stanza.t) with - | Library { public = Some { package; _ }; _ } - | Alias { package = Some package ; _ } - | Install { package; _ } - | Documentation { package; _ } -> - Package.Name.Set.mem pkgs package.name - | _ -> true))) + List.map stanzas ~f:(fun (dir_conf : Jbuild_load.Jbuild.t) -> + let stanzas = + List.filter dir_conf.stanzas ~f:(fun stanza -> + match (stanza : Stanza.t) with + | Library { public = Some { package; _ }; _ } + | Alias { package = Some package ; _ } + | Install { package; _ } + | Documentation { package; _ } -> + Package.Name.Set.mem pkgs package.name + | _ -> true) + in + { dir_conf with stanzas }) in Fiber.fork_and_join host stanzas >>= fun (host, stanzas) -> let sctx = diff --git a/src/install_rules.ml b/src/install_rules.ml index 167d3dea161..97e5f886c75 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 ~name (lib : Library.t) = + let lib_install_files ~dir ~sub_dir ~name ~scope ~dir_kind (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,7 +184,30 @@ module Gen(P : Install_params) = struct match lib.kind with | Normal | Ppx_deriver -> [] | Ppx_rewriter -> - [Preprocessing.get_ppx_driver_for_public_lib sctx ~name] + match (dir_kind : File_tree.Dune_file.Kind.t) with + | Dune -> + [Preprocessing.get_ppx_driver_for_public_lib sctx ~name ~dir_kind] + | Jbuild -> + let pps = [(lib.buildable.loc, Pp.of_string lib.name)] in + let pps = + 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 + match Preprocessing.get_ppx_driver sctx ~scope ~dir_kind pps with + | Ok x -> [x] + | Error _ -> + [Preprocessing.get_ppx_driver_for_public_lib sctx ~name ~dir_kind] in List.concat [ List.map files ~f:(make_entry Lib ) @@ -274,10 +297,12 @@ 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 { SC.Installable. dir; stanza; kind = dir_kind; scope; _ } -> match stanza with - | Library ({ public = Some { package; sub_dir; name; _ }; _ } as lib) -> - List.map (lib_install_files ~dir ~sub_dir ~name lib) + | Library ({ public = Some { package; sub_dir; name; _ } + ; _ } as lib) -> + List.map (lib_install_files ~dir ~sub_dir ~name lib ~scope + ~dir_kind) ~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 09947c98692..d5c3b2641ed 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -262,19 +262,6 @@ module Preprocess = struct 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 - 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 }) ] diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index b7e26206108..9f13896fd57 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -9,16 +9,26 @@ let filter_stanzas ~ignore_promoted_rules stanzas = else stanzas +module Jbuild = struct + type t = + { dir : Path.t + ; project : Dune_project.t + ; stanzas : Stanzas.t + ; kind : File_tree.Dune_file.Kind.t + } +end + module Jbuilds = struct type script = { dir : Path.t ; file : Path.t ; project : Dune_project.t + ; kind : File_tree.Dune_file.Kind.t } type one = - | Literal of (Path.t * Dune_project.t * Stanza.t list) - | Script of script + | Literal of Jbuild.t + | Script of script type t = { jbuilds : one list @@ -114,7 +124,7 @@ end | Literal x -> Left x | Script x -> Right x) in - Fiber.parallel_map dynamic ~f:(fun { dir; file; project } -> + Fiber.parallel_map dynamic ~f:(fun { dir; file; project; kind } -> let generated_jbuild = Path.append (Path.relative generated_jbuilds_dir context.name) file in @@ -153,10 +163,19 @@ end die "@{Error:@} %s failed to produce a valid jbuild file.\n\ Did you forgot to call [Jbuild_plugin.V*.send]?" (Path.to_string file); - let sexps = Io.Sexp.load generated_jbuild ~mode:Many in - Fiber.return (dir, project, - Stanzas.parse project sexps ~file:generated_jbuild - |> filter_stanzas ~ignore_promoted_rules)) + let stanzas = + Io.Sexp.load generated_jbuild ~mode:Many + ~lexer:(File_tree.Dune_file.Kind.lexer kind) + |> Stanzas.parse project ~file:generated_jbuild + |> filter_stanzas ~ignore_promoted_rules + in + Fiber.return + { Jbuild. + dir + ; project + ; kind + ; stanzas + }) >>| fun dynamic -> static @ dynamic end @@ -170,17 +189,24 @@ type conf = let interpret ~dir ~project ~ignore_promoted_rules ~(dune_file:File_tree.Dune_file.t) = - match dune_file with + match dune_file.contents with | Plain p -> + let stanzas = + Stanzas.parse project p.sexps ~file:p.path + |> filter_stanzas ~ignore_promoted_rules + in let jbuild = - Jbuilds.Literal (dir, project, - Stanzas.parse project p.sexps ~file:p.path - |> filter_stanzas ~ignore_promoted_rules) + Jbuilds.Literal + { dir + ; project + ; stanzas + ; kind = dune_file.kind + } in p.sexps <- []; jbuild | Ocaml_script file -> - Script { dir; project; file } + Script { dir; project; file; kind = dune_file.kind } let load ?extra_ignored_subtrees ?(ignore_promoted_rules=false) () = let ftree = File_tree.load Path.root ?extra_ignored_subtrees in diff --git a/src/jbuild_load.mli b/src/jbuild_load.mli index 9a6be25050a..5dc286d05e2 100644 --- a/src/jbuild_load.mli +++ b/src/jbuild_load.mli @@ -1,12 +1,21 @@ open Stdune +module Jbuild : sig + type t = + { dir : Path.t + ; project : Dune_project.t + ; stanzas : Jbuild.Stanzas.t + ; kind : File_tree.Dune_file.Kind.t + } +end + module Jbuilds : sig type t val eval : t -> context:Context.t - -> (Path.t * Dune_project.t * Jbuild.Stanzas.t) list Fiber.t + -> Jbuild.t list Fiber.t end type conf = diff --git a/src/merlin.ml b/src/merlin.ml index 01f27ee2314..9aa03dcd419 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -96,10 +96,10 @@ let make let add_source_dir t dir = { t with source_dirs = Path.Set.add t.source_dirs dir } -let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } = +let ppx_flags sctx ~dir:_ ~scope ~dir_kind { preprocess; libname; _ } = match preprocess with | Pps { loc = _; pps; flags } -> begin - match Preprocessing.get_ppx_driver sctx ~scope pps with + match Preprocessing.get_ppx_driver sctx ~scope ~dir_kind pps with | Ok exe -> (Path.to_absolute_filename exe :: "--as-ppx" @@ -109,7 +109,7 @@ let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } = end | Other -> [] -let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) = +let dot_merlin sctx ~dir ~scope ~dir_kind ({ requires; flags; _ } as t) = match Path.drop_build_context dir with | None -> () | Some remaindir -> @@ -139,7 +139,7 @@ let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) = in Dot_file.to_string ~remaindir - ~ppx:(ppx_flags sctx ~dir ~scope ~src_dir:remaindir t) + ~ppx:(ppx_flags sctx ~dir ~scope ~dir_kind t) ~flags ~src_dirs ~obj_dirs) @@ -162,6 +162,6 @@ let merge_all = function | [] -> None | init::ts -> Some (List.fold_left ~init ~f:merge_two ts) -let add_rules sctx ~dir ~scope merlin = +let add_rules sctx ~dir ~scope ~dir_kind merlin = if (SC.context sctx).merlin then - dot_merlin sctx ~dir ~scope merlin + dot_merlin sctx ~dir ~scope ~dir_kind merlin diff --git a/src/merlin.mli b/src/merlin.mli index 943bb21009b..c45457a0b12 100644 --- a/src/merlin.mli +++ b/src/merlin.mli @@ -23,5 +23,6 @@ val add_rules : Super_context.t -> dir:Path.t -> scope:Scope.t + -> dir_kind:File_tree.Dune_file.Kind.t -> t -> unit diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 7984b75c974..05bccd2d67d 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -66,21 +66,26 @@ module Driver = struct ] end + (* The [lib] field is lazy so that we don't need to fill it for + hardcoded [t] values used to implement the jbuild style + handling of drivers. + + See [Jbuild_driver] below for details. *) type t = { info : Info.t - ; lib : Lib.t + ; lib : Lib.t Lazy.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 lib t = Lazy.force t.lib let replaces t = t.replaces let instantiate ~resolve ~get lib (info : Info.t) = { info - ; lib + ; lib = lazy lib ; replaces = let open Result.O in Result.all @@ -96,7 +101,7 @@ module Driver = struct let to_sexp t = let open Sexp.To_sexp in - let f x = string (Lib.name x.lib) in + let f x = string (Lib.name (Lazy.force x.lib)) in ((1, 0), record [ "flags" , Ordered_set_lang.Unexpanded.sexp_of_t @@ -111,8 +116,78 @@ module Driver = struct include Sub_system.Register_backend(M) end -let ppx_exe sctx ~key = - Path.relative (SC.build_dir sctx) (".ppx/" ^ key ^ "/ppx.exe") +module Jbuild_driver = struct + (* This module is used to implement the jbuild handling of ppx + drivers. It doesn't implement exactly the same algorithm, but it + should be enough for all jbuilder packages out there. + + It works as follow: given the list of ppx rewriters specified by + the user, check whether the last one is named [ppxlib.runner] or + [ppx_driver.runner]. If it isn't, assume the driver is + ocaml-migrate-parsetree and use some hard-coded driver + information. If it is, use the corresponding hardcoded driver + information. *) + + let make name info : (Pp.t * Driver.t) Lazy.t = lazy ( + let info = + Sexp.parse_string ~mode:Single ~fname:"" info + |> Driver.Info.parse + in + (Pp.of_string name, + { info + ; lib = lazy (assert false) + ; replaces = Ok [] + })) + let omp = make "ocaml-migrate-parsetree" {| + ((main Migrate_parsetree.Driver.run_main) + (flags (--dump-ast)) + (lint_flags (--null))) + |} + let ppxlib = make "ppxlib" {| + ((main Ppxlib.Driver.standalone) + (flags (-diff-cmd - -dump-ast)) + (lint_flags (-diff-cmd - -null ))) + |} + let ppx_driver = make "ppx_driver" {| + ((main Ppx_driver.standalone) + (flags (-diff-cmd - -dump-ast)) + (lint_flags (-diff-cmd - -null ))) + |} + + let drivers = + [ Pp.of_string "ocaml-migrate-parsetree.driver-main" , omp + ; Pp.of_string "ppxlib.runner" , ppxlib + ; Pp.of_string "ppx_driver.runner" , ppx_driver + ] + + let get_driver pps = + let driver = + match List.last pps with + | None -> omp + | Some (_, pp) -> Option.value (List.assoc drivers pp) ~default:omp + in + snd (Lazy.force driver) + + (* For building the driver *) + let analyse_pps pps = + let driver, rev_others = + match List.rev pps with + | [] -> (omp, []) + | pp :: rev_rest as rev_pps -> + match List.assoc drivers pp with + | None -> (omp , rev_pps ) + | Some driver -> (driver, rev_rest) + in + let driver_pp, driver = Lazy.force driver in + (driver, List.rev (driver_pp :: rev_others)) +end + +let ppx_exe sctx ~key ~dir_kind = + match (dir_kind : File_tree.Dune_file.Kind.t) with + | Dune -> + Path.relative (SC.build_dir sctx) (".ppx/" ^ key ^ "/ppx.exe") + | Jbuild -> + Path.relative (SC.build_dir sctx) (".ppx/jbuild/" ^ key ^ "/ppx.exe") let no_driver_error pps = let has name = @@ -130,10 +205,17 @@ let no_driver_error pps = "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 build_ppx_driver sctx ~lib_db ~dep_kind ~target ~dir_kind 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 jbuild_driver, pps = + match (dir_kind : File_tree.Dune_file.Kind.t) with + | Dune -> (None, pps) + | Jbuild -> + let driver, pps = Jbuild_driver.analyse_pps pps in + (Some driver, pps) + in let driver_and_libs = let open Result.O in Result.map_error ~f:(fun e -> @@ -145,11 +227,15 @@ let build_ppx_driver sctx ~lib_db ~dep_kind ~target pps = (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)) + match jbuild_driver with + | None -> + Driver.select_replaceable_backend resolved_pps ~loc:Loc.none + ~replaces:Driver.replaces + ~no_backend_error:no_driver_error + >>| fun driver -> + (driver, resolved_pps) + | Some driver -> + Ok (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. *) @@ -175,26 +261,29 @@ let build_ppx_driver sctx ~lib_db ~dep_kind ~target pps = ; Dep ml ]) +let get_rules sctx key ~dir_kind = + let exe = ppx_exe sctx ~key ~dir_kind in + let (key, lib_db) = SC.Scope_key.of_string sctx key in + let names = + match key with + | "+none+" -> [] + | _ -> String.split key ~on:'+' + in + let names = + match List.rev names with + | [] -> [] + | driver :: rest -> List.sort rest ~compare:String.compare @ [driver] + in + let pps = List.map names ~f:Jbuild.Pp.of_string in + build_ppx_driver sctx pps ~lib_db ~dep_kind:Required ~target:exe ~dir_kind + let gen_rules sctx components = match components with - | [key] -> - let exe = ppx_exe sctx ~key in - let (key, lib_db) = SC.Scope_key.of_string sctx key in - let names = - match key with - | "+none+" -> [] - | _ -> String.split key ~on:'+' - in - let names = - match List.rev names with - | [] -> [] - | driver :: rest -> List.sort rest ~compare:String.compare @ [driver] - in - let pps = List.map names ~f:Jbuild.Pp.of_string in - build_ppx_driver sctx pps ~lib_db ~dep_kind:Required ~target:exe + | [key] -> get_rules sctx key ~dir_kind:Dune + | ["jbuild"; key] -> get_rules sctx key ~dir_kind:Jbuild | _ -> () -let ppx_driver_exe sctx libs = +let ppx_driver_exe sctx libs ~dir_kind = let names = List.rev_map libs ~f:Lib.name |> List.sort ~compare:String.compare @@ -222,22 +311,29 @@ let ppx_driver_exe sctx libs = | None -> key | Some scope_name -> SC.Scope_key.to_string key scope_name in - ppx_exe sctx ~key + ppx_exe sctx ~key ~dir_kind -let get_ppx_driver_for_public_lib sctx ~name = - ppx_exe sctx ~key:name +let get_ppx_driver_for_public_lib sctx ~name ~dir_kind = + ppx_exe sctx ~key:name ~dir_kind -let get_ppx_driver sctx ~loc ~scope pps = +let get_ppx_driver sctx ~loc ~scope ~dir_kind 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) + match (dir_kind : File_tree.Dune_file.Kind.t) with + | Dune -> + 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 ~dir_kind, driver) + | Jbuild -> + let driver = Jbuild_driver.get_driver pps in + Lib.DB.resolve_pps (Scope.libs scope) pps + >>= fun libs -> + Ok (ppx_driver_exe sctx libs ~dir_kind, driver) let target_var = String_with_vars.virt_var __POS__ "@" let root_var = String_with_vars.virt_var __POS__ "ROOT" @@ -282,85 +378,88 @@ let promote_correction fn build ~suffix = (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 - let add_alias fn build = - SC.add_alias_action sctx alias build - ~stamp:(List [ Sexp.unsafe_atom_of_string "lint" - ; Sexp.To_sexp.(option string) lib_name - ; Sexp.atom fn - ]) - in - let lint = - Per_module.map lint ~f:(function - | Preprocess.No_preprocessing -> - (fun ~source:_ ~ast:_ -> ()) - | Action (loc, action) -> - (fun ~source ~ast:_ -> - let action = Action.Unexpanded.Chdir (root_var, action) in - Module.iter source ~f:(fun _ (src : Module.File.t) -> - let src_path = Path.relative dir src.name in - add_alias src.name - (Build.path src_path - >>^ (fun _ -> [src_path]) - >>> SC.Action.run sctx - action - ~loc - ~dir - ~dep_kind - ~targets:(Static []) - ~scope))) - | Pps { loc; pps; flags } -> - let args : _ Arg_spec.t = - S [ As flags - ; As (cookie_library_name lib_name) - ] - 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 -> - add_alias src.name - (promote_correction ~suffix:corrected_suffix - (Option.value_exn (Module.file ~dir source kind)) - (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) +let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = + Staged.stage ( + let alias = Build_system.Alias.lint ~dir in + let add_alias fn build = + SC.add_alias_action sctx alias build + ~stamp:(List [ Sexp.unsafe_atom_of_string "lint" + ; Sexp.To_sexp.(option string) lib_name + ; Sexp.atom fn + ]) + in + let lint = + Per_module.map lint ~f:(function + | Preprocess.No_preprocessing -> + (fun ~source:_ ~ast:_ -> ()) + | Action (loc, action) -> + (fun ~source ~ast:_ -> + let action = Action.Unexpanded.Chdir (root_var, action) in + Module.iter source ~f:(fun _ (src : Module.File.t) -> + let src_path = Path.relative dir src.name in + add_alias src.name + (Build.path src_path + >>^ (fun _ -> [src_path]) + >>> SC.Action.run sctx + action + ~loc + ~dir + ~dep_kind + ~targets:(Static []) + ~scope))) + | Pps { loc; pps; flags } -> + let args : _ Arg_spec.t = + S [ As flags + ; As (cookie_library_name lib_name) + ] + in + let corrected_suffix = ".lint-corrected" in + let driver_and_flags = + let open Result.O in + get_ppx_driver sctx ~loc ~scope ~dir_kind 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 -> + add_alias src.name + (promote_correction ~suffix:corrected_suffix + (Option.value_exn (Module.file ~dir source kind)) + (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) type t = (Module.t -> lint:bool -> Module.t) Per_module.t let dummy = Per_module.for_all (fun m ~lint:_ -> m) let make sctx ~dir ~dep_kind ~lint ~preprocess - ~preprocessor_deps ~lib_name ~scope = + ~preprocessor_deps ~lib_name ~scope ~dir_kind = let preprocessor_deps = Build.memoize "preprocessor deps" preprocessor_deps in let lint_module = - Staged.unstage (lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope) + Staged.unstage (lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope + ~dir_kind) in Per_module.map preprocess ~f:(function | Preprocess.No_preprocessing -> @@ -401,7 +500,7 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess 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) -> + get_ppx_driver sctx ~loc ~scope ~dir_kind pps >>| fun (exe, driver) -> (exe, let extra_vars = String_map.singleton "corrected-suffix" @@ -443,9 +542,9 @@ 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 get_ppx_driver sctx ~scope ~dir_kind 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 + ppx_driver_exe sctx libs ~dir_kind diff --git a/src/preprocessing.mli b/src/preprocessing.mli index 74ece24b73a..23bb44bba59 100644 --- a/src/preprocessing.mli +++ b/src/preprocessing.mli @@ -16,6 +16,7 @@ val make -> preprocessor_deps:(unit, Path.t list) Build.t -> lib_name:string option -> scope:Scope.t + -> dir_kind:File_tree.Dune_file.Kind.t -> t (** Setup the preprocessing rules for the following modules and @@ -39,12 +40,14 @@ val pp_module_as val get_ppx_driver : Super_context.t -> scope:Scope.t + -> dir_kind:File_tree.Dune_file.Kind.t -> (Loc.t * Jbuild.Pp.t) list -> Path.t Or_exn.t val get_ppx_driver_for_public_lib : Super_context.t -> name:string + -> dir_kind:File_tree.Dune_file.Kind.t -> Path.t (** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not diff --git a/src/super_context.ml b/src/super_context.ml index deb6ff96139..b9978d1a2b6 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -10,6 +10,16 @@ module Dir_with_jbuild = struct ; ctx_dir : Path.t ; stanzas : Stanzas.t ; scope : Scope.t + ; kind : File_tree.Dune_file.Kind.t + } +end + +module Installable = struct + type t = + { dir : Path.t + ; scope : Scope.t + ; stanza : Stanza.t + ; kind : File_tree.Dune_file.Kind.t } end @@ -33,7 +43,7 @@ type t = ; packages : Package.t Package.Name.Map.t ; file_tree : File_tree.t ; artifacts : Artifacts.t - ; stanzas_to_consider_for_install : (Path.t * Scope.t * Stanza.t) list + ; stanzas_to_consider_for_install : Installable.t list ; cxx_flags : string list ; vars : Action.Var_expansion.t String.Map.t ; chdir : (Action.t, Action.t) Build.t @@ -189,7 +199,7 @@ let create Lib.DB.create_from_findlib context.findlib ~external_lib_deps_mode in let internal_libs = - List.concat_map stanzas ~f:(fun (dir, _, stanzas) -> + List.concat_map stanzas ~f:(fun { Jbuild_load.Jbuild. dir; stanzas; _ } -> let ctx_dir = Path.append context.build_dir dir in List.filter_map stanzas ~f:(fun stanza -> match (stanza : Stanza.t) with @@ -209,18 +219,19 @@ let create in let stanzas = List.map stanzas - ~f:(fun (dir, project, stanzas) -> + ~f:(fun { Jbuild_load.Jbuild. dir; project; stanzas; kind } -> let ctx_dir = Path.append context.build_dir dir in { Dir_with_jbuild. src_dir = dir ; ctx_dir ; stanzas ; scope = Scope.DB.find_by_name scopes project.Dune_project.name + ; kind }) in let stanzas_to_consider_for_install = if not external_lib_deps_mode then - List.concat_map stanzas ~f:(fun { ctx_dir; stanzas; scope; _ } -> + List.concat_map stanzas ~f:(fun { ctx_dir; stanzas; scope; kind; _ } -> List.filter_map stanzas ~f:(fun stanza -> let keep = match (stanza : Stanza.t) with @@ -229,10 +240,21 @@ let create | Install _ -> true | _ -> false in - Option.some_if keep (ctx_dir, scope, stanza))) + Option.some_if keep { Installable. + dir = ctx_dir + ; scope + ; stanza + ; kind + })) else - List.concat_map stanzas ~f:(fun { ctx_dir; stanzas; scope; _ } -> - List.map stanzas ~f:(fun s -> (ctx_dir, scope, s))) + List.concat_map stanzas ~f:(fun { ctx_dir; stanzas; scope; kind; _ } -> + List.map stanzas ~f:(fun stanza -> + { Installable. + dir = ctx_dir + ; scope + ; stanza + ; kind + })) in let artifacts = Artifacts.create context ~public_libs stanzas diff --git a/src/super_context.mli b/src/super_context.mli index a762c9609cc..68dc53326c2 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -15,6 +15,16 @@ module Dir_with_jbuild : sig ; ctx_dir : Path.t (** [_build/context-name/src_dir] *) ; stanzas : Stanzas.t ; scope : Scope.t + ; kind : File_tree.Dune_file.Kind.t + } +end + +module Installable : sig + type t = + { dir : Path.t + ; scope : Scope.t + ; stanza : Stanza.t + ; kind : File_tree.Dune_file.Kind.t } end @@ -26,7 +36,7 @@ val create -> projects:Dune_project.t list -> file_tree:File_tree.t -> packages:Package.t Package.Name.Map.t - -> stanzas:(Path.t * Dune_project.t * Stanzas.t) list + -> stanzas:Jbuild_load.Jbuild.t list -> external_lib_deps_mode:bool -> build_system:Build_system.t -> t @@ -37,7 +47,7 @@ val packages : t -> Package.t Package.Name.Map.t val libs_by_package : t -> (Package.t * Lib.Set.t) Package.Name.Map.t val file_tree : t -> File_tree.t val artifacts : t -> Artifacts.t -val stanzas_to_consider_for_install : t -> (Path.t * Scope.t * Stanza.t) list +val stanzas_to_consider_for_install : t -> Installable.t list val cxx_flags : t -> string list val build_dir : t -> Path.t val profile : t -> string diff --git a/test/blackbox-tests/test-cases/github644/dune b/test/blackbox-tests/test-cases/github644/jbuild similarity index 100% rename from test/blackbox-tests/test-cases/github644/dune rename to test/blackbox-tests/test-cases/github644/jbuild diff --git a/test/blackbox-tests/test-cases/github644/run.t b/test/blackbox-tests/test-cases/github644/run.t index 8bdb70fd7e4..d64d64c1657 100644 --- a/test/blackbox-tests/test-cases/github644/run.t +++ b/test/blackbox-tests/test-cases/github644/run.t @@ -1,5 +1,5 @@ $ dune runtest - File "dune", line 4, characters 20-42: + File "jbuild", line 4, characters 20-42: Error: Library "ppx_that_doesn't_exist" not found. Hint: try: dune external-lib-deps --missing @runtest [1] @@ -8,7 +8,7 @@ These should print something: $ dune external-lib-deps --display quiet @runtest These are the external library dependencies in the default context: - - ocaml-migrate-parsetree.driver-main + - ocaml-migrate-parsetree - ppx_that_doesn't_exist $ dune external-lib-deps --display quiet --missing @runtest diff --git a/test/blackbox-tests/test-cases/ppx-rewriter/dune b/test/blackbox-tests/test-cases/ppx-rewriter/jbuild similarity index 100% rename from test/blackbox-tests/test-cases/ppx-rewriter/dune rename to test/blackbox-tests/test-cases/ppx-rewriter/jbuild diff --git a/test/blackbox-tests/test-cases/ppx-rewriter/ppx/dune b/test/blackbox-tests/test-cases/ppx-rewriter/ppx/jbuild similarity index 100% rename from test/blackbox-tests/test-cases/ppx-rewriter/ppx/dune rename to test/blackbox-tests/test-cases/ppx-rewriter/ppx/jbuild diff --git a/test/blackbox-tests/test-cases/ppx-rewriter/run.t b/test/blackbox-tests/test-cases/ppx-rewriter/run.t index 96b19eecfd9..e614f032113 100644 --- a/test/blackbox-tests/test-cases/ppx-rewriter/run.t +++ b/test/blackbox-tests/test-cases/ppx-rewriter/run.t @@ -3,14 +3,14 @@ ocamlc ppx/.fooppx.objs/fooppx.{cmi,cmo,cmt} ocamlopt ppx/.fooppx.objs/fooppx.{cmx,o} ocamlopt ppx/fooppx.{a,cmxa} - ocamlopt .ppx/fooppx/ppx.exe + ocamlopt .ppx/jbuild/fooppx/ppx.exe ppx w_omp_driver.pp.ml ocamldep w_omp_driver.pp.ml.d ocamlc .w_omp_driver.eobjs/w_omp_driver.{cmi,cmo,cmt} 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/ppx.exe + ocamlopt .ppx/jbuild/ppx_driver.runner/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/private-public-overlap/private-rewriter/dune b/test/blackbox-tests/test-cases/private-public-overlap/private-rewriter/jbuild similarity index 100% rename from test/blackbox-tests/test-cases/private-public-overlap/private-rewriter/dune rename to test/blackbox-tests/test-cases/private-public-overlap/private-rewriter/jbuild diff --git a/test/blackbox-tests/test-cases/private-public-overlap/private-runtime-deps/dune b/test/blackbox-tests/test-cases/private-public-overlap/private-runtime-deps/jbuild similarity index 100% rename from test/blackbox-tests/test-cases/private-public-overlap/private-runtime-deps/dune rename to test/blackbox-tests/test-cases/private-public-overlap/private-runtime-deps/jbuild diff --git a/test/blackbox-tests/test-cases/private-public-overlap/run.t b/test/blackbox-tests/test-cases/private-public-overlap/run.t index 98605bc1c51..78dde583e3d 100644 --- a/test/blackbox-tests/test-cases/private-public-overlap/run.t +++ b/test/blackbox-tests/test-cases/private-public-overlap/run.t @@ -11,7 +11,7 @@ On the other hand, public libraries may have private preprocessors ocamlc .ppx_internal.objs/ppx_internal.{cmi,cmo,cmt} ocamlopt .ppx_internal.objs/ppx_internal.{cmx,o} ocamlopt ppx_internal.{a,cmxa} - ocamlopt .ppx/ppx_internal@mylib/ppx.exe + ocamlopt .ppx/jbuild/ppx_internal@mylib/ppx.exe ppx mylib.pp.ml ocamldep mylib.pp.ml.d ocamlc .mylib.objs/mylib.{cmi,cmo,cmt} @@ -22,13 +22,13 @@ On the other hand, public libraries may have private preprocessors Unless they introduce private runtime dependencies: $ dune build --display short --root private-runtime-deps 2>&1 | grep -v Entering - File "dune", line 16, characters 20-31: + File "jbuild", line 16, characters 20-31: Error: Library "private_runtime_dep" is private, it cannot be a dependency of a public library. You need to give "private_runtime_dep" a public name. ocamlc .private_ppx.objs/private_ppx.{cmi,cmo,cmt} ocamlopt .private_ppx.objs/private_ppx.{cmx,o} ocamlopt private_ppx.{a,cmxa} - ocamlopt .ppx/private_ppx@mylib/ppx.exe + ocamlopt .ppx/jbuild/private_ppx@mylib/ppx.exe ppx mylib.pp.ml ocamldep mylib.pp.ml.d 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/jbuild similarity index 70% rename from test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/dune rename to test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/jbuild index 33269f9aefa..5144628dbcf 100644 --- a/test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/dune +++ b/test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/jbuild @@ -3,5 +3,4 @@ (library ((name a_kernel) (public_name a.kernel) - (libraries (ocaml-migrate-parsetree)) (kind ppx_rewriter))) diff --git a/test/blackbox-tests/test-cases/scope-ppx-bug/a/ppx/dune b/test/blackbox-tests/test-cases/scope-ppx-bug/a/ppx/jbuild similarity index 100% rename from test/blackbox-tests/test-cases/scope-ppx-bug/a/ppx/dune rename to test/blackbox-tests/test-cases/scope-ppx-bug/a/ppx/jbuild diff --git a/test/blackbox-tests/test-cases/scope-ppx-bug/b/dune b/test/blackbox-tests/test-cases/scope-ppx-bug/b/jbuild similarity index 100% rename from test/blackbox-tests/test-cases/scope-ppx-bug/b/dune rename to test/blackbox-tests/test-cases/scope-ppx-bug/b/jbuild 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 7920c5d42aa..2c73d397d01 100644 --- a/test/blackbox-tests/test-cases/scope-ppx-bug/run.t +++ b/test/blackbox-tests/test-cases/scope-ppx-bug/run.t @@ -9,8 +9,8 @@ ocamlopt a/kernel/a_kernel.cmxs ocamlc a/ppx/a.cma ocamlc a/kernel/a_kernel.cma - ocamlopt .ppx/a.kernel/ppx.exe - ocamlopt .ppx/a/ppx.exe + ocamlopt .ppx/jbuild/a.kernel/ppx.exe + ocamlopt .ppx/jbuild/a/ppx.exe ppx b/b.pp.ml ocamldep b/b.pp.ml.d ocamlc b/.b.objs/b.{cmi,cmo,cmt} From 278d30083f6ce41da0f7496daea5bdf265f0b367 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Sat, 2 Jun 2018 17:55:17 +0100 Subject: [PATCH 4/8] Add a warning for with_lib_deps I just spent an hour debugging a stupid bug caused by this... Signed-off-by: Jeremie Dimino --- src/super_context.mli | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/super_context.mli b/src/super_context.mli index 68dc53326c2..9ca190de881 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -159,7 +159,13 @@ val resolve_program module Libs : sig (** Make sure all rules produces by [f] record the library dependencies for [jbuilder external-lib-deps] and depend on the - generation of the .merlin file. *) + generation of the .merlin file. + + /!\ WARNING /!\: make sure the last function call inside [f] is + fully applied, otherwise the function might end up being executed + after this function has returned. Consider addin a type + annotation to make sure this doesn't happen by mistake. + *) val with_lib_deps : t -> Lib.Compile.t From cc85a2a5a1c250b70e977f644dc2236eb492543a Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 4 Jun 2018 11:11:47 +0100 Subject: [PATCH 5/8] Improve the code for building and installing the compat ppx.exe program Signed-off-by: Jeremie Dimino --- src/install_rules.ml | 24 ++++++++++-------------- src/preprocessing.ml | 21 +++++++++++++++++++-- src/preprocessing.mli | 13 +++++++++++-- 3 files changed, 40 insertions(+), 18 deletions(-) diff --git a/src/install_rules.ml b/src/install_rules.ml index 97e5f886c75..789c2c1261e 100644 --- a/src/install_rules.ml +++ b/src/install_rules.ml @@ -186,28 +186,24 @@ module Gen(P : Install_params) = struct | Ppx_rewriter -> match (dir_kind : File_tree.Dune_file.Kind.t) with | Dune -> - [Preprocessing.get_ppx_driver_for_public_lib sctx ~name ~dir_kind] + [Preprocessing.get_compat_ppx_exe sctx ~name ~kind:Dune] | Jbuild -> - let pps = [(lib.buildable.loc, Pp.of_string lib.name)] in - let pps = + let 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 + | "ppx_driver" | "ppxlib" | "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"] + match Scope.name scope with + | Named "ppxlib" -> + Some "ppxlib.runner" + | _ -> + Some "ppx_driver.runner" else - pps + None in - match Preprocessing.get_ppx_driver sctx ~scope ~dir_kind pps with - | Ok x -> [x] - | Error _ -> - [Preprocessing.get_ppx_driver_for_public_lib sctx ~name ~dir_kind] + [Preprocessing.get_compat_ppx_exe sctx ~name ~kind:(Jbuild driver)] in List.concat [ List.map files ~f:(make_entry Lib ) diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 05bccd2d67d..36001eb046a 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -313,8 +313,25 @@ let ppx_driver_exe sctx libs ~dir_kind = in ppx_exe sctx ~key ~dir_kind -let get_ppx_driver_for_public_lib sctx ~name ~dir_kind = - ppx_exe sctx ~key:name ~dir_kind +module Compat_ppx_exe_kind = struct + type t = + | Dune + | Jbuild of string option +end + +let get_compat_ppx_exe sctx ~name ~kind = + match (kind : Compat_ppx_exe_kind.t) with + | Dune -> + ppx_exe sctx ~key:name ~dir_kind:Dune + | Jbuild driver -> + (* We know both [name] and [driver] are public libraries, so we + don't add the scope key. *) + let key = + match driver with + | None -> name + | Some d -> sprintf "%s+%s" name d + in + ppx_exe sctx ~key ~dir_kind:Jbuild let get_ppx_driver sctx ~loc ~scope ~dir_kind pps = let sctx = SC.host sctx in diff --git a/src/preprocessing.mli b/src/preprocessing.mli index 23bb44bba59..024f116af60 100644 --- a/src/preprocessing.mli +++ b/src/preprocessing.mli @@ -44,10 +44,19 @@ val get_ppx_driver -> (Loc.t * Jbuild.Pp.t) list -> Path.t Or_exn.t -val get_ppx_driver_for_public_lib +module Compat_ppx_exe_kind : sig + (** [Dune] for directories using a [dune] file, and [Jbuild driver] + for directories using a [jbuild] file. *) + type t = + | Dune + | Jbuild of string option +end + +(** Compatibility [ppx.exe] program for the findlib method. *) +val get_compat_ppx_exe : Super_context.t -> name:string - -> dir_kind:File_tree.Dune_file.Kind.t + -> kind:Compat_ppx_exe_kind.t -> Path.t (** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not From d0581b4ad62d6df28532b2c0dae9cb2eaa205c94 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 4 Jun 2018 12:18:59 +0100 Subject: [PATCH 6/8] Update gen-opam-install-file test Signed-off-by: Jeremie Dimino --- .../test-cases/gen-opam-install-file/ppx-new/dune | 1 + .../gen-opam-install-file/ppx-new/foo_ppx_rewriter_dune.ml | 1 + test/blackbox-tests/test-cases/gen-opam-install-file/run.t | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/test/blackbox-tests/test-cases/gen-opam-install-file/ppx-new/dune b/test/blackbox-tests/test-cases/gen-opam-install-file/ppx-new/dune index 36489c8e726..fa1688cc5d9 100644 --- a/test/blackbox-tests/test-cases/gen-opam-install-file/ppx-new/dune +++ b/test/blackbox-tests/test-cases/gen-opam-install-file/ppx-new/dune @@ -2,4 +2,5 @@ (library ((name foo_ppx_rewriter_dune) (public_name foo.ppx_rewriter_dune) + (ppx.driver ((main Foo_ppx_rewriter_dune.main))) (kind ppx_rewriter))) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/gen-opam-install-file/ppx-new/foo_ppx_rewriter_dune.ml b/test/blackbox-tests/test-cases/gen-opam-install-file/ppx-new/foo_ppx_rewriter_dune.ml index e69de29bb2d..d904bff5a4b 100644 --- a/test/blackbox-tests/test-cases/gen-opam-install-file/ppx-new/foo_ppx_rewriter_dune.ml +++ b/test/blackbox-tests/test-cases/gen-opam-install-file/ppx-new/foo_ppx_rewriter_dune.ml @@ -0,0 +1 @@ +let main () = () diff --git a/test/blackbox-tests/test-cases/gen-opam-install-file/run.t b/test/blackbox-tests/test-cases/gen-opam-install-file/run.t index b2633bab572..f9330280acb 100644 --- a/test/blackbox-tests/test-cases/gen-opam-install-file/run.t +++ b/test/blackbox-tests/test-cases/gen-opam-install-file/run.t @@ -27,7 +27,7 @@ ocamlc ppx-new/foo_ppx_rewriter_dune.cma ocamlopt .ppx/foo.ppx_rewriter_dune/ppx.exe ocamlc ppx-old/foo_ppx_rewriter_jbuild.cma - ocamlopt .ppx/foo.ppx_rewriter_jbuild/ppx.exe + ocamlopt .ppx/jbuild/foo.ppx_rewriter_jbuild/ppx.exe lib: [ "_build/install/default/lib/foo/META" {"META"} "_build/install/default/lib/foo/opam" {"opam"} From 16d8270aa2280a6600a5496d3cf280cb4c221c2b Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 4 Jun 2018 12:22:32 +0100 Subject: [PATCH 7/8] Add a hint for ppx rewriters that are not compatible Signed-off-by: Jeremie Dimino --- src/preprocessing.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 36001eb046a..bfa5c96f827 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -203,7 +203,9 @@ let no_driver_error pps = | None -> sprintf "No ppx driver found.\n\ - It seems that these ppx rewriters are not compatible with jbuilder." + It seems that these ppx rewriters are not compatible with Dune.\n\ + Hint: Examples of ppx rewriters that are compatible with Dune are\n\ + ones using ocaml-migrate-parsetree, ppxlib or ppx_driver." let build_ppx_driver sctx ~lib_db ~dep_kind ~target ~dir_kind pps = let ctx = SC.context sctx in From bf9b25c10e444adb94e8e7b639a9f9035db09179 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 5 Jun 2018 13:10:52 +0100 Subject: [PATCH 8/8] Refactor handling of backend selection errors + add tests Signed-off-by: Jeremie Dimino --- src/loc.ml | 3 +- src/preprocessing.ml | 87 ++++++++++++++----- src/stdune/fmt.ml | 2 + src/stdune/fmt.mli | 2 + src/stdune/string.ml | 13 +++ src/stdune/string.mli | 6 ++ src/sub_system.ml | 84 ++++++++++-------- src/sub_system_intf.ml | 21 +++-- test/blackbox-tests/dune.inc | 11 +++ .../test-cases/dune-ppx-driver-system/dune | 56 ++++++++++++ .../dune-ppx-driver-system/dune-project | 1 + .../dune-ppx-driver-system/foo.opam | 0 .../test-cases/dune-ppx-driver-system/run.t | 39 +++++++++ 13 files changed, 259 insertions(+), 66 deletions(-) create mode 100644 test/blackbox-tests/test-cases/dune-ppx-driver-system/dune create mode 100644 test/blackbox-tests/test-cases/dune-ppx-driver-system/dune-project create mode 100644 test/blackbox-tests/test-cases/dune-ppx-driver-system/foo.opam create mode 100644 test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t diff --git a/src/loc.ml b/src/loc.ml index 70122da3333..28d7a1dc1b2 100644 --- a/src/loc.ml +++ b/src/loc.ml @@ -33,8 +33,9 @@ let of_lexbuf lb = } let exnf t fmt = + Format.pp_open_box err_ppf 0; Format.pp_print_as err_ppf 7 ""; (* "Error: " *) - kerrf fmt ~f:(fun s -> Exn.Loc_error (t, s)) + kerrf (fmt^^ "@]") ~f:(fun s -> Exn.Loc_error (t, s)) let fail t fmt = Format.pp_print_as err_ppf 7 ""; (* "Error: " *) diff --git a/src/preprocessing.ml b/src/preprocessing.ml index bfa5c96f827..0da90c4d199 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -114,6 +114,68 @@ module Driver = struct end include M include Sub_system.Register_backend(M) + + (* Where are we called from? *) + type loc = + | User_file of Loc.t * (Loc.t * Pp.t) list + | Dot_ppx of Path.t * Pp.t list + + let make_error loc msg = + match loc with + | User_file (loc, _) -> Error (Loc.exnf loc "%a" Fmt.text msg) + | Dot_ppx (path, pps) -> + Error (Loc.exnf (Loc.in_file (Path.to_string path)) "%a" Fmt.text + (sprintf + "Failed to create on-demand ppx rewriter for %s; %s" + (String.enumerate_and (List.map pps ~f:Pp.to_string)) + (String.uncapitalize msg))) + + let select libs ~loc = + match select_replaceable_backend libs ~replaces with + | Ok _ as x -> x + | Error No_backend_found -> + let msg = + match libs with + | [] -> + "You must specify at least one ppx rewriter." + | _ -> + match + List.filter_map libs ~f:(fun lib -> + match Lib.name lib with + | "ocaml-migrate-parsetree" | "ppxlib" | "ppx_driver" as s -> + Some s + | _ -> None) + with + | [] -> + let pps = + match loc with + | User_file (_, pps) -> List.map pps ~f:snd + | Dot_ppx (_, pps) -> pps + in + sprintf + "No ppx driver were found. It seems that %s %s not \ + compatible with Dune. Examples of ppx rewriters that \ + are compatible with Dune are ones using \ + ocaml-migrate-parsetree, ppxlib or ppx_driver." + (String.enumerate_and (List.map pps ~f:Pp.to_string)) + (match pps with + | [_] -> "is" + | _ -> "are") + | names -> + sprintf + "No ppx driver were found.\n\ + Hint: Try upgrading or reinstalling %s." + (String.enumerate_and names) + in + make_error loc msg + | Error (Too_many_backends ts) -> + make_error loc + (sprintf + "Too many incompatible ppx drivers were found: %s." + (String.enumerate_and (List.map ts ~f:(fun t -> + Lib.name (lib t))))) + | Error (Other exn) -> + Error exn end module Jbuild_driver = struct @@ -189,24 +251,6 @@ let ppx_exe sctx ~key ~dir_kind = | Jbuild -> Path.relative (SC.build_dir sctx) (".ppx/jbuild/" ^ 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 Dune.\n\ - Hint: Examples of ppx rewriters that are compatible with Dune are\n\ - ones using ocaml-migrate-parsetree, ppxlib or ppx_driver." - let build_ppx_driver sctx ~lib_db ~dep_kind ~target ~dir_kind pps = let ctx = SC.context sctx in let mode = Context.best_mode ctx in @@ -231,9 +275,7 @@ let build_ppx_driver sctx ~lib_db ~dep_kind ~target ~dir_kind pps = >>= fun resolved_pps -> match jbuild_driver with | None -> - Driver.select_replaceable_backend resolved_pps ~loc:Loc.none - ~replaces:Driver.replaces - ~no_backend_error:no_driver_error + Driver.select resolved_pps ~loc:(Dot_ppx (target, pps)) >>| fun driver -> (driver, resolved_pps) | Some driver -> @@ -344,8 +386,7 @@ let get_ppx_driver sctx ~loc ~scope ~dir_kind pps = >>= fun libs -> Lib.closure libs >>= - Driver.select_replaceable_backend ~loc ~replaces:Driver.replaces - ~no_backend_error:no_driver_error + Driver.select ~loc:(User_file (loc, pps)) >>= fun driver -> Ok (ppx_driver_exe sctx libs ~dir_kind, driver) | Jbuild -> diff --git a/src/stdune/fmt.ml b/src/stdune/fmt.ml index a0d2609036e..eebd3ed8791 100644 --- a/src/stdune/fmt.ml +++ b/src/stdune/fmt.ml @@ -23,6 +23,8 @@ let failwith fmt = kstrf failwith fmt let list = Format.pp_print_list let string s ppf = Format.pp_print_string ppf s +let text = Format.pp_print_text + let nl = Format.pp_print_newline let prefix f g ppf x = f ppf; g ppf x diff --git a/src/stdune/fmt.mli b/src/stdune/fmt.mli index 8681035ed21..eaa53cc75ff 100644 --- a/src/stdune/fmt.mli +++ b/src/stdune/fmt.mli @@ -6,6 +6,8 @@ val failwith : ('a, Format.formatter, unit, 'b) format4 -> 'a val string : string -> Format.formatter -> unit +val text : string t + val prefix : (Format.formatter -> unit) -> (Format.formatter -> 'b -> 'c) diff --git a/src/stdune/string.ml b/src/stdune/string.ml index 3e5920b5783..16a3c9f11bc 100644 --- a/src/stdune/string.ml +++ b/src/stdune/string.ml @@ -201,3 +201,16 @@ let maybe_quoted s = module Set = Set.Make(T) module Map = Map.Make(T) + +let enumerate_gen s = + let s = " " ^ s ^ " " in + let rec loop = function + | [] -> [] + | [x] -> [x] + | [x; y] -> [x; s; y] + | x :: l -> x :: ", " :: loop l + in + fun l -> concat (loop l) ~sep:"" + +let enumerate_and = enumerate_gen "and" +let enumerate_or = enumerate_gen "or" diff --git a/src/stdune/string.mli b/src/stdune/string.mli index 1e2059d715c..a2c9d9820d7 100644 --- a/src/stdune/string.mli +++ b/src/stdune/string.mli @@ -45,5 +45,11 @@ val for_all : t -> f:(char -> bool) -> bool lexing conventions and [sprintf "%S" s] otherwise. *) val maybe_quoted : t -> t +(** Produces: "x, y and z" *) +val enumerate_and : string list -> string + +(** Produces: "x, y or z" *) +val enumerate_or : string list -> string + module Set : Set.S with type elt = t module Map : Map.S with type key = t diff --git a/src/sub_system.ml b/src/sub_system.ml index 2d1d214fd54..554791d23c2 100644 --- a/src/sub_system.ml +++ b/src/sub_system.ml @@ -43,39 +43,54 @@ 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 ~no_backend_error = + module Selection_error = struct + type t = + | Too_many_backends of M.t list + | No_backend_found + | Other of exn + + let to_exn t ~loc = + match t with + | Too_many_backends backends -> + Loc.exnf loc + "Too many independant %s found:\n%s" + (M.desc ~plural:true) + (String.concat ~sep:"\n" + (List.map backends ~f:(fun t -> + let lib = M.lib t in + sprintf "- %S in %s" + (Lib.name lib) + (Path.to_string_maybe_quoted (Lib.src_dir lib))))) + | No_backend_found -> + Loc.exnf loc "No %s found." (M.desc ~plural:false) + | Other exn -> + exn + + let or_exn res ~loc = + match res with + | Ok _ as x -> x + | Error t -> Error (to_exn t ~loc) + + let wrap = function + | Ok _ as x -> x + | Error exn -> Error (Other exn) + end + open Selection_error + + let written_by_user_or_scan ~written_by_user ~to_scan = match match written_by_user with | Some l -> l | None -> List.filter_map to_scan ~f:get with - | [] -> 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 + | [] -> Error No_backend_found | l -> Ok l - let too_many_backends ~loc backends = - Loc.exnf loc - "Too many independant %s found:\n%s" - (M.desc ~plural:true) - (String.concat ~sep:"\n" - (List.map backends ~f:(fun t -> - let lib = M.lib t in - sprintf "- %S in %s" - (Lib.name lib) - (Path.to_string_maybe_quoted (Lib.src_dir lib))))) - - let select_extensible_backends ~loc ?written_by_user ~extends to_scan = + let select_extensible_backends ?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 + written_by_user_or_scan ~written_by_user ~to_scan >>= fun backends -> - top_closure backends ~deps:extends + wrap (top_closure backends ~deps:extends) >>= fun backends -> let roots = let all = Set.of_list backends in @@ -86,21 +101,20 @@ module Register_backend(M : Backend) = struct if List.length roots = 1 then Ok backends else - Error (too_many_backends ~loc roots) + Error (Too_many_backends roots) - let select_replaceable_backend ~loc ?written_by_user ~replaces - ?no_backend_error to_scan = + let select_replaceable_backend ?written_by_user ~replaces to_scan = let open Result.O in - written_by_user_or_scan ~loc ~written_by_user ~to_scan ~no_backend_error + written_by_user_or_scan ~written_by_user ~to_scan >>= fun backends -> - Result.concat_map backends ~f:replaces + wrap (Result.concat_map backends ~f:replaces) >>= fun replaced_backends -> match Set.diff (Set.of_list backends) (Set.of_list replaced_backends) |> Set.to_list with | [b] -> Ok b - | l -> Error (too_many_backends ~loc l) + | l -> Error (Too_many_backends l) end type Lib.Sub_system.t += @@ -120,11 +134,11 @@ module Register_end_point(M : End_point) = struct Result.all (List.map l ~f:(M.Backend.resolve (Scope.libs c.scope))) >>| Option.some) >>= fun written_by_user -> - M.Backend.select_extensible_backends - ~loc:(M.Info.loc info) - ?written_by_user - ~extends:M.Backend.extends - (deps @ pps) + M.Backend.Selection_error.or_exn ~loc:(M.Info.loc info) + (M.Backend.select_extensible_backends + ?written_by_user + ~extends:M.Backend.extends + (deps @ pps)) in let fail, backends = match backends with diff --git a/src/sub_system_intf.ml b/src/sub_system_intf.ml index 0a4159ad780..a482a80a546 100644 --- a/src/sub_system_intf.ml +++ b/src/sub_system_intf.ml @@ -45,6 +45,16 @@ module type Registered_backend = sig (** Resolve a backend name *) val resolve : Lib.DB.t -> Loc.t * string -> t Or_exn.t + module Selection_error : sig + type nonrec t = + | Too_many_backends of t list + | No_backend_found + | Other of exn + + val to_exn : t -> loc:Loc.t -> exn + val or_exn : ('a, t) result -> loc:Loc.t -> 'a Or_exn.t + end + (** Choose a backend by either using the ones written by the user or by scanning the dependencies. @@ -53,23 +63,20 @@ module type Registered_backend = sig independant, i.e. none of them is in the transitive closure of the other one. *) val select_extensible_backends - : loc:Loc.t - -> ?written_by_user:t list + : ?written_by_user:t list -> extends:(t -> t list Or_exn.t) -> Lib.t list - -> t list Or_exn.t + -> (t list, Selection_error.t) result (** Choose a backend by either using the ones written by the user or by scanning the dependencies. A backend can replace other backends *) val select_replaceable_backend - : loc:Loc.t - -> ?written_by_user:t list + : ?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 + -> (t, Selection_error.t) result end (* This is probably what we'll give to plugins *) diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index 89e6c0d8740..0af19fcf64c 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -81,6 +81,15 @@ test-cases/depend-on-the-universe (progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))) +(alias + ((name dune-ppx-driver-system) + (deps + ((package dune) (files_recursively_in test-cases/dune-ppx-driver-system))) + (action + (chdir + test-cases/dune-ppx-driver-system + (progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))) + (alias ((name env) (deps ((package dune) (files_recursively_in test-cases/env))) @@ -537,6 +546,7 @@ (alias cross-compilation) (alias custom-build-dir) (alias depend-on-the-universe) + (alias dune-ppx-driver-system) (alias env) (alias exclude-missing-module) (alias exec-cmd) @@ -600,6 +610,7 @@ (alias cross-compilation) (alias custom-build-dir) (alias depend-on-the-universe) + (alias dune-ppx-driver-system) (alias env) (alias exclude-missing-module) (alias exec-cmd) diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune b/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune new file mode 100644 index 00000000000..b38b91fb322 --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune @@ -0,0 +1,56 @@ +; No driver found +(library + ((name foo1) + (public_name foo.1) + (modules (foo1)) + (preprocess (pps ())))) + +; Too many drivers +(library + ((name foo2) + (public_name foo.2) + (modules (foo2)) + (preprocess (pps (ppx1 ppx2))))) + +; Incompatible with Dune +(library + ((name foo3) + (public_name foo.3) + (modules (foo3)) + (preprocess (pps (ppx_other))))) + +(rule (with-stdout-to foo1.ml (echo ""))) +(rule (with-stdout-to foo2.ml (echo ""))) +(rule (with-stdout-to foo3.ml (echo ""))) + +(library + ((name ppx1) + (public_name foo.ppx1) + (kind ppx_rewriter) + (modules ()) + (libraries (driver1)))) + +(library + ((name ppx2) + (public_name foo.ppx2) + (kind ppx_rewriter) + (modules ()) + (libraries (driver2)))) + +(library + ((name driver1) + (public_name foo.driver1) + (modules ()) + (ppx.driver ((main "(fun () -> assert false)"))))) + +(library + ((name driver2) + (public_name foo.driver2) + (modules ()) + (ppx.driver ((main "(fun () -> assert false)"))))) + +(library + ((name ppx_other) + (public_name foo.ppx-other) + (modules ()) + (kind ppx_rewriter))) diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune-project b/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune-project new file mode 100644 index 00000000000..b278e95bd74 --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/dune-project @@ -0,0 +1 @@ +(lang dune 0.1) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/foo.opam b/test/blackbox-tests/test-cases/dune-ppx-driver-system/foo.opam new file mode 100644 index 00000000000..e69de29bb2d diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t b/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t new file mode 100644 index 00000000000..dc7881e2b52 --- /dev/null +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t @@ -0,0 +1,39 @@ +No ppx driver found + + $ dune build foo1.cma + File "dune", line 6, characters 14-22: + Error: You must specify at least one ppx rewriter. + [1] + +Too many drivers + + $ dune build foo2.cma + File "dune", line 13, characters 14-31: + Error: Too many incompatible ppx drivers were found: foo.driver2 and + foo.driver1. + [1] + +Not compatible with Dune + + $ dune build foo3.cma + File "dune", line 20, characters 14-31: + Error: No ppx driver were found. It seems that ppx_other is not compatible + with Dune. Examples of ppx rewriters that are compatible with Dune are ones + using ocaml-migrate-parsetree, ppxlib or ppx_driver. + [1] + +Same, but with error pointing to .ppx + + $ dune build .ppx/foo.ppx1+foo.ppx2/ppx.exe + File "_build/default/.ppx/foo.ppx1+foo.ppx2/ppx.exe", line 1, characters 0-0: + Error: Failed to create on-demand ppx rewriter for foo.ppx1 and foo.ppx2; too + many incompatible ppx drivers were found: foo.driver2 and foo.driver1. + [1] + + $ dune build .ppx/foo.ppx-other/ppx.exe + File "_build/default/.ppx/foo.ppx-other/ppx.exe", line 1, characters 0-0: + Error: Failed to create on-demand ppx rewriter for foo.ppx-other; no ppx + driver were found. It seems that foo.ppx-other is not compatible with Dune. + Examples of ppx rewriters that are compatible with Dune are ones using + ocaml-migrate-parsetree, ppxlib or ppx_driver. + [1]