Push stuff

dune

@@ -1 +1,6 @@
+(env
+ (dev
+  (flags
+   (:standard -w -27))))
+
 (dirs packages demo mocked-hash-js)

packages/react/src/react.ml

@@ -206,12 +206,18 @@ let createContext (initial_value : 'a) : 'a context =
 (* let memo f : 'props * 'props -> bool = f
    let memoCustomCompareProps f _compare : 'props * 'props -> bool = f *)
 
-let use (type a) promise =
-  let exception Suspend of a Lwt.t in
+(* `exception Suspend of 'a Lwt`
+    exceptions can't have type params, this is called existential wrapper *)
+type any_promise = Any_promise : 'a Lwt.t -> any_promise
+
+exception Suspend of any_promise
+
+let use promise =
   match Lwt.state promise with
-  | Sleep -> raise (Suspend promise)
-  | Return v -> v
+  | Sleep -> raise (Suspend (Any_promise promise))
+  (* TODO: Fail should raise a FailedSupense and catch at renderTo* *)
   | Fail e -> raise e
+  | Return v -> v
 
 let useContext context = context.current_value.contents
 

packages/react/src/react.mli

@@ -53,6 +53,7 @@ type lower_case_element = {
   children : element list;
 }
 
+(* TODO: add `component = (unit -> element)`  *)
 and element =
   | Lower_case_element of lower_case_element
   | Upper_case_component of (unit -> element)
@@ -89,6 +90,10 @@ type 'a context = {
 
 val createContext : 'a -> 'a context
 
+type any_promise = Any_promise : 'a Lwt.t -> any_promise
+
+exception Suspend of any_promise
+
 (* val memo : ('props * 'props -> bool) -> 'a -> 'props * 'props -> bool *)
 val use : 'a Lwt.t -> 'a
 val useContext : 'a context -> 'a

packages/reactDom/src/reactDOM.ml

@@ -148,87 +148,76 @@ let renderToStaticMarkup element =
   (* TODO: try catch to avoid React.use usages *)
   render_tree_to_string ~mode:Markup element
 
-let render_to_stream element =
-  let buff = Buffer.create 16 in
-  let push = Buffer.add_string buff in
+module Stream = struct
+  let create () =
+    let stream, push_to_stream = Lwt_stream.create () in
+    let push v = push_to_stream @@ Some v in
+    let close () = push_to_stream @@ None in
+    (stream, push, close)
+end
+
+type context_state = {
+  stream : string Lwt_stream.t;
+  push : string -> unit;
+  close : unit -> unit;
+  mutable waiting : int;
+}
+
+let render_to_stream ~context_state element =
   let rec render_inner element =
     match element with
-    | Empty -> push ""
+    | Empty -> ""
     | Provider childrens ->
-        childrens |> List.map (fun f -> f ()) |> List.iter render_inner
-    | Consumer children -> children () |> List.iter render_inner
+        childrens |> List.map (fun f -> render_inner (f ())) |> String.concat ""
+    | Consumer children ->
+        children () |> List.map render_inner |> String.concat ""
     | Fragment children -> render_inner children
-    | List list -> list |> Array.iter render_inner
-    | Upper_case_component f -> render_inner (f ())
+    | List arr ->
+        arr |> Array.to_list |> List.map render_inner |> String.concat ""
+    | Upper_case_component component -> (
+        print_endline "Upper_case_component";
+        let element =
+          try Some (component ()) with
+          | React.Suspend (Any_promise promise) ->
+              print_endline "| React.Suspend (Any_promise promise) ->";
+              context_state.waiting <- context_state.waiting + 1;
+              Lwt.map
+                (fun _ ->
+                  context_state.push (render_inner element);
+                  context_state.waiting <- context_state.waiting - 1;
+                  if context_state.waiting = 0 then context_state.close ()
+                  else ())
+                promise
+              |> Lwt.ignore_result;
+              None
+          | e -> raise e
+        in
+        match element with Some element -> render_inner element | None -> "")
     | Lower_case_element { tag; attributes; _ }
       when Html.is_self_closing_tag tag ->
-        push "<";
-        push tag;
-        push (attributes_to_string tag attributes);
-        push " />"
+        Printf.sprintf "<%s%s />" tag (attributes_to_string tag attributes)
     | Lower_case_element { tag; attributes; children } ->
-        push "<";
-        push tag;
-        push (attributes_to_string tag attributes);
-        push ">";
-        children |> List.iter render_inner;
-        push "</";
-        push tag;
-        push ">"
-    | Text text -> push (Html.encode text)
-    | InnerHtml text -> push text
+        Printf.sprintf "<%s%s>%s</%s>" tag
+          (attributes_to_string tag attributes)
+          (children |> List.map render_inner |> String.concat "")
+          tag
+    | Text text -> Html.encode text
+    | InnerHtml text -> text
     | Suspense { children; _ } ->
-        push "<!--$-->";
-        children |> List.iter render_inner;
-        push "<!--/$-->"
+        Printf.sprintf "<!--$-->%s<!--/$-->"
+          (children |> List.map render_inner |> String.concat "")
   in
-  render_inner element;
-  buff |> Buffer.contents
-
-let renderToLwtStream _element =
-  let stream, _push = Lwt_stream.create () in
-  let abort () =
-    (* TODO: Needs to flush the remaining loading fallbacks as HTML, and will attempt to render the rest on the client. *)
-    Lwt_stream.closed stream |> Lwt.ignore_result
-  in
-
-  (*
-      const request = createRequestImpl(children, options);
-      (* createRequestImpl ??? *)
-
-      let hasStartedFlowing = false;
-      startWork(request);
-      (* startWork ??? *)
-
-      let pipe = (destination) => {
-        hasStartedFlowing = true;
-        startFlowing(request, destination);
-        (* startFlowing ??? *)
-        destination.on('drain', createDrainHandler(destination, request));
-        (* createDrainHandler ??? *)
-
-        destination.on(
-          'error',
-          createAbortHandler(
-            request,
-            'The destination stream errored while writing data.',
-          ),
-        );
-        (* createAbortHandler ??? *)
-
-        destination.on(
-          'close',
-          createAbortHandler(request, 'The destination stream closed early.'),
-        );
-        return destination;
-      };
-
-      return {
-        pipe, abort
-      }
-  *)
-
-  (* let () = push (Some (render_to_stream element)) in *)
+  render_inner element
+
+let renderToLwtStream element =
+  print_endline "renderToLwtStream";
+  let stream, push, close = Stream.create () in
+  let context_state = { stream; push; close; waiting = 0 } in
+  let shell = render_to_stream ~context_state element in
+  push shell;
+  if context_state.waiting = 0 then close ();
+  (* TODO: Needs to flush the remaining loading fallbacks as HTML, and will attempt to render the rest on the client. *)
+  let abort () = (* Lwt_stream.closed stream |> Lwt.ignore_result *) () in
   (stream, abort)
 
 let querySelector _str = None

packages/reactDom/test/test_renderToLwtStream.ml

@@ -1,28 +1,40 @@
 let assert_string left right =
   Alcotest.check Alcotest.string "should be equal" right left
 
+let assert_list ty left right =
+  Alcotest.check (Alcotest.list ty) "should be equal" right left
+
 let make ~delay =
   let () = React.use (Lwt_unix.sleep delay) in
   React.createElement "div" [||]
     [
       React.createElement "span" [||]
-        [ React.string "Hello"; React.string "Hello" ];
+        [ React.string "Hello"; React.float delay ];
     ]
 
-let cleanup switch abort =
-  let free () = Lwt.return () in
-  Lwt_switch.add_hook (Some switch) free;
-  Lwt.async (fun () ->
-      abort ();
-      failwith "All is broken");
-  Lwt.return ()
+let assert_stream (stream : string Lwt_stream.t) expected =
+  let open Lwt.Infix in
+  Lwt_stream.to_list stream >>= fun content ->
+  if content = [] then Lwt.return @@ Alcotest.fail "stream should not be empty"
+  else Lwt.return @@ assert_list Alcotest.string content expected
 
-let suspense_one switch () =
-  let _pipe, abort = ReactDOM.renderToLwtStream (make ~delay:0.1) in
+let test_silly_stream _switch () : unit Lwt.t =
+  let stream, push = Lwt_stream.create () in
+  push (Some "first");
+  push (Some "secondo");
+  push None;
+  assert_stream stream [ "first"; "secondo" ]
 
-  assert_string "asdf"
-    "<div data-reactroot=\"\"><span>Hello<!-- -->Hello</span></div>";
-  cleanup switch abort
+let suspense_one _switch () : unit Lwt.t =
+  let timer = React.Upper_case_component (fun () -> make ~delay:0.1) in
+  let stream, _abort = ReactDOM.renderToLwtStream timer in
+  assert_stream stream [ "Hello"; "1." ]
 
 let case title fn = Alcotest_lwt.test_case title `Quick fn
-let tests = ("renderToLwtStream", [ case "suspense_one" suspense_one ])
+
+let tests =
+  ( "renderToLwtStream",
+    [
+      case "test_silly_stream" test_silly_stream;
+      case "suspense_one" suspense_one;
+    ] )