diff --git a/CHANGES.md b/CHANGES.md index 808e8793..231139f0 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 fcedfdf7..f87556a7 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 9e881888..460938a0 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 - type t = - | Plain of Plain.t - | Ocaml_script of Path.t + module Contents = struct + type t = + | Plain of Plain.t + | Ocaml_script of Path.t + end - let path = function - | Plain x -> x.path + type t = + { contents : Contents.t + ; kind : Kind.t + } + + 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 192e048f..c95f2f90 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 39883984..3ffd5868 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -532,7 +532,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 @@ -549,6 +549,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 @@ -779,7 +780,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 @@ -787,13 +789,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 @@ -812,6 +815,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 -> @@ -896,7 +900,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 @@ -907,7 +912,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 | @@ -950,7 +955,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 @@ -960,10 +965,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 @@ -979,7 +985,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 @@ -1078,17 +1084,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 167d3dea..97e5f886 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 09947c98..d5c3b264 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 b7e26206..9f13896f 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 9a6be250..5dc286d0 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 01f27ee2..9aa03dcd 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 943bb210..c45457a0 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 ec4236e8..bdab7c64 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -61,21 +61,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 @@ -91,7 +96,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 @@ -106,8 +111,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 = @@ -125,10 +200,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 -> @@ -140,11 +222,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. *) @@ -170,26 +256,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 @@ -217,22 +306,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" @@ -272,85 +368,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 -> @@ -391,7 +490,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" @@ -433,9 +532,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 74ece24b..23bb44bb 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 deb6ff96..b9978d1a 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 a762c960..68dc5332 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 8bdb70fd..d64d64c1 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 96b19eec..e614f032 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 98605bc1..78dde583 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 33269f9a..5144628d 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 7920c5d4..2c73d397 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}