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