move legacy fallback rules fixup into a separate function

Signed-off-by: Arseniy Alekseyev <aalekseyev@janestreet.com>
ocaml · Apr 23, 2019 · 7d5f47a · 7d5f47a
1 parent aaaaff4
commit 7d5f47a
Showing 1 changed file with 64 additions and 61 deletions.
diff --git a/src/build_system.ml b/src/build_system.ml
@@ -749,6 +749,69 @@ let handle_add_rule_effects f =
     List.iter (Appendable_list.to_list l) ~f:(Thunk_with_backtrace.run));
   res
 
+let fix_up_legacy_fallback_rules t ~file_tree_dir ~dir rules =
+  (* Fix up non promote/fallback rules that have targets in the
+     source tree if we are in a dune < 1.10 project *)
+  match file_tree_dir with
+  | None -> rules
+  | Some ftdir ->
+    let dune_version =
+      Dune_project.dune_version (File_tree.Dir.project ftdir)
+    in
+    if Wp.t = Dune && dune_version >= (1, 10) then
+      rules
+    else begin
+      let source_files =
+        File_tree.Dir.files ftdir
+        |> Path.Set.of_string_set ~f:(Path.relative dir)
+      in
+      List.map rules ~f:(fun (rule : Pre_rule.t) ->
+        match rule.mode with
+        | Promote _ | Fallback | Ignore_source_files -> rule
+        | Standard ->
+          let inter = Path.Set.inter rule.targets source_files in
+          if Path.Set.is_empty inter then
+            rule
+          else begin
+            let mode, behavior =
+              if Path.Set.equal inter rule.targets then
+                (Dune_file.Rule.Mode.Fallback,
+                 "acting as if the rule didn't exist")
+              else
+                (Dune_file.Rule.Mode.Promote
+                   { lifetime = Unlimited
+                   ; into = None
+                   ; only =
+                       Some
+                         (Predicate_lang.of_pred
+                            (fun s ->
+                               Path.Set.mem inter (Path.relative dir s)))
+                   },
+                 "overwriting the source files with the generated one")
+            in
+            Errors.warn
+              (rule_loc ~info:rule.info ~dir ~file_tree:t.file_tree)
+              "The following files are both generated by a rule and are \
+               present in\nthe source tree:@\n@[<v>%a@,@[%a@]@]"
+              (Fmt.list (Fmt.prefix (Fmt.string "- ") Path.pp))
+              (Path.Set.to_list inter
+               |> List.map ~f:Path.drop_optional_build_context)
+              Fmt.text
+              (sprintf "Because %s, I am closing my eyes on this and \
+                        I am %s. However, you should really delete \
+                        these files from your source tree. I will no \
+                        longer accept this once you upgrade your \
+                        project to dune >= 1.10."
+                 (match Wp.t with
+                  | Jbuilder -> "you are using the jbuilder binary"
+                  | Dune ->
+                    "your project was written for dune " ^
+                    Syntax.Version.to_string dune_version)
+                 behavior);
+            { rule with mode }
+          end)
+    end
+
 let rec compile_rule t pre_rule =
   let { Pre_rule.
         context
@@ -937,67 +1000,7 @@ and load_dir_step2_exn t ~dir ~collector =
   in
 
   let rules =
-    (* Fix up non promote/fallback rules that have targets in the
-       source tree if we are in a dune < 1.10 project *)
-    match file_tree_dir with
-    | None -> rules
-    | Some ftdir ->
-      let dune_version =
-        Dune_project.dune_version (File_tree.Dir.project ftdir)
-      in
-      if Wp.t = Dune && dune_version >= (1, 10) then
-        rules
-      else begin
-        let source_files =
-          File_tree.Dir.files ftdir
-          |> Path.Set.of_string_set ~f:(Path.relative dir)
-        in
-        List.map rules ~f:(fun (rule : Pre_rule.t) ->
-          match rule.mode with
-          | Promote _ | Fallback | Ignore_source_files -> rule
-          | Standard ->
-            let inter = Path.Set.inter rule.targets source_files in
-            if Path.Set.is_empty inter then
-              rule
-            else begin
-              let mode, behavior =
-                if Path.Set.equal inter rule.targets then
-                  (Dune_file.Rule.Mode.Fallback,
-                   "acting as if the rule didn't exist")
-                else
-                  (Dune_file.Rule.Mode.Promote
-                     { lifetime = Unlimited
-                     ; into = None
-                     ; only =
-                         Some
-                           (Predicate_lang.of_pred
-                              (fun s ->
-                                 Path.Set.mem inter (Path.relative dir s)))
-                     },
-                   "overwriting the source files with the generated one")
-              in
-              Errors.warn
-                (rule_loc ~info:rule.info ~dir ~file_tree:t.file_tree)
-                "The following files are both generated by a rule and are \
-                 present in\nthe source tree:@\n@[<v>%a@,@[%a@]@]"
-                (Fmt.list (Fmt.prefix (Fmt.string "- ") Path.pp))
-                (Path.Set.to_list inter
-                 |> List.map ~f:Path.drop_optional_build_context)
-                Fmt.text
-                (sprintf "Because %s, I am closing my eyes on this and \
-                          I am %s. However, you should really delete \
-                          these files from your source tree. I will no \
-                          longer accept this once you upgrade your \
-                          project to dune >= 1.10."
-                   (match Wp.t with
-                    | Jbuilder -> "you are using the jbuilder binary"
-                    | Dune ->
-                      "your project was written for dune " ^
-                      Syntax.Version.to_string dune_version)
-                   behavior);
-              { rule with mode }
-            end)
-      end
+    fix_up_legacy_fallback_rules t ~file_tree_dir ~dir rules
   in
 
   (* Compute the set of targets and the set of source files that must