Revert some of #1769 for compatibility (#1828)

* Revert some of #1769 for compatibility * Fix CI
ocsigen · Feb 7, 2025 · b750638 · b750638
1 parent ce62a7d
commit b750638
Show file tree

Hide file tree

Showing 5 changed files with 34 additions and 17 deletions.
diff --git a/examples/hyperbolic/hypertree.ml b/examples/hyperbolic/hypertree.ml
@@ -543,14 +543,14 @@ let default_language () =
 
 let language =
   ref
-    (Js.Opt.get
-       (Html.window##.localStorage##getItem (Js.string "hyp_lang"))
-       default_language)
+    (Js.Optdef.case Html.window##.localStorage default_language (fun st ->
+         Js.Opt.get (st##getItem (Js.string "hyp_lang")) default_language))
 
 let _ = Console.console##log !language
 
 let set_language lang =
-  Html.window##.localStorage##setItem (Js.string "hyp_lang") lang;
+  Js.Optdef.iter Html.window##.localStorage (fun st ->
+      st##setItem (Js.string "hyp_lang") lang);
   language := lang
 
 let load_messages () =

diff --git a/lib/js_of_ocaml/dom_html.ml b/lib/js_of_ocaml/dom_html.ml
@@ -341,9 +341,9 @@ and keyboardEvent = object
 
   method location : int readonly_prop
 
-  method key : js_string t readonly_prop
+  method key : js_string t optdef readonly_prop
 
-  method code : js_string t readonly_prop
+  method code : js_string t optdef readonly_prop
 
   method isComposing : bool t readonly_prop
 
@@ -2351,9 +2351,9 @@ class type window = object
 
   method scrollBy : number_t -> number_t -> unit meth
 
-  method sessionStorage : storage t readonly_prop
+  method sessionStorage : storage t optdef readonly_prop
 
-  method localStorage : storage t readonly_prop
+  method localStorage : storage t optdef readonly_prop
 
   method top : window t readonly_prop
 
@@ -3368,6 +3368,10 @@ module Keyboard_code = struct
 
   let make_unidentified _ = Unidentified
 
+  let try_next value f = function
+    | Unidentified -> Optdef.case value make_unidentified f
+    | v -> v
+
   let run_next value f = function
     | Unidentified -> f value
     | v -> v
@@ -3383,8 +3387,9 @@ module Keyboard_code = struct
 
   let ( |> ) x f = f x
 
-  let of_event (evt : keyboardEvent Js.t) =
-    try_code evt##.code
+  let of_event evt =
+    Unidentified
+    |> try_next evt##.code try_code
     |> try_key_location evt
     |> run_next (get_key_code evt) try_key_code_normal
 
@@ -3397,10 +3402,12 @@ module Keyboard_key = struct
   let char_of_int value =
     if 0 < value then try Some (Uchar.of_int value) with _ -> None else None
 
+  let empty_string _ = Js.string ""
+
   let none _ = None
 
   let of_event evt =
-    let key = evt##.key in
+    let key = Optdef.get evt##.key empty_string in
     match key##.length with
     | 0 -> Optdef.case evt##.charCode none char_of_int
     | 1 -> char_of_int (int_of_float (Js.to_float (key##charCodeAt 0)))

diff --git a/lib/js_of_ocaml/dom_html.mli b/lib/js_of_ocaml/dom_html.mli
@@ -349,9 +349,12 @@ and keyboardEvent = object
 
   method location : int readonly_prop
 
-  method key : js_string t readonly_prop
+  (* Chrome can send fake keyboard events without any of the expected
+     properties (https://chromium-review.googlesource.com/771674), so
+     we keep the [optdef] annotation for now *)
+  method key : js_string t optdef readonly_prop
 
-  method code : js_string t readonly_prop
+  method code : js_string t optdef readonly_prop
 
   method isComposing : bool t readonly_prop
 
@@ -2201,9 +2204,13 @@ class type window = object
 
   method scrollBy : number_t -> number_t -> unit meth
 
-  method sessionStorage : storage t readonly_prop
+  (* These two properties are not available on non-Web environments
+     (for instance, Web workers, node). So we keep the [optdef]
+     annotation for now. *)
 
-  method localStorage : storage t readonly_prop
+  method sessionStorage : storage t optdef readonly_prop
+
+  method localStorage : storage t optdef readonly_prop
 
   method top : window t readonly_prop
 

diff --git a/tools/ci_setup.ml b/tools/ci_setup.ml
@@ -34,7 +34,6 @@ let forked_packages =
     ; "base_bigstring"
     ; "bin_prot"
     ; "bonsai_test"
-    ; "bonsai_web"
     ; "bonsai_web_components"
     ; "bonsai_web_test"
     ; "core"

diff --git a/toplevel/examples/lwt_toplevel/toplevel.ml b/toplevel/examples/lwt_toplevel/toplevel.ml
@@ -308,7 +308,11 @@ module History = struct
 
   let idx = ref 0
 
-  let get_storage () = Dom_html.window##.localStorage
+  let get_storage () =
+    match Js.Optdef.to_option Dom_html.window##.localStorage with
+    | exception _ -> raise Not_found
+    | None -> raise Not_found
+    | Some t -> t
 
   let setup () =
     try