CR

Signed-off-by: Olivier Nicole <[email protected]>

Author: OlivierNicole

src/dune_rules/jsoo/jsoo_rules.ml

@@ -41,6 +41,50 @@ let js_env = compute_env ~mode:JS
 let wasm_env = compute_env ~mode:Wasm
 let jsoo_env ~dir ~mode = (Js_of_ocaml.Mode.select ~mode ~js:js_env ~wasm:wasm_env) ~dir
 
+module Version = struct
+  type t = int * int
+
+  let of_string s : t option =
+    let s =
+      match
+        String.findi s ~f:(function
+          | '+' | '-' | '~' -> true
+          | _ -> false)
+      with
+      | None -> s
+      | Some i -> String.take s i
+    in
+    try
+      match String.split s ~on:'.' with
+      | [] -> None
+      | [ major ] -> Some (int_of_string major, 0)
+      | major :: minor :: _ -> Some (int_of_string major, int_of_string minor)
+    with
+    | _ -> None
+  ;;
+
+  let compare (ma1, mi1) (ma2, mi2) =
+    match Int.compare ma1 ma2 with
+    | Eq -> Int.compare mi1 mi2
+    | n -> n
+  ;;
+
+  let impl_version bin =
+    let* _ = Build_system.build_file bin in
+    Memo.of_reproducible_fiber
+    @@ Process.run_capture_line ~display:Quiet Strict bin [ "--version" ]
+    |> Memo.map ~f:of_string
+  ;;
+
+  let version_memo = Memo.create "jsoo-version" ~input:(module Path) impl_version
+
+  let jsoo_version jsoo =
+    match jsoo with
+    | Ok jsoo_path -> Memo.exec version_memo jsoo_path
+    | Error e -> Action.Prog.Not_found.raise e
+  ;;
+end
+
 module Config : sig
   type t
 
@@ -49,8 +93,7 @@ module Config : sig
   val of_string : string -> t
   val of_flags : string list -> t
 
-  (** [recent] should be true if jsoo version is 6.0 or higher. *)
-  val to_flags : recent:bool -> t -> string list
+  val to_flags : jsoo_version:Version.t option -> t -> string list
 end = struct
   type effects_backend =
     | Cps
@@ -72,21 +115,23 @@ end = struct
         List.concat_map bool_opt ~f:(fun toplevel -> [ { js_string; effects; toplevel } ])))
   ;;
 
-  let set acc name v =
-    match name, v with
-    | "use-js-string", `True -> { acc with js_string = Some true }
-    | "use-js-string", `False -> { acc with js_string = Some false }
-    | "effects", `Effects backend -> { acc with effects = Some backend }
-    | "effects", `False ->
-      (* [--disable effects] *)
-      { acc with effects = None }
-    | "effects", `True ->
+  let enable name acc =
+    match name with
+    | "use-js-string" -> { acc with js_string = Some true }
+    | "effects" ->
       (* [--enable effects], used alone, implies [--effects=cps] *)
       (match acc.effects with
        | None -> { acc with effects = Some Cps }
        | Some _ -> acc)
-    | "toplevel", `True -> { acc with toplevel = Some true }
-    | "toplevel", `False -> { acc with toplevel = Some false }
+    | "toplevel" -> { acc with toplevel = Some true }
+    | _ -> acc
+  ;;
+
+  let disable name acc =
+    match name with
+    | "use-js-string" -> { acc with js_string = Some false }
+    | "effects" -> { acc with effects = None }
+    | "toplevel" -> { acc with toplevel = Some false }
     | _ -> acc
   ;;
 
@@ -126,64 +171,73 @@ end = struct
         match
           String.drop_prefix ~prefix:"!" name, String.drop_prefix ~prefix:"effects=" name
         with
-        | Some name, _ -> set acc name `False
-        | None, None -> set acc name `True
+        | Some name, _ -> disable name acc
+        | None, None -> enable name acc
         | None, Some backend ->
           (match effects_of_string backend with
-           | Some backend -> set acc "effects" (`Effects backend)
+           | Some backend -> { acc with effects = Some backend }
            | None -> acc))
   ;;
 
   let of_flags l =
     let rec loop acc = function
       | [] -> acc
-      | "--enable" :: name :: rest -> loop (set acc name `True) rest
+      | "--enable" :: name :: rest -> loop (enable name acc) rest
       | maybe_enable :: rest when String.is_prefix maybe_enable ~prefix:"--enable=" ->
         (match String.drop_prefix maybe_enable ~prefix:"--enable=" with
-         | Some name -> loop (set acc name `True) rest
+         | Some name -> loop (enable name acc) rest
          | _ -> assert false)
-      | "--disable" :: name :: rest -> loop (set acc name `False) rest
+      | "--disable" :: name :: rest -> loop (disable name acc) rest
       | maybe_disable :: rest when String.is_prefix maybe_disable ~prefix:"--disable=" ->
         (match String.drop_prefix maybe_disable ~prefix:"--disable=" with
-         | Some name -> loop (set acc name `False) rest
+         | Some name -> loop (disable name acc) rest
          | _ -> assert false)
-      | "--toplevel" :: rest -> loop (set acc "toplevel" `True) rest
-      | "--effects" :: "cps" :: rest -> loop (set acc "effects" `Cps) rest
+      | "--toplevel" :: rest -> loop (enable "toplevel" acc) rest
+      | "--effects" :: "cps" :: rest -> loop { acc with effects = Some Cps } rest
       | "--effects" :: "double-translation" :: rest ->
-        loop (set acc "effects" `Double_translation) rest
+        loop { acc with effects = Some Double_translation } rest
       | maybe_effects :: rest when String.is_prefix maybe_effects ~prefix:"--effects=" ->
         let backend =
           Option.bind
             (String.drop_prefix maybe_effects ~prefix:"--effects=")
             ~f:effects_of_string
         in
         (match backend with
-         | Some backend -> set acc "effects" (`Effects backend)
+         | Some backend -> loop { acc with effects = Some backend } rest
          | None -> loop acc rest)
       | _ :: rest -> loop acc rest
     in
     loop default l
   ;;
 
-  let backward_compatible_effects ~recent str =
+  let backward_compatible_effects ~jsoo_version str =
     match str with
     | None ->
       (* For jsoo, this means unsupported effects. For wasmoo, this means effects go
          through the Javascript Promise API. *)
       None
-    | Some Cps -> if recent then Some "--effects=cps" else Some "--enable=effects"
+    | Some Cps ->
+        let v6_or_higher =
+          match jsoo_version with
+          | Some v ->
+            (match Version.compare v (6, 0) with
+             | Gt | Eq -> true
+             | Lt -> false)
+          | None -> false
+        in
+        if v6_or_higher then Some "--effects=cps" else Some "--enable=effects"
     | Some Double_translation ->
       (* For js_of_ocaml < 6.0, this flag does not exist and will raise an error,
          which is fine. *)
       Some "--effects=double-translation"
   ;;
 
-  let to_flags ~recent t =
+  let to_flags ~jsoo_version t =
     List.filter_opt
       [ (match t.toplevel with
          | Some true -> Some "--toplevel"
          | _ -> None)
-      ; backward_compatible_effects ~recent t.effects
+      ; backward_compatible_effects ~jsoo_version t.effects
       ; (match t.js_string with
          | Some true -> Some "--enable=use-js-string"
          | Some false -> Some "--disable=use-js-string"
@@ -192,50 +246,6 @@ end = struct
   ;;
 end
 
-module Version = struct
-  type t = int * int
-
-  let of_string s : t option =
-    let s =
-      match
-        String.findi s ~f:(function
-          | '+' | '-' | '~' -> true
-          | _ -> false)
-      with
-      | None -> s
-      | Some i -> String.take s i
-    in
-    try
-      match String.split s ~on:'.' with
-      | [] -> None
-      | [ major ] -> Some (int_of_string major, 0)
-      | major :: minor :: _ -> Some (int_of_string major, int_of_string minor)
-    with
-    | _ -> None
-  ;;
-
-  let compare (ma1, mi1) (ma2, mi2) =
-    match Int.compare ma1 ma2 with
-    | Eq -> Int.compare mi1 mi2
-    | n -> n
-  ;;
-
-  let impl_version bin =
-    let* _ = Build_system.build_file bin in
-    Memo.of_reproducible_fiber
-    @@ Process.run_capture_line ~display:Quiet Strict bin [ "--version" ]
-    |> Memo.map ~f:of_string
-  ;;
-
-  let version_memo = Memo.create "jsoo-version" ~input:(module Path) impl_version
-
-  let jsoo_version jsoo =
-    match jsoo with
-    | Ok jsoo_path -> Memo.exec version_memo jsoo_path
-    | Error e -> Action.Prog.Not_found.raise e
-  ;;
-end
-
 let install_jsoo_hint = "opam install js_of_ocaml-compiler"
 
 let in_build_dir (ctx : Build_context.t) ~config args =
@@ -342,16 +352,10 @@ let js_of_ocaml_rule
               let* jsoo = jsoo in
               Action_builder.of_memo (Version.jsoo_version jsoo)
             in
-            let recent =
-              match jsoo_version with
-              | Some v ->
-                (match Version.compare v (6, 0) with
-                 | Gt | Eq -> true
-                 | Lt -> false)
-              | None -> false
-            in
             Command.Args.S
-              (List.map (Config.to_flags ~recent config) ~f:(fun x -> Command.Args.A x))))
+              (List.map
+                (Config.to_flags ~jsoo_version config)
+                ~f:(fun x -> Command.Args.A x))))
     ; A "-o"
     ; Target target
     ; spec