From b7506383243d3ecd2f7ef447028e4822782678d2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= <jerome.vouillon@gmail.com>
Date: Wed, 5 Feb 2025 16:57:59 +0100
Subject: [PATCH] Revert some of #1769 for compatibility (#1828)

* Revert some of #1769 for compatibility

* Fix CI
---
 examples/hyperbolic/hypertree.ml           |  8 ++++----
 lib/js_of_ocaml/dom_html.ml                | 21 ++++++++++++++-------
 lib/js_of_ocaml/dom_html.mli               | 15 +++++++++++----
 tools/ci_setup.ml                          |  1 -
 toplevel/examples/lwt_toplevel/toplevel.ml |  6 +++++-
 5 files changed, 34 insertions(+), 17 deletions(-)

diff --git a/examples/hyperbolic/hypertree.ml b/examples/hyperbolic/hypertree.ml
index cbfc1a14e2..499519c041 100644
--- 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
index 704c6c3410..20d9cd582a 100644
--- 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
index eb1bf41d0d..1fcf0cc7e8 100644
--- 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
index 3156fbd0c3..31d9fdc592 100644
--- 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
index fc201a8947..58b2234dec 100644
--- 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