1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
let initialized = ref false
let sprintf = Printf.sprintf
type 'a t =
{ name : string
; of_string : string -> ('a, string) result
; mutable value : 'a
; lazy_init : bool
; mutable read : bool
}
let env_name t = sprintf "DUNE_CONFIG__%s" (String.uppercase_ascii t.name)
let is_initialized () = !initialized
let get t =
if t.lazy_init || !initialized
then (
t.read <- true;
t.value)
else Code_error.raise "Config.get: invalid access" [ "name", Dyn.string t.name ]
;;
type packed = E : 'a t -> packed
let all = ref []
let register t = all := E t :: !all
module Toggle = struct
type t =
[ `Enabled
| `Disabled
]
let repr =
Repr.variant
"config-toggle"
[ Repr.case0 "Enabled" ~test:(function
| `Enabled -> true
| `Disabled -> false)
; Repr.case0 "Disabled" ~test:(function
| `Disabled -> true
| `Enabled -> false)
]
;;
let all : (string * t) list = [ "enabled", `Enabled; "disabled", `Disabled ]
include Repr.Poly (struct
type nonrec t = t
let repr = repr
end)
let to_string t =
List.find_map all ~f:(fun (k, v) -> if equal v t then Some k else None)
|> Option.value_exn
;;
let of_string s =
match List.assoc all s with
| Some s -> Ok s
| None -> Error (sprintf "only %S and %S are allowed" "enabled" "disabled")
;;
let to_dyn = Repr.to_dyn repr
end
let init values =
if !initialized then Code_error.raise "Config.init: already initialized" [];
let all =
let all = String.Map.of_list_map_exn !all ~f:(fun (E t) -> t.name, E t) in
String.Map.merge values all ~f:(fun name x y ->
match x, y with
| None, None -> assert false
| Some (loc, _), None ->
User_error.raise ~loc [ Pp.textf "key %S doesn't exist" name ]
| Some (loc, v), Some t -> Some (Some (loc, v), t)
| None, Some t -> Some (None, t))
in
String.Map.iter all ~f:(fun (config, E t) ->
let config =
Option.map config ~f:(fun (loc, config) ->
match t.of_string config with
| Ok s -> s
| Error v ->
User_error.raise ~loc [ Pp.textf "failed to parse %S" t.name; Pp.text v ])
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)
| Some v ->
(match t.of_string v with
| Ok v ->
if t.read && v <> t.value
then Code_error.raise "variable already read" [ "name", Dyn.string t.name ]
else t.value <- v
| Error e ->
User_error.raise [ Pp.textf "Invalid value for %S" env_name; Pp.text e ]));
initialized := true
;;
let make ~lazy_init ~name ~of_string ~default =
let t = { name; of_string; value = default; lazy_init; read = false } in
register t;
t
;;
let make_toggle_lazy_init ~name ~default =
make ~lazy_init:true ~name ~default ~of_string:Toggle.of_string
;;
let make_toggle ~name ~default =
make ~lazy_init:false ~name ~default ~of_string:Toggle.of_string
;;
let make ~name ~of_string ~default = make ~lazy_init:false ~name ~of_string ~default
let global_lock = make ~name:"global_lock" ~of_string:Toggle.of_string ~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
;;
let copy_file =
make
~name:"copy_file"
~of_string:(function
| "portable" -> Ok `Portable
| "fast" -> Ok `Best
| _ -> Error (sprintf "only %S and %S are allowed" "fast" "portable"))
~default:`Best
;;
let background_default =
match Platform.OS.value with
| Linux | Windows | Darwin -> `Enabled
| _ -> `Disabled
;;
let background_actions =
make ~name:"background_actions" ~of_string:Toggle.of_string ~default:`Disabled
;;
let background_digests =
make ~name:"background_digests" ~of_string:Toggle.of_string ~default:background_default
;;
let background_sandboxes =
make
~name:"background_sandboxes"
~of_string:Toggle.of_string
~default:background_default
;;
let background_file_system_operations_in_rule_execution =
make
~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_frames_per_second =
make
~name:"threaded_console_frames_per_second"
~of_string:(fun x ->
match Int.of_string x with
| Some x when x > 0 && x <= 1000 -> Ok (`Custom x)
| Some _ -> Error (sprintf "value must be between 1 and 1000")
| None -> Error (sprintf "could not parse %S as an integer" x))
~default:`Default
;;