Switch to Eio: manual changes

Author: balat

src/lib/eliom_bus.client.ml

@@ -34,37 +34,37 @@ type ('a, 'b) t =
   ; mutable max_size : int
   ; write : 'a list -> unit
   ; mutable waiter : unit -> unit
-  ; mutable last_wait : unit Promise.t
+  ; mutable last_wait : Switch.t option
   ; mutable original_stream_available : bool
-  ; error_h : 'b option Promise.t * exn Lwt.u }
+  ; error_h : 'b option Promise.or_exn * (exn, exn) result Promise.u }
 
 (* clone streams such that each clone of the original stream raise the same exceptions *)
 let consume (t, u) s =
-  let t' =
-    try Eliom_stream.iter (fun _ -> ()) s
+  let p, w = Promise.create () in
+  Eliom_lib.fork (fun () ->
+    try Promise.resolve_ok w (Eliom_stream.iter (fun _ -> ()) s)
     with e ->
-      (match Promise.peek t with None -> Lwt.wakeup_exn u e | _ -> ());
-      raise e
-  in
-  Fiber.any
-    (List.map
-       (fun p () -> Promise.await p)
-       (* TODO: ciao-lwt: The list [[ Lwt.bind t (fun _ -> Lwt.return_unit); t' ]] is expected to be a list of promises. Use [Fiber.fork_promise] to make a promise. *)
-       [ (let _ = t in
-          ())
-       ; t' ])
+      (match Promise.peek t with None -> Promise.resolve_error u e | _ -> ());
+      Promise.resolve_error w e);
+  Eliom_lib.fork (fun () ->
+    try Promise.resolve_ok w (ignore (Promise.await_exn t))
+    with e -> Promise.resolve_error w e);
+  Promise.await_exn p
 
 let clone_exn (t, u) s =
   let s' = Eliom_stream.clone s in
   Eliom_stream.from (fun () ->
     try
-      Fiber.any
-        (List.map
-           (fun p () -> Promise.await p)
-           (* TODO: ciao-lwt: The list [[ Eliom_stream.get s'; t ]] is expected to be a list of promises. Use [Fiber.fork_promise] to make a promise. *)
-           [Eliom_stream.get s'; t])
+      let p, w = Promise.create () in
+      Eliom_lib.fork (fun () ->
+        try Promise.resolve_ok w (Eliom_stream.get s')
+        with e -> Promise.resolve_error w e);
+      Eliom_lib.fork (fun () ->
+        try Promise.resolve_ok w (Promise.await_exn t)
+        with e -> Promise.resolve_error w e);
+      Promise.await_exn p
     with e ->
-      (match Promise.peek t with None -> Lwt.wakeup_exn u e | _ -> ());
+      (match Promise.peek t with None -> Promise.resolve_error u e | _ -> ());
       raise e)
 
 type ('a, 'att, 'co, 'ext, 'reg) callable_bus_service =
@@ -93,15 +93,16 @@ let create service channel waiter =
     with Eliom_request.Failed_request 204 -> ()
   in
   let error_h =
-    let t, u =
+    let t, (u : (exn, exn) result Promise.u) =
       Promise.create
         (* TODO: ciao-lwt: Translation is incomplete, [Promise.await] must be called on the promise when it's part of control-flow. *)
         ()
     in
+    let tt, uu = Promise.create () in
     ( (try
-         let _ = t in
+         ignore (Promise.await t);
          assert false
-       with e -> raise e)
+       with e -> Promise.resolve_error uu e; tt)
     , u )
   in
   let stream =
@@ -118,7 +119,7 @@ let create service channel waiter =
     ; max_size = 20
     ; write
     ; waiter
-    ; last_wait = ()
+    ; last_wait = None
     ; original_stream_available = true
     ; error_h }
   in
@@ -152,32 +153,26 @@ let flush t =
   let l = List.rev (Queue.fold (fun l v -> v :: l) [] t.queue) in
   Queue.clear t.queue; t.write l
 
+exception Cancelled
+
 let try_flush t =
-  Lwt.cancel
-    (* TODO: ciao-lwt: Use [Switch] or [Cancel] for defining a cancellable context. *)
-    (* TODO: ciao-lwt: Use [Switch] or [Cancel] for defining a cancellable context. *)
-    t.last_wait;
+  Option.iter (fun o -> Switch.fail o Cancelled) t.last_wait;
   if Queue.length t.queue >= t.max_size
   then flush t
   else
-    let th =
-      Lwt.protected
-        (* TODO: ciao-lwt: Use [Switch] or [Cancel] for defining a cancellable context. *)
-        (* TODO: ciao-lwt: Use [Switch] or [Cancel] for defining a cancellable context. *)
-        (t.waiter ())
-    in
-    t.last_wait <- th;
-    let _ = th; flush t in
-    ()
+    Eliom_lib.fork (fun () ->
+      Switch.run_protected (fun sw ->
+        (*VVV ???*)
+        t.last_wait <- Some sw;
+        t.waiter ());
+      flush t)
 
 let write t v = Queue.add v t.queue; try_flush t
 let close {channel; _} = Eliom_comet.close channel
 let set_queue_size b s = b.max_size <- s
 
 let set_time_before_flush b t =
   b.waiter <-
-    (if t <= 0.
-     then fun x1 -> Fiber.yield x1
-     else fun () -> Js_of_ocaml_eio.Eio_js.sleep t)
+    (if t <= 0. then Fiber.yield else fun () -> Js_of_ocaml_eio.Eio_js.sleep t)
 
 let force_link = ()

src/lib/eliom_client.client.ml

@@ -76,13 +76,13 @@ let run_onunload_wrapper set_content cancel =
       run_callbacks (flush_onunload ());
       set_content ()
 
-let lwt_onload () =
+let onload_promise () =
   let t, u =
     Promise.create
       (* TODO: ciao-lwt: Translation is incomplete, [Promise.await] must be called on the promise when it's part of control-flow. *)
       ()
   in
-  onload (fun x1 -> Promise.resolve u x1);
+  onload (fun () -> Promise.resolve u ());
   t
 
 (* == Initialize the client values sent with a request *)
@@ -432,11 +432,11 @@ let scroll_to_fragment ?offset fragment =
         let elem = Dom_html.document##(getElementById (Js.string fragment)) in
         Js.Opt.iter elem scroll_to_element)
 
-let with_progress_cursor : 'a Promise.t -> 'a =
- fun t ->
+let with_progress_cursor : (unit -> 'a) -> 'a =
+ fun f ->
   try
     Dom_html.document##.body##.style##.cursor := Js.string "progress";
-    let res = t in
+    let res = f () in
     Dom_html.document##.body##.style##.cursor := Js.string "auto";
     res
   with exn ->
@@ -698,7 +698,7 @@ let set_active_page p =
 
 (* This key serves as a hook to access the page the currently running code is
    generating. *)
-let this_page : page Lwt.key = Fiber.create_key ()
+let this_page : page Fiber.key = Fiber.create_key ()
 
 let get_this_page () =
   match Fiber.get this_page with
@@ -1442,23 +1442,24 @@ module Page_status = struct
     stop_event ?stop @@ React.E.map action @@ maybe_just_once ~once
     @@ Events.inactive ()
 
+  exception Cancelled
+
   let while_active ?now ?(stop = React.E.never) action =
-    let thread = ref () in
-    onactive ?now ~stop (fun () -> thread := action ());
-    oninactive ~stop (fun () ->
-      Lwt.cancel
-        (* TODO: ciao-lwt: Use [Switch] or [Cancel] for defining a cancellable context. *)
-        (* TODO: ciao-lwt: Use [Switch] or [Cancel] for defining a cancellable context. *)
-        !thread);
-    Dom_reference.retain_generic (get_this_page ())
-      ~keep:
-        (React.E.map
-           (fun () ->
-              Lwt.cancel
-                (* TODO: ciao-lwt: Use [Switch] or [Cancel] for defining a cancellable context. *)
-                (* TODO: ciao-lwt: Use [Switch] or [Cancel] for defining a cancellable context. *)
-                !thread)
-           stop)
+    let active_switch = ref None in
+    onactive ?now ~stop (fun () ->
+      Eio.Switch.run (fun sw ->
+        active_switch := Some sw;
+        Eio.Fiber.fork ~sw action);
+      oninactive ~stop (fun () ->
+        Option.iter (fun sw -> Eio.Switch.fail sw Cancelled) !active_switch);
+      Dom_reference.retain_generic (get_this_page ())
+        ~keep:
+          (React.E.map
+             (fun () ->
+                Option.iter
+                  (fun sw -> Eio.Switch.fail sw Cancelled)
+                  !active_switch)
+             stop))
 end
 
 let is_in_cache state_id =
@@ -1905,8 +1906,8 @@ and change_page :
       ~service ?hostname ?port ?fragment ?keep_nl_params ~nl_params
       ?keep_get_na_params get_params post_params
   else
-    with_progress_cursor
-      (match xhr with
+    with_progress_cursor (fun () ->
+      match xhr with
       | Some (Some tmpl as t)
         when t = Eliom_request_info.get_request_template () ->
           Logs.debug ~src:section_page (fun fmt ->
@@ -2042,29 +2043,28 @@ and reload_without_na_params ~replace ~uri ~fallback =
 (* Function used in "onclick" event handler of <a>.  *)
 let change_page_uri_a ?cookies_info ?tmpl ?(get_params = []) full_uri =
   Logs.debug ~src:section_page (fun fmt -> fmt "Change page uri");
-  with_progress_cursor
-    (let uri, fragment = Url.split_fragment full_uri in
-     if uri <> get_current_uri () || fragment = None
-     then (
-       if is_client_app ()
-       then failwith "Change_page_uri_a called on client app";
-       match tmpl with
-       | Some t when tmpl = Eliom_request_info.get_request_template () ->
-           let uri, content =
-             Eliom_request.http_get ?cookies_info uri
-               ((Eliom_request.nl_template_string, t) :: get_params)
-               Eliom_request.string_result
-           in
-           set_template_content ~replace:false ~uri ?fragment content
-       | _ ->
-           let uri, content =
-             Eliom_request.http_get ~expecting_process_page:true ?cookies_info
-               uri get_params Eliom_request.xml_result
-           in
-           set_content ~replace:false ~uri ?fragment content)
-     else (
-       change_url_string ~replace:true full_uri;
-       scroll_to_fragment fragment))
+  with_progress_cursor (fun () ->
+    let uri, fragment = Url.split_fragment full_uri in
+    if uri <> get_current_uri () || fragment = None
+    then (
+      if is_client_app () then failwith "Change_page_uri_a called on client app";
+      match tmpl with
+      | Some t when tmpl = Eliom_request_info.get_request_template () ->
+          let uri, content =
+            Eliom_request.http_get ?cookies_info uri
+              ((Eliom_request.nl_template_string, t) :: get_params)
+              Eliom_request.string_result
+          in
+          set_template_content ~replace:false ~uri ?fragment content
+      | _ ->
+          let uri, content =
+            Eliom_request.http_get ~expecting_process_page:true ?cookies_info
+              uri get_params Eliom_request.xml_result
+          in
+          set_content ~replace:false ~uri ?fragment content)
+    else (
+      change_url_string ~replace:true full_uri;
+      scroll_to_fragment fragment))
 
 let change_page_uri ?replace full_uri =
   Logs.debug ~src:section_page (fun fmt -> fmt "Change page uri");
@@ -2088,42 +2088,42 @@ let change_page_uri ?replace full_uri =
 (* Functions used in "onsubmit" event handler of <form>.  *)
 
 let change_page_get_form ?cookies_info ?tmpl form full_uri =
-  with_progress_cursor
-    (let form = Js.Unsafe.coerce form in
-     let uri, fragment = Url.split_fragment full_uri in
-     match tmpl with
-     | Some t when tmpl = Eliom_request_info.get_request_template () ->
-         let uri, content =
-           Eliom_request.send_get_form
-             ~get_args:[Eliom_request.nl_template_string, t]
-             ?cookies_info form uri Eliom_request.string_result
-         in
-         set_template_content ~replace:false ~uri ?fragment content
-     | _ ->
-         let uri, content =
-           Eliom_request.send_get_form ~expecting_process_page:true
-             ?cookies_info form uri Eliom_request.xml_result
-         in
-         set_content ~replace:false ~uri ?fragment content)
+  with_progress_cursor (fun () ->
+    let form = Js.Unsafe.coerce form in
+    let uri, fragment = Url.split_fragment full_uri in
+    match tmpl with
+    | Some t when tmpl = Eliom_request_info.get_request_template () ->
+        let uri, content =
+          Eliom_request.send_get_form
+            ~get_args:[Eliom_request.nl_template_string, t]
+            ?cookies_info form uri Eliom_request.string_result
+        in
+        set_template_content ~replace:false ~uri ?fragment content
+    | _ ->
+        let uri, content =
+          Eliom_request.send_get_form ~expecting_process_page:true ?cookies_info
+            form uri Eliom_request.xml_result
+        in
+        set_content ~replace:false ~uri ?fragment content)
 
 let change_page_post_form ?cookies_info ?tmpl form full_uri =
-  with_progress_cursor
-    (let form = Js.Unsafe.coerce form in
-     let uri, fragment = Url.split_fragment full_uri in
-     match tmpl with
-     | Some t when tmpl = Eliom_request_info.get_request_template () ->
-         let uri, content =
-           Eliom_request.send_post_form
-             ~get_args:[Eliom_request.nl_template_string, t]
-             ?cookies_info form uri Eliom_request.string_result
-         in
-         set_template_content ~replace:false ~uri ?fragment content
-     | _ ->
-         let uri, content =
-           Eliom_request.send_post_form ~expecting_process_page:true
-             ?cookies_info form uri Eliom_request.xml_result
-         in
-         set_content ~replace:false ~uri ?fragment content)
+  with_progress_cursor (fun () ->
+    let form = Js.Unsafe.coerce form in
+    let uri, fragment = Url.split_fragment full_uri in
+    match tmpl with
+    | Some t when tmpl = Eliom_request_info.get_request_template () ->
+        let uri, content =
+          Eliom_request.send_post_form
+            ~get_args:[Eliom_request.nl_template_string, t]
+            ?cookies_info form uri Eliom_request.string_result
+        in
+        set_template_content ~replace:false ~uri ?fragment content
+    | _ ->
+        let uri, content =
+          Eliom_request.send_post_form ~expecting_process_page:true
+            ?cookies_info form uri Eliom_request.xml_result
+        in
+        set_content ~replace:false ~uri ?fragment content)
 
 let _ =
   (Eliom_client_core.change_page_uri_ :=
@@ -2189,7 +2189,7 @@ let () =
       Js_of_ocaml_eio.Eio_js.start (fun () ->
         with_progress_cursor
         (* TODO: ciao-lwt: This computation might not be suspended correctly. *)
-        @@
+        @@ fun () ->
         let uri, fragment = Url.split_fragment full_uri in
         if uri = get_current_uri ()
         then (

src/lib/eliom_client.client.mli

@@ -272,7 +272,7 @@ val onload : (unit -> unit) -> unit
 
 *)
 
-val lwt_onload : unit -> unit
+val onload_promise : unit -> unit Eio.Promise.t
 (** Returns a Lwt thread that waits until the next page is loaded. *)
 
 type changepage_event =

src/lib/eliom_client_core.client.ml

@@ -273,14 +273,10 @@ let in_onload, broadcast_load_end, wait_load_end, set_loading_phase =
   let in_onload () = !loading_phase in
   let broadcast_load_end () =
     loading_phase := false;
-    Lwt_condition.broadcast load_end ()
+    Eio.Condition.broadcast load_end
   in
   let wait_load_end () =
-    if !loading_phase
-    then
-      Eio.Condition.await (* TODO: ciao-lwt: A mutex must be passed *) load_end
-        __mutex__
-    else ()
+    if !loading_phase then Eio.Condition.await_no_mutex load_end else ()
   in
   in_onload, broadcast_load_end, wait_load_end, set