diff --git a/src/dune_rules/pkg_build_progress.ml b/src/dune_rules/pkg_build_progress.ml new file mode 100644 index 00000000000..b216b7ef08c --- /dev/null +++ b/src/dune_rules/pkg_build_progress.ml @@ -0,0 +1,82 @@ +open! Import + +let enabled = Config.make_toggle ~name:"pkg_build_progress" ~default:`Disabled + +module Status = struct + type t = + [ `Downloading + | `Building + ] + + let to_string = function + | `Downloading -> "Downloading" + | `Building -> "Building" + ;; +end + +module Message = struct + type t = + { package_name : Package.Name.t + ; package_version : Package_version.t + ; status : Status.t + } + + let user_message { package_name; package_version; status } = + let status_tag = User_message.Style.Ok in + User_message.make + [ Pp.concat + [ Pp.tag status_tag (Pp.text (Status.to_string status)) + ; Pp.textf + " %s.%s" + (Package.Name.to_string package_name) + (Package_version.to_string package_version) + ] + ] + ;; + + let display t = + match Config.get enabled with + | `Enabled -> Console.print_user_message (user_message t) + | `Disabled -> () + ;; + + let encode { package_name; package_version; status } = + Sexp.List + [ Sexp.Atom (Package.Name.to_string package_name) + ; Sexp.Atom (Package_version.to_string package_version) + ; Sexp.Atom (Status.to_string status) + ] + ;; +end + +module Spec = struct + type ('path, 'target) t = Message.t + + let name = "progress-action" + let version = 1 + let is_useful_to ~memoize:_ = true + let bimap t _f _g = t + + let encode t _ _ = + Sexp.List [ Sexp.Atom name; Sexp.Atom (Int.to_string version); Message.encode t ] + ;; + + let action t ~ectx:_ ~eenv:_ = + let open Fiber.O in + let+ () = Fiber.return () in + Message.display t + ;; +end + +let progress_action package_name package_version status = + let module M = struct + type path = Path.t + type target = Path.Build.t + + module Spec = Spec + + let v = { Message.package_name; package_version; status } + end + in + Action.Extension (module M) +;; diff --git a/src/dune_rules/pkg_build_progress.mli b/src/dune_rules/pkg_build_progress.mli new file mode 100644 index 00000000000..058bb00d3a3 --- /dev/null +++ b/src/dune_rules/pkg_build_progress.mli @@ -0,0 +1,14 @@ +open! Import + +(** An action which prints a progress message about a package to + the console so users can be informed about which of their + project's dependencies are currently being installed. + + The message will only print if the + DUNE_CONFIG__PKG_BUILD_PROGRESS config variable is "enabled" + (it's "disabled" by default). *) +val progress_action + : Package.Name.t + -> Package_version.t + -> [ `Downloading | `Building ] + -> Action.t diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml index 886b1734824..5faf43a8e3c 100644 --- a/src/dune_rules/pkg_rules.ml +++ b/src/dune_rules/pkg_rules.ml @@ -1675,6 +1675,16 @@ let source_rules (pkg : Pkg.t) = | `Local (`File, _) | `Fetch -> let fetch = Fetch_rules.fetch ~target:pkg.write_paths.source_dir `Directory source + |> With_targets.map + ~f: + (Action.Full.map ~f:(fun action -> + let progress = + Pkg_build_progress.progress_action + pkg.info.name + pkg.info.version + `Downloading + in + Action.progn [ progress; action ])) in Memo.return (Dep.Set.of_files [ pkg.paths.source_dir ], [ loc, fetch ]) | `Local (`Directory, source_root) -> @@ -1713,7 +1723,7 @@ let source_rules (pkg : Pkg.t) = let build_rule context_name ~source_deps (pkg : Pkg.t) = let+ build_action = - let+ build_and_install = + let+ copy_action, build_action, install_action = let+ copy_action = let+ copy_action = Fs_memo.dir_exists @@ -1784,7 +1794,7 @@ let build_rule context_name ~source_deps (pkg : Pkg.t) = in [ mkdir_install_dirs; install_action ] in - List.concat [ copy_action; build_action; install_action ] + copy_action, build_action, install_action in let install_file_action = let prefix_outside_build_dir = Path.as_outside_build_dir pkg.paths.prefix in @@ -1798,7 +1808,20 @@ let build_rule context_name ~source_deps (pkg : Pkg.t) = |> Action_builder.return |> Action_builder.with_no_targets in - Action_builder.progn (build_and_install @ [ install_file_action ]) + (* Action to print a "Building" message for the package if its + target directory is not yet created. *) + let progress_building = + Pkg_build_progress.progress_action pkg.info.name pkg.info.version `Building + |> Action.Full.make + |> Action_builder.return + |> Action_builder.with_no_targets + in + Action_builder.progn + (copy_action + @ [ progress_building ] + @ build_action + @ install_action + @ [ install_file_action ]) in let deps = Dep.Set.union source_deps (Pkg.package_deps pkg) in let open Action_builder.With_targets.O in