Refactor Common.init (#8916)

* Refactor Common.init

Previously, we would obtain a [Common.t] from [Common.term] but it would be
only partially initialised, until we called [Common.init] on it. This
seemed unnecessarily unsafe and also made some upcoming changes to tracing
harder than they should be.

This PR refactors things such that [Common.init] now takes a [Builder.t]
(which was partially exposed but not really used externally before) and
produces a [Common.t]. [Builder.t] encapsulates how Dune should be
initialised and [Common.t] is the result of that initialisation. This seems
cleaner.

This also allows us to move some config settings into [Builder.t] which
were previously sprinkled through the code. The upcoming tracing settings
will be able to go in the same spot.

Signed-off-by: Roman Leshchinskiy <[email protected]>

* Fix dune init

Signed-off-by: Roman Leshchinskiy <[email protected]>

---------

Signed-off-by: Roman Leshchinskiy <[email protected]>
Co-authored-by: Roman Leshchinskiy <[email protected]>

Author: rleshchinskiy

bin/build_cmd.ml

@@ -143,9 +143,9 @@ let runtest_info =
 
 let runtest_term =
   let name_ = Arg.info [] ~docv:"DIR" in
-  let+ common = Common.term
+  let+ builder = Common.Builder.term
   and+ dirs = Arg.(value & pos_all string [ "." ] name_) in
-  let config = Common.init common in
+  let common, config = Common.init builder in
   let request (setup : Import.Main.build_system) =
     Action_builder.all_unit
       (List.map dirs ~f:(fun dir ->
@@ -180,14 +180,14 @@ let build =
   in
   let name_ = Arg.info [] ~docv:"TARGET" in
   let term =
-    let+ common = Common.term
+    let+ builder = Common.Builder.term
     and+ targets = Arg.(value & pos_all dep [] name_) in
     let targets =
       match targets with
-      | [] -> [ Common.default_target common ]
+      | [] -> [ Common.Builder.default_target builder ]
       | _ :: _ -> targets
     in
-    let config = Common.init common in
+    let common, config = Common.init builder in
     let request setup =
       Target.interpret_targets (Common.root common) config setup targets
     in
@@ -209,7 +209,7 @@ let fmt =
     ]
   in
   let term =
-    let+ common = Common.term
+    let+ builder = Common.Builder.term
     and+ no_promote =
       Arg.(
         value
@@ -221,10 +221,10 @@ let fmt =
                This takes precedence over auto-promote as that flag is assumed for this \
                command.")
     in
-    let common =
-      Common.set_promote common (if no_promote then Never else Automatically)
+    let builder =
+      Common.Builder.set_promote builder (if no_promote then Never else Automatically)
     in
-    let config = Common.init common in
+    let common, config = Common.init builder in
     let request (setup : Import.Main.build_system) =
       let dir = Path.(relative root) (Common.prefix_target common ".") in
       Alias.in_dir ~name:Dune_rules.Alias.fmt ~recursive:true ~contexts:setup.contexts dir

bin/clean.ml

@@ -9,13 +9,13 @@ let command =
     ]
   in
   let term =
-    let+ common = Common.term in
-    (* Pass [No_log_file] to prevent the log file from being created. Indeed, we
-       are going to delete the whole build directory right after and that
-       includes deleting the log file. Not only creating the log file would be
-       useless but with some FS this also causes [dune clean] to fail (cf
+    let+ builder = Common.Builder.term in
+    (* Disable log file creation. Indeed, we are going to delete the whole build directory
+       right after and that includes deleting the log file. Not only would creating the
+       log file be useless but with some FS this also causes [dune clean] to fail (cf
        https://github.com/ocaml/dune/issues/2964). *)
-    let _config = Common.init common ~log_file:No_log_file in
+    let builder = Common.Builder.disable_log_file builder in
+    let _common, _config = Common.init builder in
     Dune_util.Global_lock.lock_exn ~timeout:None;
     Dune_engine.Target_promotion.files_in_source_tree_to_delete ()
     |> Path.Source.Set.iter ~f:(fun p -> Path.unlink_no_err (Path.source p));

bin/common.ml

@@ -554,6 +554,14 @@ let cache_debug_flags_term : Cache_debug_flags.t Term.t =
   value initial
 ;;
 
+module Action_runner = struct
+  type t =
+    | No
+    | Yes of
+        (Dune_lang.Dep_conf.t Dune_rpc_impl.Server.t
+         -> (Dune_engine.Action_exec.input -> Dune_engine.Action_runner.t option) Staged.t)
+end
+
 module Builder = struct
   type t =
     { debug_dep_path : bool
@@ -594,9 +602,20 @@ module Builder = struct
     ; root : string option
     ; stats_trace_file : string option
     ; stats_trace_extended : bool
+    ; allow_builds : bool
+    ; default_root_is_cwd : bool
+    ; action_runner : Action_runner.t
+    ; log_file : Dune_util.Log.File.t
     }
 
   let set_root t root = { t with root = Some root }
+  let forbid_builds t = { t with allow_builds = false; no_print_directory = true }
+  let set_default_root_is_cwd t x = { t with default_root_is_cwd = x }
+  let set_action_runner t x = { t with action_runner = x }
+  let set_log_file t x = { t with log_file = x }
+  let disable_log_file t = { t with log_file = No_log_file }
+  let set_promote t v = { t with promote = Some v }
+  let default_target t = t.default_target
 
   (** Cmdliner documentation markup language
       (https://erratique.ch/software/cmdliner/doc/tool_man.html#doclang)
@@ -1023,6 +1042,10 @@ module Builder = struct
     ; root
     ; stats_trace_file
     ; stats_trace_extended
+    ; allow_builds = true
+    ; default_root_is_cwd = false
+    ; action_runner = No
+    ; log_file = Default
     }
   ;;
 end
@@ -1044,7 +1067,6 @@ let dump_memo_graph_file t = t.builder.dump_memo_graph_file
 let dump_memo_graph_format t = t.builder.dump_memo_graph_format
 let dump_memo_graph_with_timing t = t.builder.dump_memo_graph_with_timing
 let file_watcher t = t.builder.file_watcher
-let default_target t = t.builder.default_target
 let prefix_target t s = t.root.reach_from_root_prefix ^ s
 
 let rpc t =
@@ -1053,10 +1075,6 @@ let rpc t =
   | `Allow rpc -> `Allow (Lazy.force rpc)
 ;;
 
-let forbid_builds t =
-  { t with rpc = `Forbid_builds; builder = { t.builder with no_print_directory = true } }
-;;
-
 let signal_watcher t =
   match t.rpc with
   | `Allow _ -> `Yes
@@ -1068,7 +1086,6 @@ let signal_watcher t =
 let watch_exclusions t = t.builder.watch_exclusions
 let stats t = t.stats
 let insignificant_changes t = t.builder.insignificant_changes
-let set_promote t v = { t with builder = { t.builder with promote = Some v } }
 
 (* To avoid needless recompilations under Windows, where the case of
    [Sys.getcwd] can vary between different invocations of [dune], normalize to
@@ -1134,13 +1151,67 @@ let print_entering_message c =
       Console.print [ Pp.verbatim (sprintf "Leaving directory '%s'" dir) ]))
 ;;
 
-let init ?action_runner ?log_file c =
+(* CR-someday rleshchinskiy: The split between `build` and `init` seems quite arbitrary,
+   we should probably refactor that at some point. *)
+let build (builder : Builder.t) =
+  let root =
+    Workspace_root.create
+      ~default_is_cwd:builder.default_root_is_cwd
+      ~specified_by_user:builder.root
+  in
+  let stats =
+    Option.map builder.stats_trace_file ~f:(fun f ->
+      let stats =
+        Dune_stats.create
+          ~extended_build_job_info:builder.stats_trace_extended
+          (Out (open_out f))
+      in
+      Dune_stats.set_global stats;
+      stats)
+  in
+  let rpc =
+    if builder.allow_builds
+    then
+      `Allow
+        (lazy
+          (let registry =
+             match builder.watch with
+             | Yes _ -> `Add
+             | No -> `Skip
+           in
+           let lock_timeout =
+             match builder.watch with
+             | Yes Passive -> Some 1.0
+             | _ -> None
+           in
+           let action_runner = Dune_engine.Action_runner.Rpc_server.create () in
+           Dune_rpc_impl.Server.create
+             ~lock_timeout
+             ~registry
+             ~root:root.dir
+             ~handle:Dune_rules_rpc.register
+             ~watch_mode_config:builder.watch
+             ~parse_build:Dune_rules_rpc.parse_build
+             stats
+             action_runner))
+    else `Forbid_builds
+  in
+  if builder.store_digest_preimage then Dune_engine.Reversible_digest.enable ();
+  if builder.print_metrics
+  then (
+    Memo.Perf_counters.enable ();
+    Dune_metrics.enable ());
+  { builder; root; rpc; stats }
+;;
+
+let init (builder : Builder.t) =
+  let c = build builder in
   if c.root.dir <> Filename.current_dir_name then Sys.chdir c.root.dir;
   Path.set_root (normalize_path (Path.External.cwd ()));
   Path.Build.set_build_dir (Path.Outside_build_dir.of_string c.builder.build_dir);
   (* Once we have the build directory set, initialise the logging. We can't do
      this earlier, because the build log typically goes into [_build/log]. *)
-  Log.init () ?file:log_file;
+  Log.init () ~file:builder.log_file;
   (* We need to print this before reading the workspace file, so that the editor
      can interpret errors in the workspace file. *)
   print_entering_message c;
@@ -1179,9 +1250,9 @@ let init ?action_runner ?log_file c =
   in
   Log.info [ Pp.textf "Shared cache: %s" (Config.Toggle.to_string config.cache_enabled) ];
   let action_runner =
-    match action_runner with
-    | None -> None
-    | Some f ->
+    match builder.action_runner with
+    | No -> None
+    | Yes f ->
       (match rpc c with
        | `Forbid_builds -> Code_error.raise "action runners require building" []
        | `Allow server -> Some (Staged.unstage @@ f server))
@@ -1240,7 +1311,7 @@ let init ?action_runner ?log_file c =
       let stat = Gc.stat () in
       let path = Path.external_ file in
       Dune_util.Gc.serialize ~path stat);
-  config
+  c, config
 ;;
 
 let footer =
@@ -1281,63 +1352,6 @@ let help_secs =
   ]
 ;;
 
-let build (builder : Builder.t) ~default_root_is_cwd =
-  let root =
-    Workspace_root.create
-      ~default_is_cwd:default_root_is_cwd
-      ~specified_by_user:builder.root
-  in
-  let stats =
-    Option.map builder.stats_trace_file ~f:(fun f ->
-      let stats =
-        Dune_stats.create
-          ~extended_build_job_info:builder.stats_trace_extended
-          (Out (open_out f))
-      in
-      Dune_stats.set_global stats;
-      stats)
-  in
-  let rpc =
-    `Allow
-      (lazy
-        (let registry =
-           match builder.watch with
-           | Yes _ -> `Add
-           | No -> `Skip
-         in
-         let lock_timeout =
-           match builder.watch with
-           | Yes Passive -> Some 1.0
-           | _ -> None
-         in
-         let action_runner = Dune_engine.Action_runner.Rpc_server.create () in
-         Dune_rpc_impl.Server.create
-           ~lock_timeout
-           ~registry
-           ~root:root.dir
-           ~handle:Dune_rules_rpc.register
-           ~watch_mode_config:builder.watch
-           ~parse_build:Dune_rules_rpc.parse_build
-           stats
-           action_runner))
-  in
-  if builder.store_digest_preimage then Dune_engine.Reversible_digest.enable ();
-  if builder.print_metrics
-  then (
-    Memo.Perf_counters.enable ();
-    Dune_metrics.enable ());
-  { builder; root; rpc; stats }
-;;
-
-let term ~default_root_is_cwd =
-  let+ builder = Builder.term in
-  build builder ~default_root_is_cwd
-;;
-
-let term_with_default_root_is_cwd = term ~default_root_is_cwd:true
-let term = term ~default_root_is_cwd:false
-let build = build ~default_root_is_cwd:false
-
 let envs =
   Cmd.Env.
     [ info

bin/common.mli

@@ -14,7 +14,6 @@ val rpc
      | `Forbid_builds (** Promise not to build anything. For now, this isn't checked *)
      ]
 
-val forbid_builds : t -> t
 val signal_watcher : t -> [ `Yes | `No ]
 val watch_exclusions : t -> string list
 val stats : t -> Dune_stats.t option
@@ -24,23 +23,41 @@ val dump_memo_graph_format : t -> Dune_graph.Graph.File_format.t
 val dump_memo_graph_with_timing : t -> bool
 val watch : t -> Dune_rpc_impl.Watch_mode_config.t
 val file_watcher : t -> Dune_engine.Scheduler.Run.file_watcher
-val default_target : t -> Arg.Dep.t
 val prefix_target : t -> string -> string
 val insignificant_changes : t -> [ `React | `Ignore ]
 
-(** [init] executes sequence of side-effecting actions to initialize Dune's
-    working environment based on the options determined in a [Common.t]
-    record.contents.
+module Action_runner : sig
+  type t =
+    | No
+    | Yes of
+        (Dune_lang.Dep_conf.t Dune_rpc_impl.Server.t
+         -> (Dune_engine.Action_exec.input -> Dune_engine.Action_runner.t option) Staged.t)
+end
+
+(** [Builder] describes how to initialize Dune. *)
+module Builder : sig
+  type t
+
+  val set_root : t -> string -> t
+  val forbid_builds : t -> t
+  val set_default_root_is_cwd : t -> bool -> t
+  val set_action_runner : t -> Action_runner.t -> t
+  val set_log_file : t -> Dune_util.Log.File.t -> t
+  val disable_log_file : t -> t
+  val set_promote : t -> Dune_engine.Clflags.Promote.t -> t
+  val default_target : t -> Arg.Dep.t
+  val term : t Cmdliner.Term.t
+end
+
+val build : Builder.t -> t
 
-    Return the final configuration, which is the same as the one returned in the
-    [config] field of [Dune_rules.Workspace.workspace ()]) *)
-val init
-  :  ?action_runner:
-       (Dune_lang.Dep_conf.t Dune_rpc_impl.Server.t
-        -> (Dune_engine.Action_exec.input -> Dune_engine.Action_runner.t option) Staged.t)
-  -> ?log_file:Dune_util.Log.File.t
-  -> t
-  -> Dune_config.t
+(** [init] creates a [Common.t] by executing a sequence of side-effecting actions to
+    initialize Dune's working environment based on the options determined in the\
+    [Builder.t].
+
+    Return the [Common.t] and the final configuration, which is the same as the one
+    returned in the [config] field of [Dune_rules.Workspace.workspace ()]) *)
+val init : Builder.t -> t * Dune_config_file.Dune_config.t
 
 (** [examples [("description", "dune cmd foo"); ...]] is an [EXAMPLES] manpage
     section of enumerated examples illustrating how to run the documented
@@ -54,10 +71,7 @@ val command_synopsis : string list -> Cmdliner.Manpage.block list
 
 val help_secs : Cmdliner.Manpage.block list
 val footer : Cmdliner.Manpage.block
-val term : t Cmdliner.Term.t
-val term_with_default_root_is_cwd : t Cmdliner.Term.t
 val envs : Cmdliner.Cmd.Env.info list
-val set_promote : t -> Dune_engine.Clflags.Promote.t -> t
 val debug_backtraces : bool Cmdliner.Term.t
 val config_from_config_file : Dune_config.Partial.t Cmdliner.Term.t
 val display_term : Dune_config.Display.t option Cmdliner.Term.t
@@ -73,12 +87,3 @@ module Let_syntax : sig
   val ( let+ ) : 'a Cmdliner.Term.t -> ('a -> 'b) -> 'b Cmdliner.Term.t
   val ( and+ ) : 'a Cmdliner.Term.t -> 'b Cmdliner.Term.t -> ('a * 'b) Cmdliner.Term.t
 end
-
-module Builder : sig
-  type t
-
-  val set_root : t -> string -> t
-  val term : t Cmdliner.Term.t
-end
-
-val build : Builder.t -> t