Skip to content

Commit a13eebb

Browse files
OlivierNicoleOlivierNicole
authored
Adapt JSOO rules for new --effects= option (#11222)
Signed-off-by: Olivier Nicole <[email protected]>
1 parent 1b05251 commit a13eebb

File tree

12 files changed

+255
-78
lines changed

12 files changed

+255
-78
lines changed

‎src/dune_rules/jsoo/jsoo_rules.ml‎

Lines changed: 184 additions & 76 deletions
Original file line numberDiff line numberDiff line change
@@ -41,136 +41,232 @@ let js_env = compute_env ~mode:JS
4141
let wasm_env = compute_env ~mode:Wasm
4242
let jsoo_env ~dir ~mode = (Js_of_ocaml.Mode.select ~mode ~js:js_env ~wasm:wasm_env) ~dir
4343

44+
module Version = struct
45+
type t = int * int
46+
47+
let of_string s : t option =
48+
let s =
49+
match
50+
String.findi s ~f:(function
51+
| '+' | '-' | '~' -> true
52+
| _ -> false)
53+
with
54+
| None -> s
55+
| Some i -> String.take s i
56+
in
57+
try
58+
match String.split s ~on:'.' with
59+
| [] -> None
60+
| [ major ] -> Some (int_of_string major, 0)
61+
| major :: minor :: _ -> Some (int_of_string major, int_of_string minor)
62+
with
63+
| _ -> None
64+
;;
65+
66+
let compare (ma1, mi1) (ma2, mi2) =
67+
match Int.compare ma1 ma2 with
68+
| Eq -> Int.compare mi1 mi2
69+
| n -> n
70+
;;
71+
72+
let impl_version bin =
73+
let* _ = Build_system.build_file bin in
74+
Memo.of_reproducible_fiber
75+
@@ Process.run_capture_line ~display:Quiet Strict bin [ "--version" ]
76+
|> Memo.map ~f:of_string
77+
;;
78+
79+
let version_memo = Memo.create "jsoo-version" ~input:(module Path) impl_version
80+
81+
let jsoo_version jsoo =
82+
match jsoo with
83+
| Ok jsoo_path -> Memo.exec version_memo jsoo_path
84+
| Error e -> Action.Prog.Not_found.raise e
85+
;;
86+
end
87+
4488
module Config : sig
4589
type t
4690

4791
val all : t list
4892
val path : t -> string
4993
val of_string : string -> t
5094
val of_flags : string list -> t
51-
val to_flags : t -> string list
95+
val to_flags : jsoo_version:Version.t option -> t -> string list
96+
val remove_config_flags : string list -> string list
5297
end = struct
98+
type effects_backend =
99+
| Cps
100+
| Double_translation
101+
53102
type t =
54103
{ js_string : bool option
55-
; effects : bool option
104+
; effects : effects_backend option
56105
; toplevel : bool option
57106
}
58107

59108
let default = { js_string = None; effects = None; toplevel = None }
60109
let bool_opt = [ None; Some true; Some false ]
110+
let effects_opt = [ None; Some Cps; Some Double_translation ]
61111

62112
let all =
63113
List.concat_map bool_opt ~f:(fun js_string ->
64-
List.concat_map bool_opt ~f:(fun effects ->
114+
List.concat_map effects_opt ~f:(fun effects ->
65115
List.concat_map bool_opt ~f:(fun toplevel -> [ { js_string; effects; toplevel } ])))
66116
;;
67117

68-
let get t =
69-
List.filter_map
70-
[ "use-js-string", t.js_string; "effects", t.effects; "toplevel", t.toplevel ]
71-
~f:(fun (n, v) ->
72-
match v with
73-
| None -> None
74-
| Some v -> Some (n, v))
118+
let enable name acc =
119+
match name with
120+
| "use-js-string" -> { acc with js_string = Some true }
121+
| "effects" ->
122+
(* [--enable effects], used alone, implies [--effects=cps] *)
123+
(match acc.effects with
124+
| None -> { acc with effects = Some Cps }
125+
| Some _ -> acc)
126+
| "toplevel" -> { acc with toplevel = Some true }
127+
| _ -> acc
75128
;;
76129

77-
let set acc name v =
130+
let disable name acc =
78131
match name with
79-
| "use-js-string" -> { acc with js_string = Some v }
80-
| "effects" -> { acc with effects = Some v }
81-
| "toplevel" -> { acc with toplevel = Some v }
132+
| "use-js-string" -> { acc with js_string = Some false }
133+
| "effects" -> { acc with effects = None }
134+
| "toplevel" -> { acc with toplevel = Some false }
82135
| _ -> acc
83136
;;
84137

138+
let string_of_effects = function
139+
| Cps -> "cps"
140+
| Double_translation -> "double-translation"
141+
;;
142+
85143
let path t =
86144
if t = default
87145
then "default"
88-
else
89-
List.map (get t) ~f:(function
90-
| x, true -> x
91-
| x, false -> "!" ^ x)
92-
|> String.concat ~sep:"+"
146+
else (
147+
let of_bool_opt key =
148+
Option.map ~f:(function
149+
| true -> key
150+
| false -> "!" ^ key)
151+
in
152+
List.filter_opt
153+
[ of_bool_opt "use-js-string" t.js_string
154+
; Option.map t.effects ~f:(fun e -> "effects=" ^ string_of_effects e)
155+
; of_bool_opt "toplevel" t.toplevel
156+
]
157+
|> String.concat ~sep:"+")
158+
;;
159+
160+
let effects_of_string = function
161+
| "cps" -> Some Cps
162+
| "double-translation" -> Some Double_translation
163+
| _ -> None
93164
;;
94165

95166
let of_string x =
96167
match x with
97168
| "default" -> default
98169
| _ ->
99170
List.fold_left (String.split ~on:'+' x) ~init:default ~f:(fun acc name ->
100-
match String.drop_prefix ~prefix:"!" name with
101-
| Some name -> set acc name false
102-
| None -> set acc name true)
171+
match
172+
String.drop_prefix ~prefix:"!" name, String.drop_prefix ~prefix:"effects=" name
173+
with
174+
| Some name, _ -> disable name acc
175+
| None, None -> enable name acc
176+
| None, Some backend ->
177+
(match effects_of_string backend with
178+
| Some backend -> { acc with effects = Some backend }
179+
| None -> acc))
103180
;;
104181

105182
let of_flags l =
106183
let rec loop acc = function
107184
| [] -> acc
108-
| "--enable" :: name :: rest -> loop (set acc name true) rest
185+
| "--enable" :: name :: rest -> loop (enable name acc) rest
109186
| maybe_enable :: rest when String.is_prefix maybe_enable ~prefix:"--enable=" ->
110187
(match String.drop_prefix maybe_enable ~prefix:"--enable=" with
111-
| Some name -> loop (set acc name true) rest
188+
| Some name -> loop (enable name acc) rest
112189
| _ -> assert false)
113-
| "--disable" :: name :: rest -> loop (set acc name false) rest
190+
| "--disable" :: name :: rest -> loop (disable name acc) rest
114191
| maybe_disable :: rest when String.is_prefix maybe_disable ~prefix:"--disable=" ->
115192
(match String.drop_prefix maybe_disable ~prefix:"--disable=" with
116-
| Some name -> loop (set acc name false) rest
193+
| Some name -> loop (disable name acc) rest
117194
| _ -> assert false)
118-
| "--toplevel" :: rest -> loop (set acc "toplevel" true) rest
195+
| "--toplevel" :: rest -> loop (enable "toplevel" acc) rest
196+
| "--effects" :: "cps" :: rest -> loop { acc with effects = Some Cps } rest
197+
| "--effects" :: "double-translation" :: rest ->
198+
loop { acc with effects = Some Double_translation } rest
199+
| maybe_effects :: rest when String.is_prefix maybe_effects ~prefix:"--effects=" ->
200+
let backend =
201+
Option.bind
202+
(String.drop_prefix maybe_effects ~prefix:"--effects=")
203+
~f:effects_of_string
204+
in
205+
(match backend with
206+
| Some backend -> loop { acc with effects = Some backend } rest
207+
| None -> loop acc rest)
119208
| _ :: rest -> loop acc rest
120209
in
121210
loop default l
122211
;;
123212

124-
let to_flags t =
125-
List.concat_map (get t) ~f:(function
126-
| "toplevel", true -> [ "--toplevel" ]
127-
| "toplevel", false -> []
128-
| name, true -> [ "--enable"; name ]
129-
| name, false -> [ "--disable"; name ])
130-
;;
131-
end
132-
133-
module Version = struct
134-
type t = int * int
135-
136-
let of_string s : t option =
137-
let s =
138-
match
139-
String.findi s ~f:(function
140-
| '+' | '-' | '~' -> true
141-
| _ -> false)
142-
with
143-
| None -> s
144-
| Some i -> String.take s i
145-
in
146-
try
147-
match String.split s ~on:'.' with
148-
| [] -> None
149-
| [ major ] -> Some (int_of_string major, 0)
150-
| major :: minor :: _ -> Some (int_of_string major, int_of_string minor)
151-
with
152-
| _ -> None
213+
let backward_compatible_effects ~jsoo_version str =
214+
match str with
215+
| None ->
216+
(* For jsoo, this means unsupported effects. For wasmoo, this means effects go
217+
through the Javascript Promise API. *)
218+
None
219+
| Some Cps ->
220+
let v6_or_higher =
221+
match jsoo_version with
222+
| Some v ->
223+
(match Version.compare v (6, 0) with
224+
| Gt | Eq -> true
225+
| Lt -> false)
226+
| None -> false
227+
in
228+
if v6_or_higher then Some "--effects=cps" else Some "--enable=effects"
229+
| Some Double_translation ->
230+
(* For js_of_ocaml < 6.0, this flag does not exist and will raise an error,
231+
which is fine. *)
232+
Some "--effects=double-translation"
153233
;;
154234

155-
let compare (ma1, mi1) (ma2, mi2) =
156-
match Int.compare ma1 ma2 with
157-
| Eq -> Int.compare mi1 mi2
158-
| n -> n
159-
;;
160-
161-
let impl_version bin =
162-
let* _ = Build_system.build_file bin in
163-
Memo.of_reproducible_fiber
164-
@@ Process.run_capture_line ~display:Quiet Strict bin [ "--version" ]
165-
|> Memo.map ~f:of_string
235+
let to_flags ~jsoo_version t =
236+
List.filter_opt
237+
[ (match t.toplevel with
238+
| Some true -> Some "--toplevel"
239+
| _ -> None)
240+
; backward_compatible_effects ~jsoo_version t.effects
241+
; (match t.js_string with
242+
| Some true -> Some "--enable=use-js-string"
243+
| Some false -> Some "--disable=use-js-string"
244+
| None -> None)
245+
]
166246
;;
167247

168-
let version_memo = Memo.create "jsoo-version" ~input:(module Path) impl_version
169-
170-
let jsoo_version jsoo =
171-
match jsoo with
172-
| Ok jsoo_path -> Memo.exec version_memo jsoo_path
173-
| Error e -> Action.Prog.Not_found.raise e
248+
let remove_config_flags flags =
249+
let rec loop acc = function
250+
| [] -> acc
251+
| "--enable" :: ("effects" | "use-js-string") :: rest -> loop acc rest
252+
| maybe_enable :: rest when String.is_prefix maybe_enable ~prefix:"--enable=" ->
253+
(match String.drop_prefix maybe_enable ~prefix:"--enable=" with
254+
| Some ("effects" | "use-js-string") -> loop acc rest
255+
| Some _ -> loop (maybe_enable :: acc) rest
256+
| None -> assert false)
257+
| "--disable" :: ("effects" | "use-js-string") :: rest -> loop acc rest
258+
| maybe_disable :: rest when String.is_prefix maybe_disable ~prefix:"--disable=" ->
259+
(match String.drop_prefix maybe_disable ~prefix:"--disable=" with
260+
| Some ("effects" | "use-js-string") -> loop acc rest
261+
| Some _ -> loop (maybe_disable :: acc) rest
262+
| None -> assert false)
263+
| "--effects" :: _backend :: rest -> loop acc rest
264+
| maybe_effects :: rest when String.is_prefix maybe_effects ~prefix:"--effects=" ->
265+
loop acc rest
266+
| "--toplevel" :: rest -> loop acc rest
267+
| other :: rest -> loop (other :: acc) rest
268+
in
269+
loop [] flags |> List.rev
174270
;;
175271
end
176272

@@ -259,6 +355,13 @@ let js_of_ocaml_rule
259355
| Link -> flags.link
260356
| Build_runtime -> flags.build_runtime
261357
in
358+
let flags =
359+
(* Avoid duplicating flags that are covered by the config *)
360+
Action_builder.map flags ~f:(fun flags ->
361+
match config with
362+
| None -> flags
363+
| Some _ -> Config.remove_config_flags flags)
364+
in
262365
Command.run_dyn_prog
263366
~dir:(Path.build dir)
264367
jsoo
@@ -280,9 +383,14 @@ let js_of_ocaml_rule
280383
| None -> S []
281384
| Some config ->
282385
Dyn
283-
(Action_builder.map config ~f:(fun config ->
284-
Command.Args.S
285-
(List.map (Config.to_flags config) ~f:(fun x -> Command.Args.A x)))))
386+
(let+ config = config
387+
and+ jsoo_version =
388+
let* jsoo = jsoo in
389+
Action_builder.of_memo (Version.jsoo_version jsoo)
390+
in
391+
Command.Args.S
392+
(List.map (Config.to_flags ~jsoo_version config) ~f:(fun x ->
393+
Command.Args.A x))))
286394
; A "-o"
287395
; Target target
288396
; spec

‎test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin1.ml‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
let name = "bin1"
2+
let hello name = print_endline ("Hi " ^ name)
3+
4+
let () = Library1.hello name
5+
6+
let () = hello Library1.name

‎test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin2.ml‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
let name = "bin2"
2+
let hello name = print_endline ("Hi " ^ name)
3+
4+
let () = Library1.hello name
5+
6+
let () = hello Library1.name

‎test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin3.ml‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
let name = "bin3"
2+
let hello name = print_endline ("Hi " ^ name)
3+
4+
let () = Library1.hello name
5+
6+
let () = hello Library1.name

‎test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/dune‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
(executable
2+
(name bin1)
3+
(modules bin1)
4+
(modes js)
5+
(libraries library1)
6+
(js_of_ocaml
7+
(flags (:standard --enable use-js-string))))
8+
9+
(executable
10+
(name bin2)
11+
(modules bin2)
12+
(modes js)
13+
(libraries library1)
14+
(js_of_ocaml
15+
(flags (:standard --disable use-js-string))))
16+
17+
(executable
18+
(name bin3)
19+
(modules bin3)
20+
(modes js)
21+
(libraries library1)
22+
(js_of_ocaml
23+
(flags (:standard --effects=cps))))

‎test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/dune‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
(env
2+
(_
3+
(js_of_ocaml
4+
(flags (:standard --quiet))
5+
(compilation_mode separate))))

‎test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/dune-project‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
(lang dune 3.0)

‎test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/lib/dune‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
(library
2+
(name library1)
3+
(js_of_ocaml
4+
;; This will be ignored as the library is compiled once for every effect
5+
;; config and then the version needed by each individual executable is used
6+
(flags (:standard --effects=double-translation))))

0 commit comments

Comments
 (0)