diff --git a/src/gen_rules.ml b/src/gen_rules.ml index e3623c20..51a7d504 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -555,8 +555,8 @@ module Gen(P : Install_rules.Params) = struct in (* Preprocess before adding the alias module as it doesn't need preprocessing *) - let modules = - Preprocessing.pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~scope + let pp = + Preprocessing.make sctx ~dir ~dep_kind ~scope ~preprocess:lib.buildable.preprocess ~preprocessor_deps: (SC.Deps.interpret sctx ~scope ~dir @@ -564,6 +564,7 @@ module Gen(P : Install_rules.Params) = struct ~lint:lib.buildable.lint ~lib_name:(Some lib.name) in + let modules = Preprocessing.pp_modules pp modules in let modules = match alias_module with @@ -817,12 +818,15 @@ module Gen(P : Install_rules.Params) = struct SC.Deps.interpret sctx exes.buildable.preprocessor_deps ~scope ~dir in - Preprocessing.pp_and_lint_modules sctx ~dir ~dep_kind:Required ~modules - ~scope - ~preprocess:exes.buildable.preprocess - ~preprocessor_deps - ~lint:exes.buildable.lint - ~lib_name:None + let pp = + Preprocessing.make sctx ~dir ~dep_kind:Required + ~scope + ~preprocess:exes.buildable.preprocess + ~preprocessor_deps + ~lint:exes.buildable.lint + ~lib_name:None + in + Preprocessing.pp_modules pp modules in let programs = diff --git a/src/preprocessing.ml b/src/preprocessing.ml index a933cc93..d2a681f4 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -293,9 +293,9 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope = Staged.stage ( fun ~(source : Module.t) ~ast -> Per_module.get lint source.name ~source ~ast) -(* Generate rules to build the .pp files and return a new module map - where all filenames point to the .pp files *) -let pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~lint ~preprocess +type t = (Module.t -> Module.t) Per_module.t + +let make sctx ~dir ~dep_kind ~lint ~preprocess ~preprocessor_deps ~lib_name ~scope = let preprocessor_deps = Build.memoize "preprocessor deps" preprocessor_deps @@ -303,62 +303,62 @@ let pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~lint ~preprocess let lint_module = Staged.unstage (lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope) in - let preprocess = - Per_module.map preprocess ~f:(function - | Preprocess.No_preprocessing -> - (fun m -> - let ast = setup_reason_rules sctx ~dir m in - lint_module ~ast ~source:m; - ast) - | Action (loc, action) -> - (fun m -> - let ast = - pped_module m ~dir ~f:(fun _kind src dst -> - SC.add_rule sctx - (preprocessor_deps - >>> - Build.path src - >>^ (fun _ -> [src]) - >>> - SC.Action.run sctx - (Redirect - (Stdout, - target_var, - Chdir (root_var, - action))) - ~loc - ~dir - ~dep_kind - ~targets:(Static [dst]) - ~scope)) - |> setup_reason_rules sctx ~dir in - 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 - 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 - (fun m -> - let ast = setup_reason_rules sctx ~dir m in - lint_module ~ast ~source:m; - pped_module ast ~dir ~f:(fun kind src dst -> + Per_module.map preprocess ~f:(function + | Preprocess.No_preprocessing -> + (fun m -> + let ast = setup_reason_rules sctx ~dir m in + lint_module ~ast ~source:m; + ast) + | Action (loc, action) -> + (fun m -> + let ast = + pped_module m ~dir ~f:(fun _kind src dst -> SC.add_rule sctx - (promote_correction ~uses_ppx_driver - (Option.value_exn (Module.file m ~dir kind)) - (preprocessor_deps - >>> - Build.run ~context:(SC.context sctx) - (Ok ppx_exe) - [ args - ; A "-o"; Target dst - ; Ml_kind.ppx_driver_flag kind; Dep src - ]))))) - in - Module.Name.Map.map modules ~f:(fun (m : Module.t) -> - Per_module.get preprocess m.name m) + (preprocessor_deps + >>> + Build.path src + >>^ (fun _ -> [src]) + >>> + SC.Action.run sctx + (Redirect + (Stdout, + target_var, + Chdir (root_var, + action))) + ~loc + ~dir + ~dep_kind + ~targets:(Static [dst]) + ~scope)) + |> setup_reason_rules sctx ~dir in + 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 + 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 + (fun m -> + let ast = setup_reason_rules sctx ~dir m in + lint_module ~ast ~source:m; + pped_module ast ~dir ~f:(fun kind src dst -> + SC.add_rule sctx + (promote_correction ~uses_ppx_driver + (Option.value_exn (Module.file m ~dir kind)) + (preprocessor_deps + >>> + Build.run ~context:(SC.context sctx) + (Ok ppx_exe) + [ args + ; A "-o"; Target dst + ; Ml_kind.ppx_driver_flag kind; Dep src + ]))))) + +let pp_modules t modules = + Module.Name.Map.map modules ~f:(fun (m : Module.t) -> + Per_module.get t m.name m) diff --git a/src/preprocessing.mli b/src/preprocessing.mli index a323b19a..844e2288 100644 --- a/src/preprocessing.mli +++ b/src/preprocessing.mli @@ -2,19 +2,26 @@ open! Import -(** Setup pre-processing and linting rules and return the list of - pre-processed modules *) -val pp_and_lint_modules +(** Preprocessing object *) +type t + +val make : Super_context.t -> dir:Path.t -> dep_kind:Build.lib_dep_kind - -> modules:Module.t Module.Name.Map.t -> lint:Jbuild.Preprocess_map.t -> preprocess:Jbuild.Preprocess_map.t -> preprocessor_deps:(unit, Path.t list) Build.t -> lib_name:string option -> scope:Scope.t - -> Module.t Module.Name.Map.t + -> t + +(** Setup the preprocessing rules for the following modules and + returns the translated modules *) +val pp_modules + : t + -> Module.t Module.Name.Map.t + -> Module.t Module.Name.Map.t (** Get a path to a cached ppx driver *) val get_ppx_driver