Format preprocessed files before promotion

Signed-off-by: Nathan Rebours <[email protected]>

.ocamlformat-ignore

@@ -1,4 +1,3 @@
 boot/libs.ml
 src/dune_rules/assets.ml
 src/dune_rules/setup.defaults.ml
-ppx/**

src/dune_rules/format_rules.ml

@@ -68,6 +68,36 @@ module Alias = struct
   let fmt ~dir = Alias.make Alias0.fmt ~dir
 end
 
+let format_action ~expander ~dialects ~config ~dir ~ext ~input ~output =
+  let open Option.O in
+  let* dialect, kind = Dialect.DB.find_by_extension dialects ext in
+  let* () =
+    Option.some_if (Format_config.includes config (Dialect (Dialect.name dialect))) ()
+  in
+  let+ loc, action, extra_deps =
+    match Dialect.format dialect kind with
+    | Some _ as action -> action
+    | None ->
+      (match Dialect.preprocess dialect kind with
+       | None -> Dialect.format Dialect.ocaml kind
+       | Some _ -> None)
+  in
+  let extra_deps =
+    match extra_deps with
+    | [] -> Action_builder.return ()
+    | extra_deps -> depend_on_files ~named:extra_deps (Path.build dir)
+  in
+  let open Action_builder.With_targets.O in
+  Action_builder.with_no_targets extra_deps
+  >>> Preprocessing.action_for_pp_with_target
+        ~sandbox:Sandbox_config.default
+        ~loc
+        ~expander
+        ~action
+        ~src:input
+        ~target:output
+;;
+
 let gen_rules_output
   sctx
   (config : Format_config.t)
@@ -85,36 +115,11 @@ let gen_rules_output
     let input_basename = Path.Source.basename file in
     let input = Path.Build.relative dir input_basename in
     let output = Path.Build.relative output_dir input_basename in
-    (let open Option.O in
-     let* dialect, kind =
-       Path.Source.extension file |> Dialect.DB.find_by_extension dialects
-     in
-     let* () =
-       Option.some_if (Format_config.includes config (Dialect (Dialect.name dialect))) ()
-     in
-     let+ loc, action, extra_deps =
-       match Dialect.format dialect kind with
-       | Some _ as action -> action
-       | None ->
-         (match Dialect.preprocess dialect kind with
-          | None -> Dialect.format Dialect.ocaml kind
-          | Some _ -> None)
-     in
-     let extra_deps =
-       match extra_deps with
-       | [] -> Action_builder.return ()
-       | extra_deps -> depend_on_files ~named:extra_deps (Path.build dir)
-     in
-     let open Action_builder.With_targets.O in
-     Action_builder.with_no_targets extra_deps
-     >>> Preprocessing.action_for_pp_with_target
-           ~sandbox:Sandbox_config.default
-           ~loc
-           ~expander
-           ~action
-           ~src:input
-           ~target:output)
-    |> Memo.Option.iter ~f:(fun action ->
+    let formatter =
+      let ext = Path.Source.extension file in
+      format_action ~expander ~config ~dir ~ext ~input ~output ~dialects
+    in
+    Memo.Option.iter formatter ~f:(fun action ->
       Super_context.add_rule sctx ~mode:Standard ~loc ~dir action
       >>> add_diff sctx loc alias_formatted ~dir ~input:(Path.build input) ~output)
   in

src/dune_rules/format_rules.mli

@@ -12,3 +12,15 @@ val gen_rules : Super_context.t -> output_dir:Path.Build.t -> unit Memo.t
 val setup_alias : dir:Path.Build.t -> unit Memo.t
 
 val formatted_dir_basename : Filename.t
+
+val format_action
+  :  expander:Expander.t
+  -> dialects:Dialect.DB.t
+  -> config:Format_config.t
+  -> dir:Path.Build.t
+  -> ext:string
+  -> input:Path.Build.t
+  -> output:Path.Build.t
+  -> Action.Full.t Action_builder.With_targets.t option
+
+val with_config : dir:Path.Build.t -> (Format_config.t -> unit Memo.t) -> unit Memo.t

src/dune_rules/include_preprocessed_sources.ml

@@ -5,6 +5,7 @@ module Lib_or_exes_to_pp = struct
   type t =
     { ppx_driver_and_flags : (Path.Build.t * string list) Action_builder.t
     ; sources : Module.t list
+    ; source_dir : Path.Build.t
     }
 
   let ppx_driver ~sctx ~scope ~expander lib =
@@ -43,12 +44,12 @@ module Lib_or_exes_to_pp = struct
     | Some ms -> modules_to_pp ms
   ;;
 
-  let from_lib ~sctx ~scope ~expander lib =
+  let from_lib ~sctx ~scope ~expander ~dir lib =
     let* ppx_driver_and_flags = ppx_driver ~sctx ~scope ~expander lib in
     match ppx_driver_and_flags with
     | Some ppx_driver_and_flags ->
       let+ sources = sources ~sctx lib in
-      Some { ppx_driver_and_flags; sources }
+      Some { ppx_driver_and_flags; sources; source_dir = dir }
     | None -> Memo.return None
   ;;
 
@@ -85,7 +86,7 @@ module Lib_or_exes_to_pp = struct
           ctx
           pps
       in
-      Memo.return (Some { sources; ppx_driver_and_flags })
+      Memo.return (Some { sources; ppx_driver_and_flags; source_dir = dir })
   ;;
 end
 
@@ -147,7 +148,7 @@ let libs_or_exes_to_pp_in_source_tree ~sctx ~scope ~expander ~dirs_to_exclude =
                  if Path.is_descendant ~of_:(Path.build dir) src_dir
                  then
                    let+ src_to_pp =
-                     Lib_or_exes_to_pp.from_lib ~sctx ~scope ~expander lib
+                     Lib_or_exes_to_pp.from_lib ~sctx ~scope ~expander ~dir lib
                    in
                    append_opt src_to_pp acc
                  else Memo.return acc)
@@ -161,56 +162,104 @@ let libs_or_exes_to_pp_in_source_tree ~sctx ~scope ~expander ~dirs_to_exclude =
   Appendable_list.to_list srcs_to_pp
 ;;
 
-let gen_rule_for_source_file ~sctx ~dir ~ppx_driver_and_flags ~ml_kind path =
-  let target = Path.Build.append_source dir (Path.drop_build_context_exn path) in
-  (*let target = Path.Build.relative dir (Path.basename path) in*)
+type pp_ctx =
+  { sctx : Super_context.t
+  ; expander : Expander.t
+  ; dialects : Dialect.DB.t
+  ; stanza_dir : Path.Build.t
+  ; source_dir : Path.Build.t
+  ; format_config : Format_config.t
+  ; ppx_driver_and_flags : (Path.Build.t * string list) Action_builder.t
+  }
+
+let gen_pp_rule ~pp_ctx ~ml_kind ~target ~input =
   let rule =
     Action_builder.with_file_targets
       ~file_targets:[ target ]
       (let open Action_builder.O in
-       let* ppx_driver, flags = ppx_driver_and_flags in
+       let* ppx_driver, flags = pp_ctx.ppx_driver_and_flags in
        Command.run'
-         ~dir:(Path.build dir)
+         ~dir:(Path.build pp_ctx.stanza_dir)
          (Ok (Path.build ppx_driver))
          [ As flags
          ; Command.Ml_kind.ppx_driver_flag ml_kind
-         ; Dep path
+         ; Dep input
          ; A "-o"
          ; Path (Path.build target)
          ])
   in
+  Super_context.add_rule pp_ctx.sctx ~mode:Standard ~dir:pp_ctx.stanza_dir rule
+;;
+
+let gen_format_rule ~pp_ctx ~output ~ext ~input =
+  let fmt_action =
+    Format_rules.format_action
+      ~expander:pp_ctx.expander
+      ~dialects:pp_ctx.dialects
+      ~config:pp_ctx.format_config
+      ~ext
+      ~input
+      ~dir:pp_ctx.source_dir
+      ~output
+  in
   let mode = Rule.Mode.Promote { lifetime = Unlimited; into = None; only = None } in
-  Super_context.add_rule sctx ~mode ~dir rule
+  Memo.Option.iter fmt_action ~f:(fun action ->
+    Super_context.add_rule pp_ctx.sctx ~mode ~dir:pp_ctx.stanza_dir action)
 ;;
 
-let gen_rules_for_module ~sctx ~dir ~ppx_driver_and_flags module_ =
+let gen_rules_for_source_file ~pp_ctx ~ml_kind path =
+  let target =
+    Path.Build.append_source pp_ctx.stanza_dir (Path.drop_build_context_exn path)
+  in
+  let raw_pp_target = Path.Build.map_extension target ~f:(fun ext -> ".pp" ^ ext) in
+  let* () = gen_pp_rule ~pp_ctx ~ml_kind ~target:raw_pp_target ~input:path in
+  let ext = Path.extension path in
+  gen_format_rule ~pp_ctx ~output:target ~ext ~input:raw_pp_target
+;;
+
+let gen_rules_for_module ~pp_ctx module_ =
   let impl = Module.file ~ml_kind:Impl module_ in
   let intf = Module.file ~ml_kind:Intf module_ in
   let* () =
     match impl with
     | None -> Memo.return ()
-    | Some path ->
-      gen_rule_for_source_file ~sctx ~dir ~ppx_driver_and_flags ~ml_kind:Impl path
+    | Some path -> gen_rules_for_source_file ~pp_ctx ~ml_kind:Impl path
   in
   match intf with
   | None -> Memo.return ()
-  | Some path ->
-    gen_rule_for_source_file ~sctx ~dir ~ppx_driver_and_flags ~ml_kind:Intf path
+  | Some path -> gen_rules_for_source_file ~pp_ctx ~ml_kind:Intf path
 ;;
 
-let gen_rules_for_lib_or_exes ~sctx ~dir lib_or_exes_to_pp =
-  let { Lib_or_exes_to_pp.sources; ppx_driver_and_flags } = lib_or_exes_to_pp in
-  Memo.List.iter sources ~f:(gen_rules_for_module ~sctx ~dir ~ppx_driver_and_flags)
+let gen_rules_for_lib_or_exes ~sctx ~expander ~dir ~dialects lib_or_exes_to_pp =
+  let { Lib_or_exes_to_pp.sources; ppx_driver_and_flags; source_dir } =
+    lib_or_exes_to_pp
+  in
+  Format_rules.with_config ~dir:source_dir (fun format_config ->
+    let pp_ctx =
+      { sctx
+      ; expander
+      ; dialects
+      ; stanza_dir = dir
+      ; ppx_driver_and_flags
+      ; source_dir
+      ; format_config
+      }
+    in
+    Memo.List.iter sources ~f:(gen_rules_for_module ~pp_ctx))
 ;;
 
 let gen_stanza_rules ~dir ~dirs_to_exclude sctx =
   let* scope = Scope.DB.find_by_dir dir in
   let* expander = Super_context.expander sctx ~dir in
+  let project = Scope.project scope in
+  let dialects = Dune_project.dialects project in
   let dirs_to_exclude = List.map dirs_to_exclude ~f:Path.drop_build_context_exn in
   let* libs_or_exes_to_pp =
     libs_or_exes_to_pp_in_source_tree ~sctx ~scope ~expander ~dirs_to_exclude
   in
-  Memo.List.iter libs_or_exes_to_pp ~f:(gen_rules_for_lib_or_exes ~sctx ~dir)
+  Memo.List.iter
+    libs_or_exes_to_pp
+    ~f:(gen_rules_for_lib_or_exes ~expander ~dialects ~sctx ~dir)
 ;;
 
 type t = { dirs_to_exclude : String_with_vars.t list }