Source file React.ml

type 'value ref = { mutable current : 'value }
type domRef = CallbackDomRef of (Dom.element Js.nullable -> unit) | CurrentDomRef of Dom.element Js.nullable ref

module Ref = struct
  type t = domRef
  type currentDomRef = Dom.element Js.nullable ref
  type callbackDomRef = Dom.element Js.nullable -> unit

  let domRef (v : currentDomRef) = CurrentDomRef v
  let callbackDomRef (v : callbackDomRef) = CallbackDomRef v
end

let createRef () = { current = None }
let useRef value = { current = value }
let forwardRef f = f ()

module Event = struct
  type 'a synthetic

  type target_like =
    < checked : bool
    ; className : string
    ; id : string
    ; innerHTML : string
    ; name : string
    ; tagName : string
    ; textContent : string
    ; value : string >

  let fail name = Runtime.fail_impossible_action_in_ssr ("React.Event." ^ name)

  module MakeEventWithType (Type : sig
    type t
  end) =
  struct
    let bubbles : Type.t -> bool = fun _ -> fail "bubbles"
    let cancelable : Type.t -> bool = fun _ -> fail "cancelable"
    let currentTarget : Type.t -> target_like = fun _ -> fail "currentTarget"
    let defaultPrevented : Type.t -> bool = fun _ -> fail "defaultPrevented"
    let eventPhase : Type.t -> int = fun _ -> fail "eventPhase"
    let isTrusted : Type.t -> bool = fun _ -> fail "isTrusted"
    let nativeEvent : Type.t -> target_like = fun _ -> fail "nativeEvent"
    let preventDefault : Type.t -> unit = fun _ -> fail "preventDefault"
    let isDefaultPrevented : Type.t -> bool = fun _ -> fail "isDefaultPrevented"
    let stopPropagation : Type.t -> unit = fun _ -> fail "stopPropagation"
    let isPropagationStopped : Type.t -> bool = fun _ -> fail "isPropagationStopped"
    let target : Type.t -> target_like = fun _ -> fail "target"
    let timeStamp : Type.t -> float = fun _ -> fail "timeStamp"
    let type_ : Type.t -> string = fun _ -> fail "type_"
    let persist : Type.t -> unit = fun _ -> fail "persist"
  end

  module Synthetic = struct
    type tag
    type t = tag synthetic

    let bubbles : 'a synthetic -> bool = fun _ -> fail "Synthetic.bubbles"
    let cancelable : 'a synthetic -> bool = fun _ -> fail "Synthetic.cancelable"
    let currentTarget : 'a synthetic -> target_like = fun _ -> fail "Synthetic.currentTarget"
    let defaultPrevented : 'a synthetic -> bool = fun _ -> fail "Synthetic.defaultPrevented"
    let eventPhase : 'a synthetic -> int = fun _ -> fail "Synthetic.eventPhase"
    let isTrusted : 'a synthetic -> bool = fun _ -> fail "Synthetic.isTrusted"
    let nativeEvent : 'a synthetic -> target_like = fun _ -> fail "Synthetic.nativeEvent"
    let preventDefault : 'a synthetic -> unit = fun _ -> fail "Synthetic.preventDefault"
    let isDefaultPrevented : 'a synthetic -> bool = fun _ -> fail "Synthetic.isDefaultPrevented"
    let stopPropagation : 'a synthetic -> unit = fun _ -> fail "Synthetic.stopPropagation"
    let isPropagationStopped : 'a synthetic -> bool = fun _ -> fail "Synthetic.isPropagationStopped"
    let target : 'a synthetic -> target_like = fun _ -> fail "Synthetic.target"
    let timeStamp : 'a synthetic -> float = fun _ -> fail "Synthetic.timeStamp"
    let type_ : 'a synthetic -> string = fun _ -> fail "Synthetic.type_"
    let persist : 'a synthetic -> unit = fun _ -> fail "Synthetic.persist"
  end

  (* let toSyntheticEvent : 'a synthetic -> Synthetic.t = i -> i *)

  module Clipboard = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let clipboardData : t -> target_like = fun _ -> fail "Clipboard.clipboardData"
  end

  module Composition = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let data : t -> string = fun _ -> fail "Composition.data"
  end

  module Keyboard = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let altKey : t -> bool = fun _ -> fail "Keyboard.altKey"
    let charCode : t -> int = fun _ -> fail "Keyboard.charCode"
    let ctrlKey : t -> bool = fun _ -> fail "Keyboard.ctrlKey"
    let getModifierState : t -> string -> bool = fun _ _ -> fail "Keyboard.getModifierState"
    let key : t -> string = fun _ -> fail "Keyboard.key"
    let keyCode : t -> int = fun _ -> fail "Keyboard.keyCode"
    let locale : t -> string = fun _ -> fail "Keyboard.locale"
    let location : t -> int = fun _ -> fail "Keyboard.location"
    let metaKey : t -> bool = fun _ -> fail "Keyboard.metaKey"
    let repeat : t -> bool = fun _ -> fail "Keyboard.repeat"
    let shiftKey : t -> bool = fun _ -> fail "Keyboard.shiftKey"
    let which : t -> int = fun _ -> fail "Keyboard.which"
  end

  module Focus = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let relatedTarget : t -> target_like option = fun _ -> fail "Focus.relatedTarget"
  end

  module Form = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)
  end

  module Mouse = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let altKey : t -> bool = fun _ -> fail "Mouse.altKey"
    let button : t -> int = fun _ -> fail "Mouse.button"
    let buttons : t -> int = fun _ -> fail "Mouse.buttons"
    let clientX : t -> int = fun _ -> fail "Mouse.clientX"
    let clientY : t -> int = fun _ -> fail "Mouse.clientY"
    let ctrlKey : t -> bool = fun _ -> fail "Mouse.ctrlKey"
    let getModifierState : t -> string -> bool = fun _ _ -> fail "Mouse.getModifierState"
    let metaKey : t -> bool = fun _ -> fail "Mouse.metaKey"
    let movementX : t -> int = fun _ -> fail "Mouse.movementX"
    let movementY : t -> int = fun _ -> fail "Mouse.movementY"
    let pageX : t -> int = fun _ -> fail "Mouse.pageX"
    let pageY : t -> int = fun _ -> fail "Mouse.pageY"
    let relatedTarget : t -> target_like option = fun _ -> fail "Mouse.relatedTarget"
    let screenX : t -> int = fun _ -> fail "Mouse.screenX"
    let screenY : t -> int = fun _ -> fail "Mouse.screenY"
    let shiftKey : t -> bool = fun _ -> fail "Mouse.shiftKey"
  end

  module Pointer = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let detail : t -> int = fun _ -> fail "Pointer.detail"

    (* let view : t -> Dom.window *)
    let screenX : t -> int = fun _ -> fail "Pointer.screenX"
    let screenY : t -> int = fun _ -> fail "Pointer.screenY"
    let clientX : t -> int = fun _ -> fail "Pointer.clientX"
    let clientY : t -> int = fun _ -> fail "Pointer.clientY"
    let pageX : t -> int = fun _ -> fail "Pointer.pageX"
    let pageY : t -> int = fun _ -> fail "Pointer.pageY"
    let movementX : t -> int = fun _ -> fail "Pointer.movementX"
    let movementY : t -> int = fun _ -> fail "Pointer.movementY"
    let ctrlKey : t -> bool = fun _ -> fail "Pointer.ctrlKey"
    let shiftKey : t -> bool = fun _ -> fail "Pointer.shiftKey"
    let altKey : t -> bool = fun _ -> fail "Pointer.altKey"
    let metaKey : t -> bool = fun _ -> fail "Pointer.metaKey"
    let getModifierState : t -> string -> bool = fun _ _ -> fail "Pointer.getModifierState"
    let button : t -> int = fun _ -> fail "Pointer.button"
    let buttons : t -> int = fun _ -> fail "Pointer.buttons"
    let relatedTarget : t -> target_like option = fun _ -> fail "Pointer.relatedTarget"

    (* let pointerId : t -> Dom.eventPointerId *)
    let width : t -> float = fun _ -> fail "Pointer.width"
    let height : t -> float = fun _ -> fail "Pointer.height"
    let pressure : t -> float = fun _ -> fail "Pointer.pressure"
    let tangentialPressure : t -> float = fun _ -> fail "Pointer.tangentialPressure"
    let tiltX : t -> int = fun _ -> fail "Pointer.tiltX"
    let tiltY : t -> int = fun _ -> fail "Pointer.tiltY"
    let twist : t -> int = fun _ -> fail "Pointer.twist"
    let pointerType : t -> string = fun _ -> fail "Pointer.pointerType"
    let isPrimary : t -> bool = fun _ -> fail "Pointer.isPrimary"
  end

  module Selection = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)
  end

  module Touch = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let altKey : t -> bool = fun _ -> fail "Touch.altKey"
    let changedTouches : t -> target_like = fun _ -> fail "Touch.changedTouches"
    let ctrlKey : t -> bool = fun _ -> fail "Touch.ctrlKey"
    let getModifierState : t -> string -> bool = fun _ _ -> fail "Touch.getModifierState"
    let metaKey : t -> bool = fun _ -> fail "Touch.metaKey"
    let shiftKey : t -> bool = fun _ -> fail "Touch.shiftKey"
    let targetTouches : t -> target_like = fun _ -> fail "Touch.targetTouches"
    let touches : t -> target_like = fun _ -> fail "Touch.touches"
  end

  module UI = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let detail : t -> int = fun _ -> fail "UI.detail"
    (* let view : t -> Dom.window *)
  end

  module Wheel = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let deltaMode : t -> int = fun _ -> fail "Wheel.deltaMode"
    let deltaX : t -> float = fun _ -> fail "Wheel.deltaX"
    let deltaY : t -> float = fun _ -> fail "Wheel.deltaY"
    let deltaZ : t -> float = fun _ -> fail "Wheel.deltaZ"
  end

  module Media = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)
  end

  module Image = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)
  end

  module Animation = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let animationName : t -> string = fun _ -> fail "Animation.animationName"
    let pseudoElement : t -> string = fun _ -> fail "Animation.pseudoElement"
    let elapsedTime : t -> float = fun _ -> fail "Animation.elapsedTime"
  end

  module Transition = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let propertyName : t -> string = fun _ -> fail "Transition.propertyName"
    let pseudoElement : t -> string = fun _ -> fail "Transition.pseudoElement"
    let elapsedTime : t -> float = fun _ -> fail "Transition.elapsedTime"
  end

  module Drag = struct
    type tag
    type t = tag synthetic

    include MakeEventWithType (struct
      type nonrec t = t [@@nonrec]
    end)

    let altKey : t -> bool = fun _ -> fail "Drag.altKey"
    let button : t -> int = fun _ -> fail "Drag.button"
    let buttons : t -> int = fun _ -> fail "Drag.buttons"
    let clientX : t -> int = fun _ -> fail "Drag.clientX"
    let clientY : t -> int = fun _ -> fail "Drag.clientY"
    let ctrlKey : t -> bool = fun _ -> fail "Drag.ctrlKey"
    let getModifierState : t -> string -> bool = fun _ _ -> fail "Drag.getModifierState"
    let metaKey : t -> bool = fun _ -> fail "Drag.metaKey"
    let movementX : t -> int = fun _ -> fail "Drag.movementX"
    let movementY : t -> int = fun _ -> fail "Drag.movementY"
    let pageX : t -> int = fun _ -> fail "Drag.pageX"
    let pageY : t -> int = fun _ -> fail "Drag.pageY"
    let relatedTarget : t -> target_like option = fun _ -> fail "Drag.relatedTarget"
    let screenX : t -> int = fun _ -> fail "Drag.screenX"
    let screenY : t -> int = fun _ -> fail "Drag.screenY"
    let shiftKey : t -> bool = fun _ -> fail "Drag.shiftKey"
    let dataTransfer : t -> target_like = fun _ -> fail "Drag.dataTransfer"
  end
end

module JSX = struct
  type event =
    | Drag of (Event.Drag.t -> unit)
    | Mouse of (Event.Mouse.t -> unit)
    | Selection of (Event.Selection.t -> unit)
    | Touch of (Event.Touch.t -> unit)
    | UI of (Event.UI.t -> unit)
    | Wheel of (Event.Wheel.t -> unit)
    | Clipboard of (Event.Clipboard.t -> unit)
    | Composition of (Event.Composition.t -> unit)
    | Transition of (Event.Transition.t -> unit)
    | Animation of (Event.Animation.t -> unit)
    | Pointer of (Event.Pointer.t -> unit)
    | Keyboard of (Event.Keyboard.t -> unit)
    | Focus of (Event.Focus.t -> unit)
    | Form of (Event.Form.t -> unit)
    | Media of (Event.Media.t -> unit)
    | Inline of string

  type prop =
    | Action : (string * string * _ Runtime.server_function) -> prop
    | Bool of (string * string * bool)
    | BooleanishString of (string * string * bool)
    | String of (string * string * string)
    | Int of (string * string * int)
    | Float of (string * string * float)
    | Style of (string * string * string) list
    | DangerouslyInnerHtml of string
    | Ref of Ref.t
    | Event of string * event

  let bool name jsxName value = Bool (name, jsxName, value)
  let booleanishString name jsxName value = BooleanishString (name, jsxName, value)
  let string name jsxName value = String (name, jsxName, value)
  let style value = Style value
  let int name jsxName value = Int (name, jsxName, value)
  let float name jsxName value = Float (name, jsxName, value)
  let dangerouslyInnerHtml value = DangerouslyInnerHtml value#__html
  let ref value = Ref value
  let event key value = Event (key, value)

  module Event = struct
    let drag key value = event key (Drag value)
    let mouse key value = event key (Mouse value)
    let selection key value = event key (Selection value)
    let touch key value = event key (Touch value)
    let ui key value = event key (UI value)
    let wheel key value = event key (Wheel value)
    let clipboard key value = event key (Clipboard value)
    let composition key value = event key (Composition value)
    let transition key value = event key (Transition value)
    let animation key value = event key (Animation value)
    let pointer key value = event key (Pointer value)
    let keyboard key value = event key (Keyboard value)
    let focus key value = event key (Focus value)
    let form key value = event key (Form value)
    let media key value = event key (Media value)
  end
end

type error = { message : string; stack : Yojson.Basic.t; env : string; digest : string }

module Model = struct
  type 'element t =
    | Function : 'server_function Runtime.server_function -> 'element t
    | List : 'element t list -> 'element t
    | Assoc : (string * 'element t) list -> 'element t
    | Json : Yojson.Basic.t -> 'element t
    | Error : error -> 'element t
    | Element : 'element -> 'element t
    | Promise : 'a Js.Promise.t * ('a -> 'element t) -> 'element t
end

type ('props, 'return) componentLike = ?key:string -> 'props -> 'return

and element =
  | Lower_case_element of lower_case_element
  | Upper_case_component of string * (unit -> element)
  | Async_component of string * (unit -> element Lwt.t)
  | Client_component of {
      key : string option;
      props : client_props;
      client : element;
      import_module : string;
      import_name : string;
    }
  | List of element list
  | Array of element array
  | Text of string
  | Int of int
  | Float of float
  | Static of { prerendered : string; original : element }
  | Writer of { emit : Buffer.t -> separators:bool -> unit; original : unit -> element }
      (** Like [Static] but writes directly into the caller's buffer. Used by the PPX for subtrees with static skeleton
          \+ dynamic string/int/float holes (the [Needs_string_concat] and [Needs_buffer] tiers).

          [separators] tells the emit function whether adjacent text nodes must be delimited with an [<!-- -->] comment,
          matching react-dom: [renderToString] needs the delimiters so hydration can split merged text nodes,
          [renderToStaticMarkup] must not emit them.

          [original] is a thunk that rebuilds the variant-tree form on-demand for [cloneElement] and RSC consumers. Same
          name as [Static.original] for symmetry; [Writer]'s version is lazy so the render-to-string fast path pays no
          allocation for the fallback. *)
  | Fragment of element
  | Empty
  | Provider of { children : element; push : unit -> unit -> unit; async_key : Obj.t Lwt.key; async_value : Obj.t }
  | Consumer of element
  | Suspense of { key : string option; children : element; fallback : element option }

and lower_case_element = { key : string option; tag : string; attributes : JSX.prop list; children : element list }
and client_props = (string * element Model.t) list
and model_value = element Model.t

exception Invalid_children of string

let prop_key (prop : JSX.prop) =
  match prop with
  | Bool (name, _, _) -> name
  | BooleanishString (name, _, _) -> name
  | String (name, _, _) -> name
  | Int (name, _, _) -> name
  | Float (name, _, _) -> name
  | Action (name, _, _) -> name
  | Style _ -> "style"
  | DangerouslyInnerHtml _ -> "dangerouslySetInnerHTML"
  | Ref _ -> "ref"
  | Event (name, _) -> name

(* Merges attributes following JS object-spread semantics ([{...attributes, ...new_attributes}]): base attributes keep
   their original order and are replaced in place when a new attribute shares their key; new attributes with unseen
   keys are appended in their original order. If the same key appears multiple times in [new_attributes], the last
   occurrence wins. O(n²) over List, which is fine: attribute lists are small and [cloneElement] is rare. *)
let clone_attributes (attributes : JSX.prop list) (new_attributes : JSX.prop list) =
  let key_equals key prop = String.equal (prop_key prop) key in
  let last_new_with_key key =
    List.fold_left (fun acc prop -> if key_equals key prop then Some prop else acc) None new_attributes
  in
  let base =
    List.map
      (fun attr -> match last_new_with_key (prop_key attr) with Some replacement -> replacement | None -> attr)
      attributes
  in
  let rec append_new seen props =
    match props with
    | [] -> []
    | prop :: rest ->
        let key = prop_key prop in
        if List.exists (key_equals key) attributes || List.mem key seen then append_new seen rest
        else
          let winner = match last_new_with_key key with Some last -> last | None -> prop in
          winner :: append_new (key :: seen) rest
  in
  base @ append_new [] new_attributes

let create_element_with_key ?key tag attributes children =
  match Html.is_self_closing_tag tag with
  | true when List.length children > 0 ->
      raise (Invalid_children (Printf.sprintf {|"%s" is a self-closing tag and must not have "children".\n|} tag))
  | true when List.exists (function JSX.DangerouslyInnerHtml _ -> true | _ -> false) attributes ->
      raise
        (Invalid_children
           (Printf.sprintf {|"%s" is a self-closing tag and must not have "dangerouslySetInnerHTML".\n|} tag))
  | true -> Lower_case_element { key; tag; attributes; children = [] }
  | false -> Lower_case_element { key; tag; attributes; children }

let createElement = create_element_with_key ?key:None
let createElementWithKey = create_element_with_key

let clone_component_error name =
  Printf.sprintf
    "React.cloneElement: cannot clone '%s'. In server-reason-react, component props are compile-time labelled \
     arguments (and extending them with new props at runtime is not supported). React.cloneElement only works with \
     lowercase DOM elements."
    name

let rec cloneElement element new_attributes =
  match element with
  | Lower_case_element { key; tag; attributes; children } ->
      Lower_case_element { key; tag; attributes = clone_attributes attributes new_attributes; children }
  | Upper_case_component (name, _) -> raise (Invalid_argument (clone_component_error name))
  | Async_component (name, _) -> raise (Invalid_argument (clone_component_error name))
  | Client_component { import_name; _ } -> raise (Invalid_argument (clone_component_error import_name))
  | Static { original; prerendered = _ } -> cloneElement original new_attributes
  | Writer { original; emit = _ } -> cloneElement (original ()) new_attributes
  | Fragment _ -> raise (Invalid_argument "React.cloneElement: cannot clone a Fragment")
  | Text _ | Int _ | Float _ -> raise (Invalid_argument "React.cloneElement: cannot clone a Text element")
  | Empty -> raise (Invalid_argument "React.cloneElement: cannot clone a null element")
  | List _ -> raise (Invalid_argument "React.cloneElement: cannot clone a List")
  | Array _ -> raise (Invalid_argument "React.cloneElement: cannot clone an Array")
  | Provider _ -> raise (Invalid_argument "React.cloneElement: cannot clone a Provider")
  | Consumer _ -> raise (Invalid_argument "React.cloneElement: cannot clone a Consumer")
  | Suspense _ -> raise (Invalid_argument "React.cloneElement: cannot clone a Suspense")

module Fragment = struct
  let makeProps ~children () : < children : element > Js.t =
    object
      method children = children
    end

  let make ?key:_ props = Fragment props#children
end

let fragment children = Fragment.make (Fragment.makeProps ~children ())

(* ReasonReact APIs *)
let string txt = Text txt
let null = Empty
let int i = Int i
let float f = Float f
let array arr = Array arr
let list l = List l

type 'a provider = value:'a -> children:element -> unit -> element

module Context = struct
  type 'a t = {
    current_value : 'a ref;
    async_key : Obj.t Lwt.key;
    provider : 'a provider;
    consumer : children:element -> element;
  }

  let makeProps ~value ~children () : < value : 'a ; children : element > Js.t =
    object
      method value = value
      method children = children
    end

  let provider ctx ?key:_ props = ctx.provider ~value:props#value ~children:props#children ()
end

let createContext (initial_value : 'a) : 'a Context.t =
  let ref_value = { current = initial_value } in
  let async_key = Lwt.new_key () in
  let provider ~value ~children () =
    Provider
      {
        children;
        push =
          (fun () ->
            let prev = ref_value.current in
            ref_value.current <- value;
            fun () -> ref_value.current <- prev);
        async_key;
        async_value = Obj.repr value;
      }
  in
  let consumer ~children = Consumer children in
  { current_value = ref_value; async_key; provider; consumer }

module Suspense = struct
  let or_react_null = function None -> null | Some x -> x

  let makeProps ?fallback ?children () : < fallback : element option ; children : element option > Js.t =
    object
      method fallback = fallback
      method children = children
    end

  let make ?key props = Suspense { key; fallback = props#fallback; children = or_react_null props#children }
end

module Cache = struct
  type cache_entry = Ok of Obj.t | Error of exn
  type fn_cache = (Obj.t, cache_entry) Hashtbl.t
  type request_cache = (int, fn_cache) Hashtbl.t

  let async_key : request_cache Lwt.key = Lwt.new_key ()
  let fn_id_counter : int Stdlib.ref = Stdlib.ref 0

  let with_request_cache f =
    let cache = Hashtbl.create 16 in
    Lwt.with_value async_key (Some cache) f

  let with_request_cache_async f =
    let cache = Hashtbl.create 16 in
    Lwt.with_value async_key (Some cache) f
end

(* On the server there's no re-render, so memoization is a no-op and the
   component is passed through unchanged. Signatures match reason-react. *)
let memo component = component
let memoCustomCompareProps component _compare = component

let cache fn =
  let fn_id = !Cache.fn_id_counter in
  Cache.fn_id_counter := fn_id + 1;
  fun arg ->
    match Lwt.get Cache.async_key with
    | None -> fn arg
    | Some cache_map -> (
        let fn_cache =
          match Hashtbl.find_opt cache_map fn_id with
          | Some cache -> cache
          | None ->
              let cache = Hashtbl.create 8 in
              Hashtbl.add cache_map fn_id cache;
              cache
        in
        let arg_key = Obj.repr arg in
        match Hashtbl.find_opt fn_cache arg_key with
        | Some (Cache.Ok value) -> Obj.obj value
        | Some (Cache.Error error) -> raise error
        | None -> (
            try
              let result = fn arg in
              Hashtbl.add fn_cache arg_key (Cache.Ok (Obj.repr result));
              result
            with exn ->
              Hashtbl.add fn_cache arg_key (Cache.Error exn);
              raise exn))

let useContext (context : 'a Context.t) =
  match Lwt.get context.async_key with Some v -> (Obj.obj v : 'a) | None -> context.current_value.current

let useState (make_initial_value : unit -> 'state) =
  let initial_value : 'state = make_initial_value () in
  let setState (fn : 'state -> 'state) =
    let _ = fn initial_value in
    ()
  in
  (initial_value, setState)

type ('input, 'output) callback = 'input -> 'output

let useSyncExternalStore ~subscribe:_ ~getSnapshot = getSnapshot ()
let useSyncExternalStoreWithServer ~subscribe:_ ~getSnapshot:_ ~getServerSnapshot = getServerSnapshot ()

(* Tree context for useId — implements the same bit-packing algorithm as React's
   ReactFizzTree_context.js to produce hydration-compatible IDs.

   IDs are base-32 strings whose binary representation corresponds to the
   position of a node in a tree. Every time the tree forks into multiple
   children, additional bits encode the position of the child within the
   current level of children. *)
module Tree_context = struct
  type t = { id : int; overflow : string }

  let empty = { id = 1; overflow = "" }

  (* Count leading zeros in a 32-bit representation.
     Uses the same algorithm as Math.clz32 in JavaScript. *)
  let clz32 x =
    if x = 0 then 32
    else
      let n = Stdlib.ref 0 in
      let v = Stdlib.ref x in
      if !v land 0xFFFF0000 = 0 then (
        n := !n + 16;
        v := !v lsl 16);
      if !v land 0xFF000000 = 0 then (
        n := !n + 8;
        v := !v lsl 8);
      if !v land 0xF0000000 = 0 then (
        n := !n + 4;
        v := !v lsl 4);
      if !v land 0xC0000000 = 0 then (
        n := !n + 2;
        v := !v lsl 2);
      if !v land 0x80000000 = 0 then n := !n + 1;
      !n

  let get_bit_length n = 32 - clz32 n
  let get_leading_bit id = 1 lsl (get_bit_length id - 1)

  (* Convert a non-negative integer to a base-32 string (digits: 0-9, a-v).
     Matches JavaScript's Number.prototype.toString(32). *)
  let int_to_base32 n =
    if n = 0 then "0"
    else
      let digits = "0123456789abcdefghijklmnopqrstuv" in
      let buf = Buffer.create 8 in
      let rec go n =
        if n > 0 then begin
          go (n / 32);
          Buffer.add_char buf (String.get digits (n mod 32))
        end
      in
      go n;
      Buffer.contents buf

  let get_tree_id ctx =
    let overflow = ctx.overflow in
    let id_with_leading_bit = ctx.id in
    let id = id_with_leading_bit land lnot (get_leading_bit id_with_leading_bit) in
    int_to_base32 id ^ overflow

  let push base_ctx ~total_children ~index =
    let base_id_with_leading_bit = base_ctx.id in
    let base_overflow = base_ctx.overflow in
    let base_length = get_bit_length base_id_with_leading_bit - 1 in
    let base_id = base_id_with_leading_bit land lnot (1 lsl base_length) in
    let slot = index + 1 in
    let length = get_bit_length total_children + base_length in
    if length > 30 then begin
      (* Overflow: convert some bits to base-32 string *)
      let number_of_overflow_bits = base_length - (base_length mod 5) in
      let new_overflow_bits = (1 lsl number_of_overflow_bits) - 1 in
      let new_overflow = int_to_base32 (base_id land new_overflow_bits) in
      let rest_of_base_id = base_id asr number_of_overflow_bits in
      let rest_of_base_length = base_length - number_of_overflow_bits in
      let rest_of_length = get_bit_length total_children + rest_of_base_length in
      let rest_of_new_bits = slot lsl rest_of_base_length in
      let id = rest_of_new_bits lor rest_of_base_id in
      let overflow = new_overflow ^ base_overflow in
      { id = (1 lsl rest_of_length) lor id; overflow }
    end
    else
      (* Normal path *)
      let new_bits = slot lsl base_length in
      let id = new_bits lor base_id in
      { id = (1 lsl length) lor id; overflow = base_overflow }
end

(* Rendering hook context — mutable state set by the renderer (ReactDOM) and
   read by hooks (useId). This mirrors React's currentlyRenderingTask pattern
   in ReactFizzHooks.js.

   This state is process-global: two async renders (renderToStream/render_html)
   must not be in flight concurrently in one process, or their useId state
   interleaves at Lwt yields and produces hydration mismatches.
   TODO: scope per render (Lwt.key, as React.Cache/Context do, or thread through
   the renderer) before enabling concurrent renders. *)
let current_tree_context : Tree_context.t Stdlib.ref = Stdlib.ref Tree_context.empty
let local_id_counter : int Stdlib.ref = Stdlib.ref 0
let did_render_id_hook : bool Stdlib.ref = Stdlib.ref false
let identifier_prefix : string option Stdlib.ref = Stdlib.ref None

let reset_component_id_state (ctx : Tree_context.t) =
  current_tree_context := ctx;
  local_id_counter := 0;
  did_render_id_hook := false

let check_did_render_id_hook () = !did_render_id_hook

let reset_id_rendering ?prefix () =
  current_tree_context := Tree_context.empty;
  local_id_counter := 0;
  did_render_id_hook := false;
  identifier_prefix := prefix

(* React 19 uses \u00ab (LEFT-POINTING DOUBLE ANGLE QUOTATION MARK) and
   \u00bb (RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK) as ID delimiters. *)
let id_start = "\xc2\xab"
let id_end = "\xc2\xbb"

let useId () =
  let tree_id = Tree_context.get_tree_id !current_tree_context in
  let local_id = !local_id_counter in
  local_id_counter := local_id + 1;
  did_render_id_hook := true;
  match (!identifier_prefix, local_id > 0) with
  | None, false -> Printf.sprintf "%sR%s%s" id_start tree_id id_end
  | None, true -> Printf.sprintf "%sR%sH%s%s" id_start tree_id (Tree_context.int_to_base32 local_id) id_end
  | Some prefix, false -> Printf.sprintf "%s%sR%s%s" id_start prefix tree_id id_end
  | Some prefix, true ->
      Printf.sprintf "%s%sR%sH%s%s" id_start prefix tree_id (Tree_context.int_to_base32 local_id) id_end

let useMemo fn = fn ()
let useMemo0 fn = fn ()
let useMemo1 fn _ = fn ()
let useMemo2 fn _ = fn ()
let useMemo3 fn _ = fn ()
let useMemo4 fn _ = fn ()
let useMemo5 fn _ = fn ()
let useMemo6 fn _ = fn ()
let useCallback fn = fn
let useCallback0 fn = fn
let useCallback1 fn _ = fn
let useCallback2 fn _ = fn
let useCallback3 fn _ = fn
let useCallback4 fn _ = fn
let useCallback5 fn _ = fn
let useCallback6 fn _ = fn
let useReducer _ s = (s, fun _ -> ())
let useReducerWithMapState _ s mapper = (mapper s, fun _ -> ())
let useEffect _ = ()
let useEffect0 _ = ()
let useEffect1 _ _ = ()
let useEffect2 _ _ = ()
let useEffect3 _ _ = ()
let useEffect4 _ _ = ()
let useEffect5 _ _ = ()
let useEffect6 _ _ = ()
let useLayoutEffect0 _ = ()
let useLayoutEffect1 _ _ = ()
let useLayoutEffect2 _ _ = ()
let useLayoutEffect3 _ _ = ()
let useLayoutEffect4 _ _ = ()
let useLayoutEffect5 _ _ = ()
let useLayoutEffect6 _ _ = ()

module Children = struct
  let map element fn =
    match element with
    | List children -> List.map fn children |> list
    | Array children -> Array.map fn children |> array
    | _ -> fn element

  let mapWithIndex element fn =
    match element with
    | List children -> List.mapi (fun index element -> fn element index) children |> list
    | Array children -> Array.mapi (fun index element -> fn element index) children |> array
    | _ -> fn element 0

  let forEach element fn =
    match element with
    | List children -> List.iter fn children
    | Array children -> Array.iter fn children
    | _ ->
        let _ = fn element in
        ()

  let forEachWithIndex element fn =
    match element with
    | List children -> List.iteri (fun index element -> fn element index) children
    | Array children -> Array.iteri (fun index element -> fn element index) children
    | _ ->
        let _ = fn element 0 in
        ()

  let count element =
    match element with
    | List children -> List.length children
    | Array children -> Array.length children
    | Empty -> 0
    | _ -> 1

  let only element =
    match element with
    | List (child :: _) -> child
    | List [] -> raise (Invalid_argument "Expected at least one child")
    | Array children ->
        if Array.length children >= 1 then Array.get children 0
        else raise (Invalid_argument "Expected at least one child")
    | _ -> element

  (* TODO: silly way to convert children to array, but isn't necessary in most cases *)
  let toArray element = [| element |]
end

let setDisplayName _ _ = ()
let useTransition () = (false, fun (_cb : unit -> unit) -> ())
let useDebugValue : 'value -> ?format:('value -> string) -> unit = fun[@warning "-16"] _ ?format:_ -> ()
let useDeferredValue value = value

(* `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 suspend promise = raise (Suspend (Any_promise promise))

module Experimental = struct
  let usePromise promise =
    match Lwt.state promise with
    | Sleep -> suspend promise
    (* TODO: Fail should raise a FailedSupense and catch at renderTo*? *)
    | Fail e -> raise e
    | Return v -> v

  let useActionState ?permalink:_ _action state = (state, (), false)
end