diff --git a/bin/subst.ml b/bin/subst.ml index 2bc98511982..c4d61c63f15 100644 --- 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 ) 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 ) 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 ) 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 ) 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 index a0f79b6b0be..71a51a72562 100644 --- 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