From 7ef8c00a1c4857c03380c7861c5fc3e49521eb11 Mon Sep 17 00:00:00 2001
From: Marek Kubica <marek@tarides.com>
Date: Tue, 13 Aug 2024 11:57:06 +0200
Subject: [PATCH] Add configure-time toggles (#10811)

Signed-off-by: Marek Kubica <marek@tarides.com>
Co-authored-by: Etienne Millon <me@emillon.org>
---
 bin/main.ml                               |  1 +
 boot/configure.ml                         | 13 ++++-
 otherlibs/stdune/src/string.ml            | 11 +++-
 otherlibs/stdune/src/string.mli           |  1 +
 src/dune_config/config.ml                 | 61 ++++++++++++++---------
 src/dune_config/config.mli                |  4 ++
 src/dune_config_file/dune_config_file.ml  |  2 +
 src/dune_config_file/dune_config_file.mli |  2 +
 src/dune_engine/build_system.ml           | 16 ++++++
 src/dune_rules/import.ml                  |  2 +-
 src/dune_rules/setup.defaults.ml          |  2 +
 src/dune_rules/setup.mli                  |  2 +
 12 files changed, 90 insertions(+), 27 deletions(-)

diff --git a/bin/main.ml b/bin/main.ml
index ba47da9fe45..e07900b528a 100644
--- a/bin/main.ml
+++ b/bin/main.ml
@@ -101,6 +101,7 @@ let exit_and_flush code =
 ;;
 
 let () =
+  Dune_rules.Setup.init ();
   Dune_rules.Colors.setup_err_formatter_colors ();
   try
     match Cmd.eval_value cmd ~catch:false with
diff --git a/boot/configure.ml b/boot/configure.ml
index 5467bf3b37e..4c2a14db7eb 100644
--- a/boot/configure.ml
+++ b/boot/configure.ml
@@ -17,6 +17,10 @@ let out =
   | Some out -> out
 ;;
 
+let toggle_inits l =
+  sprintf "Dune_config.Config.set_configure_time_toggles ~names:%s" (list string l)
+;;
+
 let () =
   let bad fmt = ksprintf (fun s -> raise (Arg.Bad s)) fmt in
   let library_path = ref [] in
@@ -29,6 +33,7 @@ let () =
   let libexecdir = ref None in
   let datadir = ref None in
   let cwd = lazy (Sys.getcwd ()) in
+  let toggles = ref [] in
   let dir_of_string s =
     if Filename.is_relative s then Filename.concat (Lazy.force cwd) s else s
   in
@@ -41,6 +46,7 @@ let () =
     let dir = dir_of_string s in
     v := Some dir
   in
+  let set_toggles s = toggles := String.split_on_char ~sep:',' s in
   let args =
     [ ( "--libdir"
       , Arg.String set_libdir
@@ -70,6 +76,10 @@ let () =
       , Arg.String (set_dir datadir)
       , "DIR where files for the share_root section are installed for the default build \
          context" )
+    ; ( "--toggles"
+      , Arg.String set_toggles
+      , "NAMES comma-separated list of configuration options to be set to 'enabled' by \
+         default." )
     ]
   in
   let anon s = bad "Don't know what to do with %s" s in
@@ -89,6 +99,7 @@ let () =
   pr "  ; bin = %s" (option string !bindir);
   pr "  ; sbin = %s" (option string !sbindir);
   pr "  ; libexec_root = %s" (option string !libexecdir);
-  pr "  }";
+  pr "  }\n";
+  pr "let init () = %s" (toggle_inits !toggles);
   close_out oc
 ;;
diff --git a/otherlibs/stdune/src/string.ml b/otherlibs/stdune/src/string.ml
index 65baad0bcdf..74b889e32e1 100644
--- a/otherlibs/stdune/src/string.ml
+++ b/otherlibs/stdune/src/string.ml
@@ -1,5 +1,14 @@
-(* Because other the syntax s.[x] causes trouble *)
+(* Because otherwise the syntax s.[x] causes trouble *)
 module String = Stdlib.String
+
+module StringLabels = struct
+  (* functions potentially in the stdlib, depending on OCaml version *)
+  let[@warning "-32"] fold_left ~f ~init s = s |> String.to_seq |> Seq.fold_left ~f ~init
+
+  (* overwrite them with stdlib versions if available *)
+  include Stdlib.StringLabels
+end
+
 include StringLabels
 
 let compare a b = Ordering.of_int (String.compare a b)
diff --git a/otherlibs/stdune/src/string.mli b/otherlibs/stdune/src/string.mli
index 484a6c67bab..50b2d9d34af 100644
--- a/otherlibs/stdune/src/string.mli
+++ b/otherlibs/stdune/src/string.mli
@@ -80,6 +80,7 @@ val longest_map : 'a list -> f:('a -> string) -> int
 val longest_prefix : t list -> t
 val exists : t -> f:(char -> bool) -> bool
 val for_all : t -> f:(char -> bool) -> bool
+val fold_left : f:('acc -> char -> 'acc) -> init:'acc -> string -> 'acc
 
 (** [maybe_quoted s] is [s] if [s] doesn't need escaping according to OCaml
     lexing conventions and [sprintf "%S" s] otherwise.
diff --git a/src/dune_config/config.ml b/src/dune_config/config.ml
index 1ec1ef3313c..25e559e62fb 100644
--- a/src/dune_config/config.ml
+++ b/src/dune_config/config.ml
@@ -1,11 +1,14 @@
 open Stdune
 
 let initialized = ref false
+let configure_time_frozen = ref false
 
 type 'a t =
   { name : string
   ; of_string : string -> ('a, string) result
-  ; mutable value : 'a
+  ; mutable value : 'a option
+  ; default : 'a
+  ; mutable configure_time_value : 'a option
   }
 
 let env_name t = sprintf "DUNE_CONFIG__%s" (String.uppercase_ascii t.name)
@@ -13,13 +16,18 @@ let env_name t = sprintf "DUNE_CONFIG__%s" (String.uppercase_ascii t.name)
 let get t =
   if not !initialized
   then Code_error.raise "Config.get: invalid access" [ "name", Dyn.string t.name ];
-  t.value
+  configure_time_frozen := true;
+  match t.value with
+  | Some v -> v
+  | None -> Option.value t.configure_time_value ~default:t.default
 ;;
 
 type packed = E : 'a t -> packed
 
 let all = ref []
 let register t = all := E t :: !all
+let toggles = ref []
+let register_toggle t = toggles := t :: !toggles
 
 module Toggle = struct
   type t =
@@ -70,29 +78,40 @@ let init values =
     in
     let env_name = env_name t in
     match Sys.getenv_opt env_name with
-    | None -> Option.iter config ~f:(fun config -> t.value <- config)
+    | None -> Option.iter config ~f:(fun config -> t.value <- Some config)
     | Some v ->
       (match t.of_string v with
-       | Ok v -> t.value <- v
+       | Ok v -> t.value <- Some v
        | Error e ->
          User_error.raise [ Pp.textf "Invalid value for %S" env_name; Pp.text e ]));
   initialized := true
 ;;
 
 let make ~name ~of_string ~default =
-  let t = { name; of_string; value = default } in
+  let t = { name; of_string; value = None; default; configure_time_value = None } in
   register t;
   t
 ;;
 
-let make_toggle ~name ~default = make ~name ~default ~of_string:Toggle.of_string
-let global_lock = make ~name:"global_lock" ~of_string:Toggle.of_string ~default:`Enabled
+let set_configure_time_toggles ~names =
+  if !configure_time_frozen
+  then Code_error.raise "Config.set_configure_time_toggles: invalid access" [];
+  List.iter names ~f:(fun name ->
+    let t = List.find_exn !toggles ~f:(fun t -> String.equal t.name name) in
+    t.configure_time_value <- Some `Enabled);
+  configure_time_frozen := true
+;;
+
+let make_toggle ~name ~default =
+  let t = make ~name ~default ~of_string:Toggle.of_string in
+  register_toggle t;
+  t
+;;
+
+let global_lock = make_toggle ~name:"global_lock" ~default:`Enabled
 
 let cutoffs_that_reduce_concurrency_in_watch_mode =
-  make
-    ~name:"cutoffs_that_reduce_concurrency_in_watch_mode"
-    ~of_string:Toggle.of_string
-    ~default:`Disabled
+  make_toggle ~name:"cutoffs_that_reduce_concurrency_in_watch_mode" ~default:`Disabled
 ;;
 
 let copy_file =
@@ -111,31 +130,23 @@ let background_default =
   | _ -> `Disabled
 ;;
 
-let background_actions =
-  make ~name:"background_actions" ~of_string:Toggle.of_string ~default:`Disabled
-;;
+let background_actions = make_toggle ~name:"background_actions" ~default:`Disabled
 
 let background_digests =
-  make ~name:"background_digests" ~of_string:Toggle.of_string ~default:background_default
+  make_toggle ~name:"background_digests" ~default:background_default
 ;;
 
 let background_sandboxes =
-  make
-    ~name:"background_sandboxes"
-    ~of_string:Toggle.of_string
-    ~default:background_default
+  make_toggle ~name:"background_sandboxes" ~default:background_default
 ;;
 
 let background_file_system_operations_in_rule_execution =
-  make
+  make_toggle
     ~name:"background_file_system_operations_in_rule_execution"
-    ~of_string:Toggle.of_string
     ~default:`Disabled
 ;;
 
-let threaded_console =
-  make ~name:"threaded_console" ~of_string:Toggle.of_string ~default:background_default
-;;
+let threaded_console = make_toggle ~name:"threaded_console" ~default:background_default
 
 let threaded_console_frames_per_second =
   make
@@ -147,3 +158,5 @@ let threaded_console_frames_per_second =
       | None -> Error (sprintf "could not parse %S as an integer" x))
     ~default:`Default
 ;;
+
+let party_mode = make_toggle ~name:"party_mode" ~default:`Disabled
diff --git a/src/dune_config/config.mli b/src/dune_config/config.mli
index 4c1d3944aaa..3dfdb7eff58 100644
--- a/src/dune_config/config.mli
+++ b/src/dune_config/config.mli
@@ -22,6 +22,8 @@ module Toggle : sig
   val to_dyn : t -> Dyn.t
 end
 
+val set_configure_time_toggles : names:string list -> unit
+
 (** [make ~name ~of_string ~default] registers a config value called [name],
     parsed using [of_string], defaulting to [default]. *)
 val make : name:string -> of_string:(string -> ('a, string) result) -> default:'a -> 'a t
@@ -67,3 +69,5 @@ val threaded_console_frames_per_second : [ `Default | `Custom of int ] t
     Note that environment variables take precedence over the values passed here
     for easy overriding. *)
 val init : (Loc.t * string) String.Map.t -> unit
+
+val party_mode : Toggle.t t
diff --git a/src/dune_config_file/dune_config_file.ml b/src/dune_config_file/dune_config_file.ml
index 0b31881b547..f797570b1cd 100644
--- a/src/dune_config_file/dune_config_file.ml
+++ b/src/dune_config_file/dune_config_file.ml
@@ -501,4 +501,6 @@ module Dune_config = struct
         | Simple { verbosity; _ } -> verbosity);
     { Scheduler.Config.concurrency; stats; print_ctrl_c_warning; watch_exclusions }
   ;;
+
+  let set_configure_time_toggles = Config.set_configure_time_toggles
 end
diff --git a/src/dune_config_file/dune_config_file.mli b/src/dune_config_file/dune_config_file.mli
index 0f33225084b..1df6567a77e 100644
--- a/src/dune_config_file/dune_config_file.mli
+++ b/src/dune_config_file/dune_config_file.mli
@@ -111,4 +111,6 @@ module Dune_config : sig
     -> Dune_stats.t option
     -> print_ctrl_c_warning:bool
     -> Dune_engine.Scheduler.Config.t
+
+  val set_configure_time_toggles : names:string list -> unit
 end
diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml
index 28986dceba9..39dbc6e9dec 100644
--- a/src/dune_engine/build_system.ml
+++ b/src/dune_engine/build_system.ml
@@ -1131,6 +1131,22 @@ let handle_final_exns exns =
 
 let run f =
   let open Fiber.O in
+  (match Dune_config.Config.get Dune_config.Config.party_mode with
+   | `Enabled ->
+     let tag i =
+       match i mod 4 with
+       | 0 -> User_message.Style.Ok
+       | 1 -> Error
+       | 2 -> Warning
+       | _ -> Kwd
+     in
+     let festive s =
+       String.fold_left s ~init:(Pp.nop, 0) ~f:(fun (acc, i) c ->
+         Pp.seq acc (Pp.tag (tag i) (Pp.char c)), i + 1)
+       |> fst
+     in
+     User_message.print (User_message.make [ festive "PARTY MODE enabled." ])
+   | `Disabled -> ());
   let* () = State.reset_progress () in
   let* () = State.reset_errors () in
   let f () =
diff --git a/src/dune_rules/import.ml b/src/dune_rules/import.ml
index dbcf474a259..39dc8197422 100644
--- a/src/dune_rules/import.ml
+++ b/src/dune_rules/import.ml
@@ -162,5 +162,5 @@ let ( == ) = `Use_phys_equal
 
 (** Controls whether we use background threads in the dune rules *)
 let background_dune_rules =
-  Config.make ~name:"background_dune_rules" ~of_string:Toggle.of_string ~default:`Disabled
+  Config.make_toggle ~name:"background_dune_rules" ~default:`Disabled
 ;;
diff --git a/src/dune_rules/setup.defaults.ml b/src/dune_rules/setup.defaults.ml
index 39b9242e701..b7c9a4a2839 100644
--- a/src/dune_rules/setup.defaults.ml
+++ b/src/dune_rules/setup.defaults.ml
@@ -10,3 +10,5 @@ let roots : string option Install.Roots.t =
   ; sbin = None
   ; libexec_root = None
   }
+
+let init () = Dune_config.Config.set_configure_time_toggles ~names:[]
diff --git a/src/dune_rules/setup.mli b/src/dune_rules/setup.mli
index 442125bf12e..c6cef1df87f 100644
--- a/src/dune_rules/setup.mli
+++ b/src/dune_rules/setup.mli
@@ -9,3 +9,5 @@ val library_path : string list
 
 (** Where to install files. All the directories are absolute path *)
 val roots : string option Install.Roots.t
+
+val init : unit -> unit