diff --git a/dune b/dune index 168c980ca..fe670d9b1 100644 --- a/dune +++ b/dune @@ -1 +1,6 @@ +(env + (dev + (flags + (:standard -w -27)))) + (dirs packages demo mocked-hash-js) diff --git a/packages/react/src/react.ml b/packages/react/src/react.ml index c4c7a5454..bcc27c2ec 100644 --- a/packages/react/src/react.ml +++ b/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 diff --git a/packages/react/src/react.mli b/packages/react/src/react.mli index 27698851a..35831d848 100644 --- a/packages/react/src/react.mli +++ b/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 diff --git a/packages/reactDom/src/reactDOM.ml b/packages/reactDom/src/reactDOM.ml index 47d0d3820..8da89b205 100644 --- a/packages/reactDom/src/reactDOM.ml +++ b/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 "" - | Text text -> push (Html.encode text) - | InnerHtml text -> push text + Printf.sprintf "<%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 diff --git a/packages/reactDom/test/test_renderToLwtStream.ml b/packages/reactDom/test/test_renderToLwtStream.ml index 23d6b9801..b9c89a7e8 100644 --- a/packages/reactDom/test/test_renderToLwtStream.ml +++ b/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" - "
HelloHello
"; - 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; + ] )