fix: allow [$ dune subst] to work without a repo (#11028)

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>
ocaml · Oct 26, 2024 · 7464d0f · 7464d0f
1 parent bdbd30c
commit 7464d0f
Show file tree

Hide file tree

Showing 2 changed files with 130 additions and 98 deletions.
diff --git a/bin/subst.ml b/bin/subst.ml
@@ -299,111 +299,143 @@ let make_watermark_map ~commit ~version ~dune_project ~info =
 
 let subst vcs =
   let open Memo.O in
-  let* (version, commit), files =
-    Memo.fork_and_join
-      (fun () ->
-        Memo.fork_and_join (fun () -> Vcs.describe vcs) (fun () -> Vcs.commit_id vcs))
-      (fun () -> Vcs.files vcs)
-  in
-  let+ (dune_project : Dune_project.t) =
-    (let files =
-       (* Filter-out files form sub-directories *)
-       List.fold_left files ~init:String.Set.empty ~f:(fun acc fn ->
-         let fn = Path.source fn in
-         if Path.is_root (Path.parent_exn fn)
-         then String.Set.add acc (Path.to_string fn)
-         else acc)
-     in
-     Dune_project.load ~dir:Path.Source.root ~files ~infer_from_opam_files:true)
-    >>| function
-    | Some dune_project -> dune_project
-    | None ->
-      User_error.raise
-        ~loc:(Loc.in_dir (Path.source Path.Source.root))
-        [ Pp.text
-            "There is no dune-project file in the current directory, please add one with \
-             a (name <name>) field in it."
-        ]
-        ~hints:
-          [ Pp.concat
-              ~sep:Pp.space
-              [ User_message.command "dune subst"
-              ; Pp.text "must be executed from the root of the project."
-              ]
-            |> Pp.hovbox
-          ]
-  in
-  (let loc, subst_config = Dune_project.subst_config dune_project.project in
-   match subst_config with
-   | `Enabled -> ()
-   | `Disabled ->
-     User_error.raise
-       ~loc
-       [ Pp.concat
-           ~sep:Pp.space
-           [ User_message.command "dune subst"
-           ; Pp.text "has been disabled in this project. Any use of it is forbidden."
-           ]
-       ]
-       ~hints:
-         [ Pp.text
-             "If you wish to re-enable it, change to (subst enabled) in the dune-project \
-              file."
-         ]);
-  let info =
-    let loc, name =
-      match dune_project.name with
+  (match vcs with
+   | Some vcs ->
+     let+ version = Vcs.describe vcs
+     and+ commit_id = Vcs.commit_id vcs
+     and+ files = Vcs.files vcs in
+     Some (version, commit_id, files)
+   | None ->
+     (* We have to do this because scanning the source tree evaluates [-p].
+        That's because [-p] is needed to interpret packages in dune projects
+        correctly. It should not be necessary, so we should probably make the
+        package loading lazier. *)
+     Dune_rules.Only_packages.Clflags.set No_restriction;
+     let* root = Source_tree.root () in
+     let project = Source_tree.Dir.project root in
+     if Dune_project.dune_version project < (3, 17)
+     then Memo.return None
+     else
+       let+ files =
+         let module Map_reduce =
+           Source_tree.Dir.Make_map_reduce (Memo) (Monoid.Union (Path.Source.Set))
+         in
+         Source_tree.root ()
+         >>= Map_reduce.map_reduce
+               ~traverse:Source_dir_status.Set.all
+               ~trace_event_name:"Subst"
+               ~f:(fun dir ->
+                 Source_tree.Dir.filenames dir
+                 |> Filename.Set.fold ~init:Path.Source.Set.empty ~f:(fun fname acc ->
+                   Path.Source.relative (Source_tree.Dir.path dir) fname
+                   |> Path.Source.Set.add acc)
+                 |> Memo.return)
+       in
+       Some (None, None, Path.Source.Set.to_list files))
+  >>= Memo.Option.iter ~f:(fun (version, commit, files) ->
+    let+ (dune_project : Dune_project.t) =
+      (* CR-soon rgrinberg: unify this check with the above version check *)
+      (let files =
+         (* Filter-out files form sub-directories *)
+         List.fold_left files ~init:String.Set.empty ~f:(fun acc fn ->
+           let fn = Path.source fn in
+           if Path.is_root (Path.parent_exn fn)
+           then String.Set.add acc (Path.to_string fn)
+           else acc)
+       in
+       Dune_project.load ~dir:Path.Source.root ~files ~infer_from_opam_files:true)
+      >>| function
+      | Some dune_project -> dune_project
       | None ->
         User_error.raise
-          ~loc:(Loc.in_file (Path.source dune_project.project_file))
-          [ Pp.textf
-              "The project name is not defined, please add a (name <name>) field to your \
-               dune-project file."
+          ~loc:(Loc.in_dir (Path.source Path.Source.root))
+          [ Pp.text
+              "There is no dune-project file in the current directory, please add one \
+               with a (name <name>) field in it."
           ]
-      | Some n -> n.loc_of_arg, n.arg
+          ~hints:
+            [ Pp.concat
+                ~sep:Pp.space
+                [ User_message.command "dune subst"
+                ; Pp.text "must be executed from the root of the project."
+                ]
+              |> Pp.hovbox
+            ]
     in
-    let package_named_after_project =
-      let packages = Dune_project.including_hidden_packages dune_project.project in
-      Package.Name.Map.find packages name
+    (let loc, subst_config = Dune_project.subst_config dune_project.project in
+     match subst_config with
+     | `Enabled -> ()
+     | `Disabled ->
+       User_error.raise
+         ~loc
+         [ Pp.concat
+             ~sep:Pp.space
+             [ User_message.command "dune subst"
+             ; Pp.text "has been disabled in this project. Any use of it is forbidden."
+             ]
+         ]
+         ~hints:
+           [ Pp.text
+               "If you wish to re-enable it, change to (subst enabled) in the \
+                dune-project file."
+           ]);
+    let info =
+      let loc, name =
+        match dune_project.name with
+        | None ->
+          User_error.raise
+            ~loc:(Loc.in_file (Path.source dune_project.project_file))
+            [ Pp.textf
+                "The project name is not defined, please add a (name <name>) field to \
+                 your dune-project file."
+            ]
+        | Some n -> n.loc_of_arg, n.arg
+      in
+      let package_named_after_project =
+        let packages = Dune_project.including_hidden_packages dune_project.project in
+        Package.Name.Map.find packages name
+      in
+      let metadata_from_dune_project () = Dune_project.info dune_project.project in
+      let metadata_from_matching_package () =
+        match package_named_after_project with
+        | Some pkg -> Ok (Package.info pkg)
+        | None ->
+          Error
+            (User_error.make
+               ~loc
+               [ Pp.textf "Package %s doesn't exist." (Package.Name.to_string name) ])
+      in
+      let version = Dune_project.dune_version dune_project.project in
+      if version >= (3, 0)
+      then metadata_from_dune_project ()
+      else if version >= (2, 8)
+      then (
+        match metadata_from_matching_package () with
+        | Ok p -> p
+        | Error _ -> metadata_from_dune_project ())
+      else User_error.ok_exn (metadata_from_matching_package ())
     in
-    let metadata_from_dune_project () = Dune_project.info dune_project.project in
-    let metadata_from_matching_package () =
-      match package_named_after_project with
-      | Some pkg -> Ok (Package.info pkg)
-      | None ->
-        Error
-          (User_error.make
-             ~loc
-             [ Pp.textf "Package %s doesn't exist." (Package.Name.to_string name) ])
+    let watermarks = make_watermark_map ~commit ~version ~dune_project ~info in
+    Dune_project.subst ~map:watermarks ~version dune_project;
+    let opam_package_files =
+      Dune_project.packages dune_project.project
+      |> Package.Name.Map.fold ~init:Path.Source.Set.empty ~f:(fun package acc ->
+        Path.Source.Set.add acc (Package.opam_file package))
     in
-    let version = Dune_project.dune_version dune_project.project in
-    if version >= (3, 0)
-    then metadata_from_dune_project ()
-    else if version >= (2, 8)
-    then (
-      match metadata_from_matching_package () with
-      | Ok p -> p
-      | Error _ -> metadata_from_dune_project ())
-    else User_error.ok_exn (metadata_from_matching_package ())
-  in
-  let watermarks = make_watermark_map ~commit ~version ~dune_project ~info in
-  Dune_project.subst ~map:watermarks ~version dune_project;
-  let opam_package_files =
-    Dune_project.packages dune_project.project
-    |> Package.Name.Map.fold ~init:Path.Source.Set.empty ~f:(fun package acc ->
-      Path.Source.Set.add acc (Package.opam_file package))
-  in
-  List.iter files ~f:(fun path ->
-    if is_a_source_file path && not (Path.Source.equal path Dune_project.filename)
-    then subst_file path ~map:watermarks opam_package_files)
+    List.iter files ~f:(fun path ->
+      if is_a_source_file path && not (Path.Source.equal path Dune_project.filename)
+      then subst_file path ~map:watermarks opam_package_files))
 ;;
 
 let subst () =
-  match
-    Sys.readdir "." |> Array.to_list |> String.Set.of_list |> Vcs.Kind.of_dir_contents
-  with
-  | None -> Fiber.return ()
-  | Some kind -> Memo.run (subst { kind; root = Path.root })
+  (* CR-someday rgrinberg: use [Source_tree.nearest_vcs] *)
+  Sys.readdir "."
+  |> Array.to_list
+  |> String.Set.of_list
+  |> Vcs.Kind.of_dir_contents
+  |> Option.map ~f:(fun kind -> { Vcs.kind; root = Path.root })
+  |> subst
+  |> Memo.run
 ;;
 
 (** A string that is "%%VERSION%%" but not expanded by [dune subst] *)

diff --git a/test/blackbox-tests/test-cases/subst/without-repo.t b/test/blackbox-tests/test-cases/subst/without-repo.t
@@ -1,7 +1,7 @@
 Demonstrate $ dune subst without a git repository
 
   $ cat > dune-project << EOF
-  > (lang dune 3.16)
+  > (lang dune 3.17)
   > (name test)
   > EOF
 
@@ -10,4 +10,4 @@ Demonstrate $ dune subst without a git repository
   $ dune subst
 
   $ cat README.md
-  %%NAME%%
+  test