(*

names?:
   - universal tool, unitool [was thinking about how this is trying to unify a lot of my "tools for thought"]
     * because it has always bothered me that it's easier to use google search as a calculator than the purpose built app!!!!!!!!
   - universal console, unicon (UNICOrN) [unicon is nice ;3]
   - non-magical systems (NMS) un-magical
   - console is an interface to allow you to program your computer more easily.
  
describe exactly every case you can think of that you want this drawing and layout system to handle:
   
* draw text on variously coloured backgrounds that can be defined locally or globally
* TODO

*)

(*

ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!!

Times I would have solved it faster if i broke it up instead of trying to understand it all at once: 2

a computation console

- irmin store provides a tree of data objects
- the tree can be navigated in the default view
- the selected object can be edited <enter> or executed as an ocaml top level phrase <C-enter>
- each execution stores any edited modifications and the command to execute that phrase in the current irmin store context as a commit message
- while editing a data object <ctrl-enter> wille search for the previous and next `;;` or BOF/EOF and execute the enclosed text and the commit message includes the character offsets of the executed text.
- executions can modify the window system creating new windows and redirecting input focus. They define their own input handling however C-g,C-g,C-g will restore the window system to the default??

but how do we integrate this with the ocaml environment and name spaces??
some options:
- always wrap execution units from data objects in some sort of local namespace so opens are not global?
- dig into the toplevel environment and manipulate it, this will also help with things like completion and context help

*)
open Js_of_ocaml
module F = Fmt

module Logs_reporter = struct
  (* Console reporter *)

  open Jsoo_runtime

  let console : Logs.level -> string -> unit =
   fun level s ->
    let meth =
      match level with
      | Logs.Error -> "error"
      | Logs.Warning -> "warn"
      | Logs.Info -> "info"
      | Logs.Debug -> "debug"
      | Logs.App -> "log"
    in
    ignore
      (Js.meth_call
         (Js.pure_js_expr "console")
         meth
         [| Js.string s |])

  let ppf, flush =
    let b = Buffer.create 255 in
    let flush () =
      let s = Buffer.contents b in
      Buffer.clear b;
      s
    in
    (Format.formatter_of_buffer b, flush)

  let hook =
    ref (fun level s ->
        ignore (Logs.level_to_string (Some level) ^ ": " ^ s))

  let console_report _src level ~over k msgf =
    let k _ =
      let s = flush () in
      console level s;
      !hook level s;
      over ();
      k ()
    in
    msgf @@ fun ?header ?tags fmt ->
    let _tags = tags in
    match header with
    | None -> Format.kfprintf k ppf ("@[" ^^ fmt ^^ "@]@.")
    | Some h -> Format.kfprintf k ppf ("[%s] @[" ^^ fmt ^^ "@]@.") h

  let console_reporter () = { Logs.report = console_report }
end

let _ =
  Logs.set_reporter (Logs_reporter.console_reporter ());
  Logs.set_level (Some Debug);
  Logs.debug (fun m -> m "hello")

module Log = Logs
module Cohttp_backend = Cohttp_lwt_jsoo

module Git_af = struct
  open Lwt.Infix

  type error = |

  let git_af_scheme : [ `HTTP | `HTTPS ] Mimic.value =
    Mimic.make ~name:"git-af-scheme"

  let git_af_port : int Mimic.value = Mimic.make ~name:"git-af-port"

  let git_af_hostname : string Mimic.value =
    Mimic.make ~name:"git-af-hostname"

  let pp_error : error Fmt.t = fun _ppf -> function _ -> .

  let with_redirects ?(max = 10) ~f uri =
    if max < 10 then invalid_arg "with_redirects";
    let tbl = Hashtbl.create 0x10 in
    let rec go max uri =
      f uri >>= fun (resp, body) ->
      let status_code =
        Cohttp.(Response.status resp |> Code.code_of_status)
      in
      if Cohttp.Code.is_redirection status_code then
        match
          Cohttp.(Response.headers resp |> Header.get_location)
        with
        | Some uri' when Hashtbl.mem tbl uri' || max = 0 ->
            Lwt.return (resp, body)
        | Some uri' ->
            Hashtbl.add tbl uri' ();
            Cohttp_lwt.Body.drain_body body >>= fun () ->
            go (pred max) uri'
        | None -> Lwt.return (resp, body)
      else Lwt.return (resp, body)
    in
    go max uri

  let get ~ctx:_ ?(headers = []) uri =
    Firebug.console##log (Js.string "Git_Cohttp_console.get()\n");
    let headers = Cohttp.Header.of_list headers in
    let f uri = Cohttp_backend.Client.get ~headers uri in
    with_redirects ~f uri >>= fun (_resp, body) ->
    Cohttp_lwt.Body.to_string body >>= fun body ->
    Lwt.return_ok ((), body)

  let post ~ctx:_ ?(headers = []) uri body =
    let headers = Cohttp.Header.of_list headers in
    let body = Cohttp_lwt.Body.of_string body in
    let f uri =
      Cohttp_backend.Client.post ~headers ~chunked:false ~body uri
    in
    with_redirects ~f uri >>= fun (_resp, body) ->
    Cohttp_lwt.Body.to_string body >>= fun body ->
    Lwt.return_ok ((), body)
end

module Git_console_http = struct
  open Lwt.Infix

  let context ctx =
    (* HTTP *)
    let edn = Mimic.make ~name:"af-http-endpoint" in
    let k1 git_af_scheme git_af_hostname git_af_port =
      match git_af_scheme with
      | `HTTP -> Lwt.return_some (git_af_hostname, git_af_port)
      | _ -> Lwt.return_none
    in
    let ctx =
      Mimic.fold edn
        Mimic.Fun.
          [
            req Git_af.git_af_scheme;
            req Git_af.git_af_hostname;
            dft Git_af.git_af_port 80;
          ]
        ~k:k1 ctx
    in

    (* HTTPS *)
    let edn = Mimic.make ~name:"af-https-endpoint" in
    let k1 git_af_scheme git_af_hostname git_af_port =
      match git_af_scheme with
      | `HTTPS -> Lwt.return_some (git_af_hostname, git_af_port)
      | _ -> Lwt.return_none
    in

    let ctx =
      Mimic.fold edn
        Mimic.Fun.
          [
            req Git_af.git_af_scheme;
            req Git_af.git_af_hostname;
            dft Git_af.git_af_port 443;
          ]
        ~k:k1 ctx
    in

    ctx

  module HTTP = struct
    type state =
      | Handshake
      | Get of {
          advertised_refs : string;
          uri : Uri.t;
          headers : (string * string) list;
          ctx : Mimic.ctx;
        }
      | Post of {
          mutable output : string;
          uri : Uri.t;
          headers : (string * string) list;
          ctx : Mimic.ctx;
        }
      | Error

    type flow = { endpoint : Uri.t; mutable state : state }
    type error = [ `Msg of string ]
    type write_error = [ `Closed | `Msg of string ]

    let pp_error ppf (`Msg err) = Fmt.string ppf err

    let pp_write_error ppf = function
      | `Closed -> Fmt.string ppf "Connection closed by peer"
      | `Msg err -> Fmt.string ppf err

    let write t cs =
      match t.state with
      | Handshake | Get _ ->
          Lwt.return_error (`Msg "Handshake has not been done")
      | Error -> Lwt.return_error (`Msg "Handshake got an error")
      | Post ({ output; _ } as v) ->
          let output = output ^ Cstruct.to_string cs in
          v.output <- output;
          Lwt.return_ok ()

    let writev t css =
      let rec go = function
        | [] -> Lwt.return_ok ()
        | x :: r -> (
            write t x >>= function
            | Ok () -> go r
            | Error _ as err -> Lwt.return err)
      in
      go css

    let read t =
      match t.state with
      | Handshake ->
          Lwt.return_error (`Msg "Handshake has not been done")
      | Error -> Lwt.return_error (`Msg "Handshake got an error")
      | Get { advertised_refs; uri; headers; ctx } ->
          t.state <- Post { output = ""; uri; headers; ctx };
          Lwt.return_ok (`Data (Cstruct.of_string advertised_refs))
      | Post { output; uri; headers; ctx } -> (
          Git_af.post ~ctx ~headers uri output >>= function
          | Ok (_resp, contents) ->
              Lwt.return_ok (`Data (Cstruct.of_string contents))
          | Error err ->
              Lwt.return_error
                (`Msg (Fmt.str "%a" Git_af.pp_error err)))

    let close _ = Lwt.return_unit

    type endpoint = Uri.t

    let connect endpoint =
      Firebug.console##log
        (Js.string "Git_Console_http.HTTP.connect()\n");
      Lwt.return_ok { endpoint; state = Handshake }
  end

  let http_endpoint, http_protocol =
    Mimic.register ~name:"http" (module HTTP)

  let connect (ctx : Mimic.ctx) =
    Firebug.console##log (Js.string "Git_Console_http.connect()\n");
    let module T = (val Mimic.repr http_protocol) in
    let edn = Mimic.make ~name:"http-endpoint" in
    let k0 uri = Lwt.return_some uri in
    let k1 git_transmission git_scheme =
      match (git_transmission, git_scheme) with
      | `HTTP (uri, _), (`HTTP | `HTTPS) -> Lwt.return_some uri
      | _ -> Lwt.return_none
    in
    let k2 git_scheme git_uri git_http_headers =
      match git_scheme with
      | `Git | `SSH | `Scheme _ -> Lwt.return_none
      | `HTTP | `HTTPS ->
          let headers =
            ("content-type", "application/x-git-upload-pack-request")
            :: git_http_headers
          in
          let handshake ~uri0 ~uri1 = function
            | T.T flow -> (
                Firebug.console##log
                  (Js.string
                     (F.str
                        "Git_Console_http.connect.k2.handshake \
                         uri0='%s' uri1='%s'\n"
                        (Uri.to_string uri0) (Uri.to_string uri1)));
                let ctx = context Mimic.empty in
                Git_af.get ~ctx ~headers uri0 >>= function
                | Ok (_resp, advertised_refs) ->
                    flow.state <-
                      HTTP.Get
                        { advertised_refs; uri = uri1; headers; ctx };
                    Lwt.return_unit
                | Error _ ->
                    flow.state <- Error;
                    Lwt.return_unit)
            | _ -> Lwt.return_unit
          in
          let git_transmission = `HTTP (git_uri, handshake) in
          Lwt.return_some git_transmission
    in
    let ctx =
      Mimic.fold http_endpoint Mimic.Fun.[ req edn ] ~k:k0 ctx
    in
    let ctx =
      Mimic.fold edn
        Mimic.Fun.
          [ req Smart_git.git_transmission; req Smart_git.git_scheme ]
        ~k:k1 ctx
    in
    let ctx =
      Mimic.fold Smart_git.git_transmission
        Mimic.Fun.
          [
            req Smart_git.git_scheme;
            req Smart_git.git_uri;
            dft Smart_git.git_http_headers List.[];
          ]
        ~k:k2 ctx
    in
    Lwt.return ctx
end

module Nav = struct
  open Lwt.Infix

  module Config = struct
    open Irmin.Backend.Conf

    let spec = Spec.v "console_js_git"

    module Key = struct
      let reference : Git.Reference.t Irmin.Type.t =
        let of_string str =
          Git.Reference.of_string str |> Result.get_ok
        in
        let to_string r = Git.Reference.to_string r in
        Irmin.Type.(map string) of_string to_string

      let head =
        key ~spec ~doc:"The main branch of the Git repository." "head"
          Irmin.Type.(option reference)
          None

      let bare =
        key ~spec ~doc:"Do not expand the filesystem on the disk."
          "bare" Irmin.Type.bool false

      let level =
        key ~spec ~doc:"The Zlib compression level." "level"
          Irmin.Type.(option int)
          None

      let buffers =
        key ~spec ~doc:"The number of 4K pre-allocated buffers."
          "buffers"
          Irmin.Type.(option int)
          None
    end

    let init ?head ?level ?buffers _root =
      let module C = Irmin.Backend.Conf in
      let config = C.empty spec in

      let config = C.add config Key.head head in
      let config = C.add config Key.level level in
      let config = C.add config Key.buffers buffers in
      C.verify config
  end

  module S = struct
    module Schema =
      Irmin_git.Schema.Make (Git.Mem.Store) (Irmin.Contents.String)
        (Irmin_git.Branch.Make (Irmin.Branch.String))

    module Sync' = struct
      module GitMemSync = Git.Mem.Sync (Git.Mem.Store)
      include GitMemSync
      (* This is where the fetch and push are broken *)
    end

    module SMaker = Irmin_git.Maker (Git.Mem.Store) (Sync')
    module SMade = SMaker.Make (Schema)
    include SMade

    type endpoint = Mimic.ctx * Smart_git.Endpoint.t

    let remote ?(ctx = Mimic.empty) ?headers uri =
      E
        (Firebug.console##log (Js.string "Nav.S.remote()\n");
         let ( ! ) f a b = f b a in
         match Smart_git.Endpoint.of_string uri with
         | Ok edn ->
             let edn =
               Option.fold ~none:edn
                 ~some:(!Smart_git.Endpoint.with_headers_if_http edn)
                 headers
             in
             Firebug.console##log
               (Js.string "Nav.S.remote() = (ctx, edn) \n");
             (ctx, edn)
         | Error (`Msg err) -> Fmt.invalid_arg "remote: %s" err)

    module Backend = struct
      include Backend
      module R = Remote

      module Remote = struct
        include R

        type endpoint = Mimic.ctx * Smart_git.Endpoint.t

        let ctx e = fst e
        let edn e = snd e

        let fetch t ?depth endpoint branch =
          Firebug.console##log
            (Js.string "S.Backend.Remote.wrapped_fetch()\n");
          R.fetch t ?depth endpoint branch
      end
    end
  end

  module Sync = Irmin.Sync.Make (S)

  type t = S.tree
  type tree = t
  type step = S.step
  type path = step list

  let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree

  let test_populate () : t Lwt.t =
    let add p s t = S.Tree.add t p s in
    add [ "hello" ] "world" (S.Tree.empty ())
    >>= add [ "hello"; "daddy" ] "ily"
    >>= add [ "beep"; "beep" ] "motherfucker"

  let test_pull () : t Lwt.t =
    (* test_populate ()*)
    Firebug.console##log (Js.string "Nav.test_pull()\n");
    S.Repo.v (Config.init "") >>= fun repo ->
    Firebug.console##log (Js.string "Nav.test_pull(2)\n");
    S.of_branch repo "current" >>= fun t ->
    Firebug.console##log (Js.string "Nav.test_pull(3)\n");
    Git_console_http.connect Mimic.empty >>= fun ctx ->
    Firebug.console##log (Js.string "Nav.test_pull(4)\n");
    let upstream =
      S.remote ~ctx "https://localhost:8080/console/rootstore.git"
    in
    Firebug.console##log (Js.string "Nav.test_pull(5)\n");
    Sync.fetch_exn t upstream >>= fun _ -> S.tree t
  (* irmin/src/irmin/sync.ml: calls S.Remote.Backend.fetch *)
end

module Input = struct
  type button =
    [ `Left | `Middle | `Right | `Scroll of [ `Up | `Down ] ]

  type special =
    [ `Enter
    | `Escape
    | `Tab
    | `Arrow of [ `Up | `Down | `Left | `Right ]
    | `Function of int
    | `Page of [ `Up | `Down ]
    | `Home
    | `End
    | `Insert
    | `Delete
    | `Backspace
    | `Unknown of string ]

  (* Type of key code. *)
  type code =
    [ `Uchar of Uchar.t (* A unicode character. *) | special ]

  type mods = [ `Super | `Meta | `Ctrl | `Shift ] list

  type mouse =
    [ `Press of button | `Drag | `Release ] * (float * float) * mods

  type paste = [ `Start | `End ]
  type keyaction = [ `Press | `Release | `Repeat ]

  (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
  let string_of_code = function
    | `Uchar ch ->
        if Uchar.is_char ch then F.str "Char '%c'" (Uchar.to_char ch)
        else F.str "Char 0x%02x" (Uchar.to_int ch)
    | `Enter -> "Enter"
    | `Escape -> "Escape"
    | `Tab -> "Tab"
    | `Arrow `Up -> "Up"
    | `Arrow `Down -> "Down"
    | `Arrow `Left -> "Left"
    | `Arrow `Right -> "Right"
    | `Function i -> F.str "F%d" i
    | `Page `Up -> "Page Up"
    | `Page `Down -> "Page Down"
    | `Home -> "Home"
    | `End -> "End"
    | `Insert -> "Insert"
    | `Delete -> "Delete"
    | `Backspace -> "Backspace"
    | `Unknown s -> String.concat "Unknown " [ "\""; s; "\"" ]
end

module Event_js = struct
  open Js_of_ocaml

  let evt_of_jskey (evt : Dom_html.keyboardEvent Js.t) =
    ( (match Js.Optdef.to_option evt##.key with
      | Some s -> (
          match Js.to_string s with
          | "Enter" -> `Enter
          | "Escape" -> `Escape
          | "Tab" -> `Tab
          | "ArrowUp" -> `Arrow `Up
          | "ArrowDown" -> `Arrow `Down
          | "ArrowLeft" -> `Arrow `Left
          | "ArrowRight" -> `Arrow `Right
          | "PageUp" -> `Page `Up
          | "PageDown" -> `Page `Down
          | "Home" -> `Home
          | "End" -> `End
          | "Insert" -> `Insert
          | "Delete" -> `Delete
          | "Backspace" -> `Backspace
          | s -> (
              match Dom_html.Keyboard_key.of_event evt with
              | Some s' -> `Uchar s'
              | None -> `Unknown s))
      | None -> `Unknown "keypress .key is None?"),
      (if Js.to_bool evt##.altKey then [ `Meta ] else [])
      @ (if Js.to_bool evt##.shiftKey then [ `Shift ] else [])
      @ (if Js.to_bool evt##.ctrlKey then [ `Ctrl ] else [])
      @ if Js.to_bool evt##.metaKey then [ `Super ] else [] )
end

open Gg

module NVG = struct
  include Graphv_webgl

  module Color = struct
    include Graphv_webgl.Color

    let none = Color.transparent
    let rgbf = Color.rgbf
    let gray a = rgbf ~r:a ~g:a ~b:a
    let light = gray 0.8
    let dark = gray 0.2

    let black = gray 0.
    and red = rgbf ~r:1. ~g:0. ~b:0.
    and green = rgbf ~r:0. ~g:1. ~b:0.
    and yellow = rgbf ~r:1. ~g:1. ~b:0.
    and blue = rgbf ~r:0. ~g:0. ~b:1.
    and magenta = rgbf ~r:1. ~g:0. ~b:1.
    and cyan = rgbf ~r:0. ~g:1. ~b:1.
    and white = rgbf ~r:1. ~g:1. ~b:1.
    and lightblack = gray 0.5
    and lightred = rgbf ~r:1.0 ~g:0.5 ~b:0.5
    and lightgreen = rgbf ~r:0.5 ~g:1.0 ~b:0.5
    and lightyellow = rgbf ~r:1.0 ~g:1.0 ~b:0.5
    and lightblue = rgbf ~r:0.5 ~g:0.5 ~b:1.0
    and lightmagenta = rgbf ~r:1.0 ~g:0.5 ~b:1.0
    and lightcyan = rgbf ~r:0.5 ~g:1.0 ~b:1.0
    and lightwhite = rgbf ~r:1.0 ~g:1.0 ~b:1.0

    let pp ppf t : unit =
      F.(
        fmt "%a" ppf
          (record
             [
               field "r" (fun t -> t.r) F.float;
               field "g" (fun t -> t.g) F.float;
               field "b" (fun t -> t.b) F.float;
               field "a" (fun t -> t.a) F.float;
             ])
          t)
  end
end

open NVG

let str_of_box b =
  Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b)
    (Box2.oy b) (Box2.maxx b) (Box2.maxy b)

let fill_box vg color b =
  let module Path = NVG.Path in
  let open NVG in
  Path.begin_ vg;
  Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
    ~h:(Box2.h b);
  set_fill_color vg ~color;
  fill vg;
  Box2.max b

let path_box vg color ?(width = 0.) b =
  let module Path = NVG.Path in
  Path.begin_ vg;
  Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
    ~h:(Box2.h b);
  if width != 0. then NVG.set_stroke_width vg ~width;
  NVG.set_stroke_color vg ~color;
  NVG.stroke vg;
  Box2.max b

module Style = struct
  module Font = struct
    type t = {
      size : float option;
      font : [ `Sans | `Serif | `Mono | `None ];
      weight : [ `Bold | `Regular | `Light | `None ];
      italic : [ `Italic | `None ];
      underline : [ `Underline | `None ];
    }

    let empty =
      {
        size = None;
        font = `None;
        weight = `None;
        italic = `None;
        underline = `None;
      }

    let underline = { empty with underline = `Underline }
    let size { size; _ } = match size with None -> 20. | Some s -> s

    let merge a b =
      {
        size =
          (match (a.size, b.size) with
          | None, None -> None
          | Some s, None | None, Some s -> Some s
          | Some s1, Some s2 -> Some (Float.max_num s1 s2));
        font =
          (match (a.font, b.font) with
          | `Sans, _ | _, `Sans -> `Sans
          | `Serif, (`Serif | `Mono | `None) | (`Mono | `None), `Serif
            ->
              `Serif
          | `Mono, (`Mono | `None) | `None, `Mono -> `Mono
          | `None, `None -> `None);
        weight =
          (match (a.weight, b.weight) with
          | `Bold, _ | _, `Bold -> `Bold
          | `Regular, (`Regular | `Light | `None)
          | (`Light | `None), `Regular ->
              `Regular
          | `Light, (`Light | `None) | `None, `Light -> `Light
          | `None, `None -> `None);
        italic =
          (match (a.italic, b.italic) with
          | `Italic, _ | _, `Italic -> `Italic
          | _ -> `None);
        underline =
          (match (a.underline, b.underline) with
          | `Underline, _ | _, `Underline -> `Underline
          | _ -> `None);
      }

    let set vg t =
      (match t.size with
      | Some size -> Text.set_size vg ~size
      | None -> ());
      match t.font with
      | `Sans -> Text.set_font_face vg ~name:"sans"
      | _ -> ()
  end

  type t = { fg : Color.t; bg : Color.t; font : Font.t }
  type attr = t

  let equal = ( == )

  let empty =
    {
      fg = Color.transparent;
      bg = Color.transparent;
      font = Font.empty;
    }

  let dark = { empty with fg = Color.light; bg = Color.dark }

  let ( ++ ) a1 a2 =
    if a1 == empty then a2
    else if a2 == empty then a1
    else
      {
        a1 with
        fg = Color.lerp a1.fg a2.fg ~a:0.5;
        bg = Color.lerp a1.bg a2.bg ~a:0.5;
      }

  let fg ?(t = empty) c = { t with fg = c }
  let bg ?(t = empty) c = { t with bg = c }
  let font ?(t = empty) c = { t with font = c }

  let merge a b =
    {
      fg = Color.lerp a.fg b.fg ~a:0.5;
      bg = Color.lerp a.bg b.bg ~a:0.5;
      font = Font.merge a.font b.font;
    }

  let set vg s =
    F.epr "Style.set @.";
    NVG.set_fill_color vg ~color:s.bg;
    NVG.set_stroke_color vg ~color:s.fg;
    Font.set vg s.font
end

module Pad = struct
  open Gg

  type t = { t : size1; b : size1; l : size1; r : size1 }

  let empty =
    { t = Size1.zero; b = Size1.zero; l = Size1.zero; r = Size1.zero }

  let all v = { t = v; b = v; l = v; r = v }
end

(* from notty.ml *)
let btw (x : int) a b = a <= x && x <= b

module Buffer = struct
  include Stdlib.Buffer

  let buf = create 1024

  let mkstring f =
    f buf;
    let res = contents buf in
    reset buf;
    res

  let add_decimal b = function
    | x when btw x 0 999 ->
        let d1 = x / 100 and d2 = x mod 100 / 10 and d3 = x mod 10 in
        if d1 > 0 then 0x30 + d1 |> Char.unsafe_chr |> add_char b;
        if d1 + d2 > 0 then 0x30 + d2 |> Char.unsafe_chr |> add_char b;
        0x30 + d3 |> Char.unsafe_chr |> add_char b
    | x -> string_of_int x |> add_string b

  let add_chars b c n =
    for _ = 1 to n do
      add_char b c
    done
end

module String = struct
  include String

  let sub0cp s i len =
    if i > 0 || len < length s then sub s i len else s

  let of_chars_rev = function
    | [] -> ""
    | [ c ] -> String.make 1 c
    | cs ->
        let n = List.length cs in
        let rec go bs i =
          Bytes.(
            function
            | [] -> unsafe_to_string bs
            | x :: xs ->
                unsafe_set bs i x;
                go bs (pred i) xs)
        in
        go (Bytes.create n) (n - 1) cs
end

module Text = struct
  type t = String of string (* | Uchars of Uchar.t list*)

  let empty = String ""

  let equal = function
    | String a -> ( function String b -> String.equal a b)

  let of_string s = String s
  let to_string = function String s -> s

  let of_uchars ucs =
    of_string @@ Buffer.mkstring
    @@ fun buf -> Array.iter (Buffer.add_utf_8_uchar buf) ucs

  let replicatec w c = String (String.make (int_of_float w) c)

  let pp ppf : t -> unit = function
    | String s -> F.(fmt "String %s" ppf s)
end

module A = Style

module I = struct
  open Gg

  type dim = p2

  type t =
    | Empty
    | Segment of Text.t
    | Attr of (t * A.t)
    | Hcompose of (t * t)
    | Vcompose of (t * t)
    | Zcompose of (t * t)
    | Hcrop of (t * float * float)
    | Vcrop of (t * float * float)
    | Void of dim

  let p2_max p1 p2 : p2 =
    V2.(v (Float.max (x p1) (x p2)) (Float.max (y p1) (y p2)))
    [@@inline]

  let rec size vg p = function
    | Empty -> V2.zero
    | Segment s ->
        let NVG.Bounds.{ xmin; ymin; xmax; ymax } =
          (NVG.Text.bounds vg ~x:(V2.x p) ~y:(V2.y p)
             (Text.to_string s))
            .box
        in
        V2.v (xmax -. xmin) (ymax -. ymin)
    | Attr (t, _a) -> size vg p t
    | Hcompose (t1, t2) ->
        let p1 = size vg p t1 in
        let p2 = size vg V2.(p + v (x p1) 0.) t2 in
        V2.(v (x p1 +. x p2) (Float.max (y p1) (y p2)))
    | Vcompose (t1, t2) ->
        let p1 = size vg p t1 in
        let p2 = size vg V2.(p + v 0. (y p1)) t2 in
        V2.(v (Float.max (x p1) (x p2)) (y p1 +. y p2))
    | Zcompose (t1, t2) -> p2_max (size vg p t1) (size vg p t2)
    | Hcrop (t, left, right) ->
        V2.(size vg (p - v left 0.) t - v right 0.)
    | Vcrop (t, top, bottom) ->
        V2.(size vg (p - v 0. top) t - v 0. bottom)
    | Void p' -> V2.(p + p')

  let empty = Empty
  let void w h = Void (P2.v w h)

  let attr a = function
    | Attr (t, a0) -> Attr (t, A.(a ++ a0))
    | t -> Attr (t, a)

  let ( <|> ) t1 t2 =
    match (t1, t2) with
    | _, Empty -> t1
    | Empty, _ -> t2
    | _ -> Hcompose (t1, t2)

  let ( <-> ) t1 t2 =
    match (t1, t2) with
    | _, Empty -> t1
    | Empty, _ -> t2
    | _ -> Vcompose (t1, t2)

  let ( </> ) t1 t2 =
    match (t1, t2) with
    | _, Empty -> t1
    | Empty, _ -> t2
    | _ -> Zcompose (t1, t2)

  let hcrop left right img = Hcrop (img, left, right)
  let vcrop top bottom img = Vcrop (img, top, bottom)

  let crop ?(l = 0.) ?(r = 0.) ?(t = 0.) ?(b = 0.) img =
    let img = if l <> 0. || r <> 0. then hcrop l r img else img in
    if t <> 0. || b <> 0. then vcrop t b img else img

  let hpad left right img = hcrop (-.left) (-.right) img
  let vpad top bottom img = vcrop (-.top) (-.bottom) img

  let pad ?(l = 0.) ?(r = 0.) ?(t = 0.) ?(b = 0.) img =
    crop ~l:(-.l) ~r:(-.r) ~t:(-.t) ~b:(-.b) img

  let rec concatm z ( @ ) xs =
    let rec accum ( @ ) = function
      | ([] | [ _ ]) as xs -> xs
      | a :: b :: xs -> (a @ b) :: accum ( @ ) xs
    in
    match xs with
    | [] -> z
    | [ x ] -> x
    | xs -> concatm z ( @ ) (accum ( @ ) xs)

  let hcat = concatm empty ( <|> )
  let vcat = concatm empty ( <-> )
  let zcat xs = List.fold_right ( </> ) xs empty

  let text attr tx =
    match attr with Some a -> Attr (Segment tx, a) | _ -> Segment tx

  let string ?attr s = text attr (Text.of_string s)
  let uchars ?attr a = text attr (Text.of_uchars a)

  let rec linspcm z ( @ ) x n f =
    match n with
    | 0. -> z
    | 1. -> f x
    | _ ->
        let m = n /. 2. in
        linspcm z ( @ ) x m f @ linspcm z ( @ ) (x +. m) (n -. m) f

  let tabulate m n f =
    let m = max m 0. and n = max n 0. in
    linspcm empty ( <-> ) 0. n (fun y ->
        linspcm empty ( <|> ) 0. m (fun x -> f x y))

  let chars ctor ?attr c w h =
    let w = max 0. w and h = max 0. h in
    if w < 1. || h < 1. then void w h
    else
      let line = text attr (ctor w c) in
      tabulate 1. h (fun _ _ -> line)

  let char = chars Text.replicatec
  (* let uchar = chars Text.replicateu *)

  (* module Fmt = struct
       open Format

       type stag += Attr of A.t

       let push r x = r := x :: !r
       let pop r = r := match !r with _ :: xs -> xs | _ -> []
       let top_a r = match !r with a :: _ -> a | _ -> A.empty

       let create () =
         let img, line, attr = (ref empty, ref empty, ref []) in
         let fmt =
           formatter_of_out_functions
             {
               out_flush =
                 (fun () ->
                   img := !img <-> !line;
                   line := empty;
                   attr := []);
               out_newline =
                 (fun () ->
                   img := !img <-> !line;
                   line := void 0. 1.);
               out_string =
                 (fun s i n ->
                   line :=
                     !line
                     <|> string ~attr:(top_a attr)
                           String.(sub0cp s i n))
                 (* Not entirely clear; either or both could be void: *);
               out_spaces =
                 (fun w ->
                   line := !line <|> char ~attr:(top_a attr) ' ' w 1);
               out_indent =
                 (fun w ->
                   line := !line <|> char ~attr:(top_a attr) ' ' w 1);
             }
         in
         pp_set_formatter_stag_functions fmt
           {
             (pp_get_formatter_stag_functions fmt ()) with
             mark_open_stag =
               (function
               | Attr a ->
                   push attr A.(top_a attr ++ a);
                   ""
               | _ -> "");
             mark_close_stag =
               (fun _ ->
                 pop attr;
                 "");
           };
         pp_set_mark_tags fmt true;
         ( fmt,
           fun () ->
             let i = !img in
             img := empty;
             line := empty;
             attr := [];
             i )

       let ppf, reset = create ()

       let kstrf ?(attr = A.empty) ?(w = 1000000) k format =
         let m = ref 0 in
         let f1 _ () =
           m := pp_get_margin ppf ();
           pp_set_margin ppf w;
           pp_open_stag ppf (Attr attr)
         and k _ =
           pp_print_flush ppf ();
           pp_set_margin ppf !m;
           reset () |> k
         in
         kfprintf k ppf ("%a" ^^ format) f1 ()

       let strf ?attr ?w format = kstrf ?attr ?w (fun i -> i) format

       let attr attr f fmt x =
         pp_open_stag fmt (Attr attr);
         f fmt x;
         pp_close_stag fmt ()
     end

       let kstrf, strf, pp_attr = Fmt.(kstrf, strf, attr) *)

  module Draw = struct
    type attr = Style.t
    type p = P2.t
    type d = [ `X | `Y | `Z ]

    let vcat d a b =
      match d with
      | `X ->
          V2.v (V2.x a +. V2.x b) (Float.max_num (V2.y a) (V2.y b))
      | `Y -> V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b)
      | `Z ->
          V2.v
            (Float.max_num (V2.x a) (V2.x b))
            (Float.max_num (V2.y a) (V2.y b))

    let rec pp ppf : t -> unit = function
      | Empty -> F.(fmt "Empty" ppf)
      | Segment v -> F.(fmt "Segment %a" ppf (parens Text.pp) v)
      | Attr v ->
          F.(fmt "Attr %a" ppf (pair (parens pp) (any "...")) v)
      | Hcompose a ->
          F.(fmt "Hcompose %a" ppf (pair (parens pp) (parens pp)) a)
      | Vcompose a ->
          F.(fmt "Vcompose %a" ppf (pair (parens pp) (parens pp)) a)
      | Zcompose a ->
          F.(fmt "Zcompose %a" ppf (pair (parens pp) (parens pp)) a)
      | Hcrop (t, h, w) -> F.(fmt "Hcrop (%a,%f,%f)" ppf pp t h w)
      | Vcrop (t, h, w) -> F.(fmt "Vcrop (%a,%f,%f)" ppf pp t h w)
      | Void dim -> F.(fmt "Void %a" ppf (parens V2.pp) dim)

    let rec segment vg p : Text.t -> P2.t = function
      | String s ->
          (* Log.debug (fun m -> m "I.Draw.segment p=%a %s" Gg.V2.pp p s); *)
          let metrics = NVG.Text.metrics vg in
          NVG.Text.text vg ~x:(V2.x p)
            ~y:(V2.y p +. metrics.ascender)
            s;
          let NVG.Bounds.{ xmin; ymin; xmax; ymax } =
            (NVG.Text.bounds vg ~x:(V2.x p) ~y:(V2.y p) s).box
          in
          V2.v (xmax -. xmin) (ymax -. ymin)

    and node vg attr p n : p2 =
      let b' =
        match n with
        | Empty | Void _ -> p
        | Segment text -> segment vg p text
        | Attr (i, a0) ->
            if Style.(attr.fg) != a0.fg then
              NVG.set_fill_color vg ~color:Style.(attr.fg);
            node vg A.(attr ++ a0) p i
        | Hcompose (i1, i2) ->
            let p1 = node vg attr p i1 in
            let p2 = node vg attr V2.(p + v (V2.x p1) 0.) i2 in
            V2.(v (x p1 +. x p2) (Float.max (y p1) (y p2)))
        | Vcompose (i1, i2) ->
            let p1 = node vg attr p i1 in
            let p2 = node vg attr V2.(p + v 0. (V2.y p1)) i2 in
            V2.(v (Float.max (x p1) (x p2)) (y p1 +. y p2))
        | Zcompose (i1, i2) ->
            let p1 = node vg attr p i1 in
            let p2 = node vg attr p i2 in
            p2_max p1 p2
        | Hcrop (i, left, right) -> node vg attr p i
        | Vcrop (i, top, bottom) -> node vg attr p i
      in
      (* ignore
         (path_box vg.vg
            (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
            (Box2.of_pts b b')); *)
      b'
  end
end

module Nottui = struct
  let maxi x y : int = if x > y then x else y
  let mini x y : int = if x < y then x else y

  module Focus : sig
    type var = int Lwd.var
    type handle

    val make : unit -> handle
    val request : handle -> unit
    val request_var : var -> unit
    val release : handle -> unit

    type status = Empty | Handle of int * var | Conflict of int

    val empty : status

    (*val is_empty : status -> bool*)
    val status : handle -> status Lwd.t
    val has_focus : status -> bool
    val merge : status -> status -> status
  end = struct
    type var = int Lwd.var
    type status = Empty | Handle of int * var | Conflict of int
    type handle = var * status Lwd.t

    let make () =
      let v = Lwd.var 0 in
      (v, Lwd.map ~f:(fun i -> Handle (i, v)) (Lwd.get v))

    let empty : status = Empty
    let status (h : handle) : status Lwd.t = snd h

    let has_focus = function
      | Empty -> false
      | Handle (i, _) | Conflict i -> i > 0

    let clock = ref 0

    let request_var (v : var) =
      incr clock;
      Lwd.set v !clock

    let request ((v, _) : handle) = request_var v

    let release ((v, _) : handle) =
      incr clock;
      Lwd.set v 0

    let merge s1 s2 : status =
      match (s1, s2) with
      | Empty, x | x, Empty -> x
      | _, Handle (0, _) -> s1
      | Handle (0, _), _ -> s2
      | Handle (i1, _), Handle (i2, _) when i1 = i2 -> s1
      | (Handle (i1, _) | Conflict i1), Conflict i2 when i1 < i2 -> s2
      | (Handle (i1, _) | Conflict i1), Handle (i2, _) when i1 < i2 ->
          Conflict i2
      | Conflict _, (Handle (_, _) | Conflict _) -> s1
      | Handle (i1, _), (Handle (_, _) | Conflict _) -> Conflict i1
  end

  module Gravity : sig
    type direction = [ `Negative | `Neutral | `Positive ]

    val pp_direction : Format.formatter -> direction -> unit

    type t

    val pp : Format.formatter -> t -> unit
    val make : h:direction -> v:direction -> t
    val default : t
    val h : t -> direction
    val v : t -> direction

    type t2

    val pair : t -> t -> t2
    val p1 : t2 -> t
    val p2 : t2 -> t
  end = struct
    type direction = [ `Negative | `Neutral | `Positive ]
    type t = int
    type t2 = int

    let default = 0

    let pack = function
      | `Negative -> 0
      | `Neutral -> 1
      | `Positive -> 2

    let unpack = function
      | 0 -> `Negative
      | 1 -> `Neutral
      | _ -> `Positive

    let make ~h ~v = (pack h lsl 2) lor pack v
    let h x = unpack (x lsr 2)
    let v x = unpack (x land 3)

    let pp_direction ppf dir =
      let text =
        match dir with
        | `Negative -> "`Negative"
        | `Neutral -> "`Neutral"
        | `Positive -> "`Positive"
      in
      Format.pp_print_string ppf text

    let pp ppf g =
      Format.fprintf ppf "{ h = %a; v = %a }" pp_direction (h g)
        pp_direction (v g)

    let pair t1 t2 = (t1 lsl 4) lor t2
    let p1 t = (t lsr 4) land 15
    let p2 t = t land 15
  end

  type gravity = Gravity.t

  module Interval : sig
    type t

    val make : float -> float -> t
    val shift : t -> float -> t
    val fst : t -> float
    val snd : t -> float

    (*val size : t -> int*)
    val zero : t
  end = struct
    type t = float * float

    let make x y = (x, y)
    let shift (x, y) d = (x +. d, y +. d)
    let fst (x, _) = x
    let size (x, y) = y -. x
    let snd (_, y) = y
    let zero = (0., 0.)
  end

  module Ui = struct
    type may_handle = [ `Unhandled | `Handled ]

    type mouse_handler =
      x:float ->
      y:float ->
      Input.button ->
      [ `Unhandled
      | `Handled
      | `Grab of
        (x:float -> y:float -> unit) * (x:float -> y:float -> unit)
      ]

    type semantic_key =
      [ (* Clipboard *)
        `Copy
      | `Paste
      | (* Focus management *)
        `Focus of
        [ `Next | `Prev | `Left | `Right | `Up | `Down ] ]

    type key =
      [ Input.special | `Uchar of Uchar.t | semantic_key ]
      * Input.mods

    type mouse = Input.mouse

    type event =
      [ `Key of key | `Mouse of mouse | `Paste of Input.paste ]

    type layout_spec = {
      w : float;
      h : float;
      sw : float;
      sh : float;
    }

    let pp_layout_spec ppf { w; h; sw; sh } =
      Format.fprintf ppf "{ w = %f; h = %f; sw = %f; sh = %f }" w h sw
        sh

    type flags = int

    let flags_none = 0
    let flag_transient_sensor = 1
    let flag_permanent_sensor = 2

    type size_sensor = w:float -> h:float -> unit

    type frame_sensor =
      x:float -> y:float -> w:float -> h:float -> unit -> unit

    type t = {
      w : float;
      sw : float;
      h : float;
      sh : float;
      mutable desc : desc;
      focus : Focus.status;
      mutable flags : flags;
      mutable sensor_cache : (float * float * float * float) option;
      mutable cache : cache;
    }

    and image = I.t
    and cache = { vx : Interval.t; vy : Interval.t; image : image }

    and desc =
      | Atom of image
      | Size_sensor of t * size_sensor
      | Transient_sensor of t * frame_sensor
      | Permanent_sensor of t * frame_sensor
      | Resize of t * Gravity.t2 * A.t
      | Mouse_handler of t * mouse_handler
      | Focus_area of t * (key -> may_handle)
      | Shift_area of t * float * float
      | Event_filter of
          t * ([ `Key of key | `Mouse of mouse ] -> may_handle)
      | X of t * t
      | Y of t * t
      | Z of t * t

    let layout_spec t : layout_spec =
      { w = t.w; h = t.h; sw = t.sw; sh = t.sh }

    let layout_width t = t.w
    let layout_stretch_width t = t.sw
    let layout_height t = t.h
    let layout_stretch_height t = t.sh

    let cache : cache =
      { vx = Interval.zero; vy = Interval.zero; image = I.empty }

    let empty : t =
      {
        w = 0.;
        sw = 0.;
        h = 0.;
        sh = 0.;
        flags = flags_none;
        focus = Focus.empty;
        desc = Atom I.empty;
        sensor_cache = None;
        cache;
      }

    let atom img : t =
      {
        w = 0.;
        sw = 0.;
        h = 0.;
        sh = 0.;
        focus = Focus.empty;
        flags = flags_none;
        desc = Atom img;
        sensor_cache = None;
        cache;
      }

    (* let space_1_0 = atom (I.void 1 0)
       let space_0_1 = atom (I.void 0 1)
       let space_1_1 = atom (I.void 1 1)

       let space x y =
         match (x, y) with
         | 0, 0 -> empty
         | 1, 0 -> space_1_0
         | 0, 1 -> space_0_1
         | 1, 1 -> space_1_1
          | _ -> atom (I.void x y) *)

    let space x y = atom (I.void x y)
    let mouse_area f t : t = { t with desc = Mouse_handler (t, f) }

    let keyboard_area ?focus f t : t =
      let focus =
        match focus with
        | None -> t.focus
        | Some focus -> Focus.merge focus t.focus
      in
      { t with desc = Focus_area (t, f); focus }

    let shift_area x y t : t = { t with desc = Shift_area (t, x, y) }

    let size_sensor handler t : t =
      { t with desc = Size_sensor (t, handler) }

    let transient_sensor frame_sensor t =
      {
        t with
        desc = Transient_sensor (t, frame_sensor);
        flags = t.flags lor flag_transient_sensor;
      }

    let permanent_sensor frame_sensor t =
      {
        t with
        desc = Permanent_sensor (t, frame_sensor);
        flags = t.flags lor flag_permanent_sensor;
      }

    let prepare_gravity = function
      | None, None -> Gravity.(pair default default)
      | Some g, None | None, Some g -> Gravity.(pair g g)
      | Some pad, Some crop -> Gravity.(pair pad crop)

    let resize ?w ?h ?sw ?sh ?pad ?crop ?(bg = A.empty) t : t =
      let g = prepare_gravity (pad, crop) in
      match ((w, t.w), (h, t.h), (sw, t.sw), (sh, t.sh)) with
      | ( (Some w, _ | None, w),
          (Some h, _ | None, h),
          (Some sw, _ | None, sw),
          (Some sh, _ | None, sh) ) ->
          { t with w; h; sw; sh; desc = Resize (t, g, bg) }

    let resize_to ({ w; h; sw; sh } : layout_spec) ?pad ?crop
        ?(bg = A.empty) t : t =
      let g = prepare_gravity (pad, crop) in
      { t with w; h; sw; sh; desc = Resize (t, g, bg) }

    let event_filter ?focus f t : t =
      let focus =
        match focus with None -> t.focus | Some focus -> focus
      in
      { t with desc = Event_filter (t, f); focus }

    let join_x a b =
      {
        w = a.w +. b.w;
        sw = a.sw +. b.sw;
        h = max a.h b.h;
        sh = max a.sh b.sh;
        flags = a.flags lor b.flags;
        focus = Focus.merge a.focus b.focus;
        desc = X (a, b);
        sensor_cache = None;
        cache;
      }

    let join_y a b =
      {
        w = max a.w b.w;
        sw = max a.sw b.sw;
        h = a.h +. b.h;
        sh = a.sh +. b.sh;
        flags = a.flags lor b.flags;
        focus = Focus.merge a.focus b.focus;
        desc = Y (a, b);
        sensor_cache = None;
        cache;
      }

    let join_z a b =
      {
        w = max a.w b.w;
        sw = max a.sw b.sw;
        h = max a.h b.h;
        sh = max a.sh b.sh;
        flags = a.flags lor b.flags;
        focus = Focus.merge a.focus b.focus;
        desc = Z (a, b);
        sensor_cache = None;
        cache;
      }

    let pack_x = (empty, join_x)
    let pack_y = (empty, join_y)
    let pack_z = (empty, join_z)
    let hcat xs = Lwd_utils.reduce pack_x xs
    let vcat xs = Lwd_utils.reduce pack_y xs
    let zcat xs = Lwd_utils.reduce pack_z xs
    let has_focus t = Focus.has_focus t.focus

    let rec pp ppf t =
      Format.fprintf ppf "@[<hov>@[%a@]@]" pp_desc t.desc

    and pp_desc ppf = function
      | Atom _ -> Format.fprintf ppf "Atom _"
      | Size_sensor (desc, _) ->
          Format.fprintf ppf "Size_sensor (@[%a,@ _@])" pp desc
      | Transient_sensor (desc, _) ->
          Format.fprintf ppf "Transient_sensor (@[%a,@ _@])" pp desc
      | Permanent_sensor (desc, _) ->
          Format.fprintf ppf "Permanent_sensor (@[%a,@ _@])" pp desc
      | Resize (desc, gravity, _bg) ->
          Format.fprintf ppf "Resize (@[%a,@ %a,@ %a@])" pp desc
            Gravity.pp (Gravity.p1 gravity) Gravity.pp
            (Gravity.p2 gravity)
      | Mouse_handler (n, _) ->
          Format.fprintf ppf "Mouse_handler (@[%a,@ _@])" pp n
      | Focus_area (n, _) ->
          Format.fprintf ppf "Focus_area (@[%a,@ _@])" pp n
      | Shift_area (n, _, _) ->
          Format.fprintf ppf "Shift_area (@[%a,@ _@])" pp n
      | Event_filter (n, _) ->
          Format.fprintf ppf "Event_filter (@[%a,@ _@])" pp n
      | X (a, b) -> Format.fprintf ppf "X (@[%a,@ %a@])" pp a pp b
      | Y (a, b) -> Format.fprintf ppf "Y (@[%a,@ %a@])" pp a pp b
      | Z (a, b) -> Format.fprintf ppf "Z (@[%a,@ %a@])" pp a pp b

    let iter f ui =
      match ui.desc with
      | Atom _ -> ()
      | Size_sensor (u, _)
      | Transient_sensor (u, _)
      | Permanent_sensor (u, _)
      | Resize (u, _, _)
      | Mouse_handler (u, _)
      | Focus_area (u, _)
      | Shift_area (u, _, _)
      | Event_filter (u, _) ->
          f u
      | X (u1, u2) | Y (u1, u2) | Z (u1, u2) ->
          f u1;
          f u2
  end

  type ui = Ui.t

  module Renderer = struct
    open Ui

    type size = Gg.p2

    type grab_function =
      (x:float -> y:float -> unit) * (x:float -> y:float -> unit)

    type t = {
      mutable size : size;
      mutable view : ui;
      mutable mouse_grab : grab_function option;
    }

    let make () = { mouse_grab = None; size = P2.o; view = Ui.empty }
    let size t = t.size

    let solve_focus ui i =
      let rec aux ui =
        match ui.focus with
        | Focus.Empty | Focus.Handle (0, _) -> ()
        | Focus.Handle (i', _) when i = i' -> ()
        | Focus.Handle (_, v) -> Lwd.set v 0
        | Focus.Conflict _ -> Ui.iter aux ui
      in
      aux ui

    let split ~a ~sa ~b ~sb total =
      let stretch = sa +. sb in
      let flex = total -. a -. b in
      if stretch > 0. && flex > 0. then
        let ratio =
          if sa > sb then flex *. sa /. stretch
          else flex -. (flex *. sb /. stretch)
        in
        (a +. ratio, b +. flex -. ratio)
      else (a, b)

    let pack ~fixed ~stretch total g1 g2 =
      let flex = total -. fixed in
      if stretch > 0. && flex > 0. then (0., total)
      else
        let gravity = if flex >= 0. then g1 else g2 in
        match gravity with
        | `Negative -> (0., fixed)
        | `Neutral -> (flex /. 2., fixed)
        | `Positive -> (flex, fixed)

    let has_transient_sensor flags =
      flags land flag_transient_sensor <> 0

    let has_permanent_sensor flags =
      flags land flag_permanent_sensor <> 0

    let rec update_sensors ox oy sw sh ui =
      if
        has_transient_sensor ui.flags
        || has_permanent_sensor ui.flags
           &&
           match ui.sensor_cache with
           | None -> false
           | Some (ox', oy', sw', sh') ->
               ox = ox' && oy = oy' && sw = sw' && sh = sh'
      then (
        ui.flags <- ui.flags land lnot flag_transient_sensor;
        if has_permanent_sensor ui.flags then
          ui.sensor_cache <- Some (ox, oy, sw, sh);
        match ui.desc with
        | Atom _ -> ()
        | Size_sensor (t, _)
        | Mouse_handler (t, _)
        | Focus_area (t, _)
        | Event_filter (t, _) ->
            update_sensors ox oy sw sh t
        | Transient_sensor (t, sensor) ->
            ui.desc <- t.desc;
            let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
            update_sensors ox oy sw sh t;
            sensor ()
        | Permanent_sensor (t, sensor) ->
            let sensor = sensor ~x:ox ~y:oy ~w:sw ~h:sh in
            update_sensors ox oy sw sh t;
            sensor ()
        | Resize (t, g, _) ->
            let open Gravity in
            let dx, rw =
              pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g))
            in
            let dy, rh =
              pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g))
            in
            update_sensors (ox +. dx) (oy +. dy) rw rh t
        | Shift_area (t, sx, sy) ->
            update_sensors (ox -. sx) (oy -. sy) sw sh t
        | X (a, b) ->
            let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
            update_sensors ox oy aw sh a;
            update_sensors (ox +. aw) oy bw sh b
        | Y (a, b) ->
            let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
            update_sensors ox oy sw ah a;
            update_sensors ox (oy +. ah) sw bh b
        | Z (a, b) ->
            update_sensors ox oy sw sh a;
            update_sensors ox oy sw sh b)

    let update_focus ui =
      match ui.focus with
      | Focus.Empty | Focus.Handle _ -> ()
      | Focus.Conflict i -> solve_focus ui i

    let update t size ui =
      t.size <- size;
      t.view <- ui;
      update_sensors 0. 0. (P2.x size) (P2.y size) ui;
      update_focus ui

    let dispatch_mouse st x y btn w h t =
      let handle ox oy f =
        match f ~x:(x -. ox) ~y:(y -. oy) btn with
        | `Unhandled -> false
        | `Handled -> true
        | `Grab f ->
            st.mouse_grab <- Some f;
            true
      in
      let rec aux ox oy sw sh t =
        match t.desc with
        | Atom _ -> false
        | X (a, b) ->
            let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
            if x -. ox < aw then aux ox oy aw sh a
            else aux (ox +. aw) oy bw sh b
        | Y (a, b) ->
            let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
            if y -. oy < ah then aux ox oy sw ah a
            else aux ox (oy +. ah) sw bh b
        | Z (a, b) -> aux ox oy sw sh b || aux ox oy sw sh a
        | Mouse_handler (t, f) ->
            let _offsetx, rw =
              pack ~fixed:t.w ~stretch:t.sw sw `Negative `Negative
            and _offsety, rh =
              pack ~fixed:t.h ~stretch:t.sh sh `Negative `Negative
            in
            assert (_offsetx = 0. && _offsety = 0.);
            (x -. ox >= 0.
            && x -. ox <= rw
            && y -. oy >= 0.
            && y -. oy <= rh)
            && (aux ox oy sw sh t || handle ox oy f)
        | Size_sensor (desc, _)
        | Transient_sensor (desc, _)
        | Permanent_sensor (desc, _)
        | Focus_area (desc, _) ->
            aux ox oy sw sh desc
        | Shift_area (desc, sx, sy) ->
            aux (ox -. sx) (oy -. sy) sw sh desc
        | Resize (t, g, _bg) ->
            let open Gravity in
            let dx, rw =
              pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g))
            in
            let dy, rh =
              pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g))
            in
            aux (ox +. dx) (oy +. dy) rw rh t
        | Event_filter (n, f) -> (
            match f (`Mouse (`Press btn, (x, y), [])) with
            | `Handled -> true
            | `Unhandled -> aux ox oy sw sh n)
      in
      aux 0. 0. w h t

    let release_grab st x y =
      match st.mouse_grab with
      | None -> ()
      | Some (_, release) ->
          st.mouse_grab <- None;
          release ~x ~y

    let resize_canvas vg rw rh image =
      let w, h = V2.to_tuple @@ I.size vg V2.zero image in
      if w <> rw || h <> rh then I.pad ~r:(rw -. w) ~b:(rh -. h) image
      else image

    let resize_canvas2 vg ox oy rw rh image =
      let w, h = V2.to_tuple @@ I.size vg V2.zero image in
      I.pad ~l:ox ~t:oy ~r:(rw -. w -. ox) ~b:(rh -. h -. oy) image

    let same_size vg w h image =
      V2.(equal (of_tuple (w, h)) (I.size vg V2.zero image))

    let dispatch_mouse t (event, (x, y), _mods) =
      if
        match event with
        | `Press btn ->
            release_grab t x y;
            let w, h = V2.to_tuple t.size in
            dispatch_mouse t x y btn w h t.view
        | `Drag -> (
            match t.mouse_grab with
            | None -> false
            | Some (drag, _) ->
                drag ~x ~y;
                true)
        | `Release ->
            release_grab t x y;
            true
      then `Handled
      else `Unhandled

    let rec render_node vg (vx1 : size1) (vy1 : size1) (vx2 : size1)
        (vy2 : size1) (sw : size1) (sh : size1) (t : ui) : cache =
      if
        let cache = t.cache in
        vx1 >= Interval.fst cache.vx
        && vy1 >= Interval.fst cache.vy
        && vx2 <= Interval.snd cache.vx
        && vy2 <= Interval.snd cache.vy
      then t.cache
      else if vx2 < 0. || vy2 < 0. || sw < vx1 || sh < vy1 then
        {
          vx = Interval.make vx1 vx2;
          vy = Interval.make vy1 vy2;
          image = I.void sw sh;
        }
      else
        let cache =
          match t.desc with
          | Atom image ->
              {
                vx = Interval.make 0. sw;
                vy = Interval.make 0. sh;
                image = resize_canvas vg sw sh image;
              }
          | Size_sensor (desc, handler) ->
              handler ~w:sw ~h:sh;
              render_node vg vx1 vy1 vx2 vy2 sw sh desc
          | Transient_sensor (desc, _) | Permanent_sensor (desc, _) ->
              render_node vg vx1 vy1 vx2 vy2 sw sh desc
          | Focus_area (desc, _) | Mouse_handler (desc, _) ->
              render_node vg vx1 vy1 vx2 vy2 sw sh desc
          | Shift_area (t', sx, sy) ->
              let cache =
                render_node vg (vx1 +. sx) (vy1 +. sy) (vx2 +. sx)
                  (vy2 +. sy) (sx +. sw) (sy +. sh) t'
              in
              let vx = Interval.make vx1 vx2
              and vy = Interval.make vy1 vy2 in
              let image =
                resize_canvas vg sw sh
                  (I.crop ~l:sx ~t:sy cache.image)
              in
              { vx; vy; image }
          | X (a, b) ->
              let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in
              let ca = render_node vg vx1 vy1 vx2 vy2 aw sh a in
              let cb =
                render_node vg (vx1 -. aw) vy1 (vx2 -. aw) vy2 bw sh b
              in
              let vx =
                Interval.make
                  (max (Interval.fst ca.vx)
                     (Interval.fst cb.vx +. aw))
                  (min (Interval.snd ca.vx)
                     (Interval.snd cb.vx +. aw))
              and vy =
                Interval.make
                  (max (Interval.fst ca.vy) (Interval.fst cb.vy))
                  (min (Interval.snd ca.vy) (Interval.snd cb.vy))
              and image =
                resize_canvas vg sw sh (I.( <|> ) ca.image cb.image)
              in
              { vx; vy; image }
          | Y (a, b) ->
              let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in
              let ca = render_node vg vx1 vy1 vx2 vy2 sw ah a in
              let cb =
                render_node vg vx1 (vy1 -. ah) vx2 (vy2 -. ah) sw bh b
              in
              let vx =
                Interval.make
                  (max (Interval.fst ca.vx) (Interval.fst cb.vx))
                  (min (Interval.snd ca.vx) (Interval.snd cb.vx))
              and vy =
                Interval.make
                  (max (Interval.fst ca.vy)
                     (Interval.fst cb.vy +. ah))
                  (min (Interval.snd ca.vy)
                     (Interval.snd cb.vy +. ah))
              and image =
                resize_canvas vg sw sh (I.( <-> ) ca.image cb.image)
              in
              { vx; vy; image }
          | Z (a, b) ->
              let ca = render_node vg vx1 vy1 vx2 vy2 sw sh a in
              let cb = render_node vg vx1 vy1 vx2 vy2 sw sh b in
              let vx =
                Interval.make
                  (max (Interval.fst ca.vx) (Interval.fst cb.vx))
                  (min (Interval.snd ca.vx) (Interval.snd cb.vx))
              and vy =
                Interval.make
                  (max (Interval.fst ca.vy) (Interval.fst cb.vy))
                  (min (Interval.snd ca.vy) (Interval.snd cb.vy))
              and image =
                resize_canvas vg sw sh (I.( </> ) cb.image ca.image)
              in
              { vx; vy; image }
          | Resize (t, g, a) ->
              let open Gravity in
              let dx, rw =
                pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g))
              in
              let dy, rh =
                pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g))
              in
              let c =
                render_node vg (vx1 -. dx) (vy1 -. dy) (vx2 -. dx)
                  (vy2 -. dy) rw rh t
              in
              let image = resize_canvas2 vg dx dy sw sh c.image in
              let image =
                if a.bg != Color.none then
                  I.(image </> char ~attr:a ' ' sw sh)
                else image
              in
              let vx = Interval.shift c.vx dx in
              let vy = Interval.shift c.vy dy in
              { vx; vy; image }
          | Event_filter (t, _f) ->
              render_node vg vx1 vy1 vx2 vy2 sw sh t
        in
        t.cache <- cache;
        cache

    let image vg { size; view; _ } =
      let w, h = V2.to_tuple size in
      Log.debug (fun m -> m "Renderer.image view=%a" Ui.pp view);
      (render_node vg 0. 0. w h w h view).image

    let dispatch_raw_key st key =
      let rec iter (st : ui list) : [> `Unhandled ] =
        match st with
        | [] -> `Unhandled
        | ui :: tl -> (
            match ui.desc with
            | Atom _ -> iter tl
            | X (a, b) | Y (a, b) | Z (a, b) ->
                (* Try left/top most branch first *)
                let st' =
                  if Focus.has_focus b.focus then b :: tl
                  else a :: b :: tl
                in
                iter st'
            | Focus_area (t, f) -> (
                Log.debug (fun m -> m "dispatch_raw_key Focus_area");
                match iter [ t ] with
                | `Handled -> `Handled
                | `Unhandled -> (
                    match f key with
                    | `Handled -> `Handled
                    | `Unhandled -> iter tl))
            | Mouse_handler (t, _)
            | Size_sensor (t, _)
            | Transient_sensor (t, _)
            | Permanent_sensor (t, _)
            | Shift_area (t, _, _)
            | Resize (t, _, _) ->
                iter (t :: tl)
            | Event_filter (t, f) -> (
                match f (`Key key) with
                | `Unhandled -> iter (t :: tl)
                | `Handled -> `Handled))
      in
      iter [ st.view ]

    exception Acquired_focus

    let grab_focus ui =
      let rec aux ui =
        match ui.focus with
        | Focus.Empty -> ()
        | Focus.Handle (_, v) ->
            Focus.request_var v;
            raise Acquired_focus
        | Focus.Conflict _ -> iter aux ui
      in
      try
        aux ui;
        false
      with Acquired_focus -> true

    let rec dispatch_focus t dir =
      match t.desc with
      | Atom _ -> false
      | Mouse_handler (t, _)
      | Size_sensor (t, _)
      | Transient_sensor (t, _)
      | Permanent_sensor (t, _)
      | Shift_area (t, _, _)
      | Resize (t, _, _)
      | Event_filter (t, _) ->
          dispatch_focus t dir
      | Focus_area (t', _) ->
          if Focus.has_focus t'.focus then (
            Log.debug (fun m ->
                m "dispatch_focus: Focus.has_focus t'.focus");
            dispatch_focus t' dir || grab_focus t)
          else if
            Log.debug (fun m ->
                m "dispatch_focus: Focus.has_focus t.focus");
            Focus.has_focus t.focus
          then false
          else (
            Log.debug (fun m -> m "dispatch_focus: grab_focus");
            grab_focus t)
      | X (a, b) -> (
          if Focus.has_focus a.focus then
            dispatch_focus a dir
            ||
            match dir with
            | `Next | `Right -> dispatch_focus b dir
            | _ -> false
          else if Focus.has_focus b.focus then
            dispatch_focus b dir
            ||
            match dir with
            | `Prev | `Left -> dispatch_focus a dir
            | _ -> false
          else
            match dir with
            | `Prev | `Left | `Up ->
                dispatch_focus b dir || dispatch_focus a dir
            | `Next | `Down | `Right ->
                dispatch_focus a dir || dispatch_focus b dir)
      | Y (a, b) -> (
          if Focus.has_focus a.focus then
            dispatch_focus a dir
            ||
            match dir with
            | `Next | `Down -> dispatch_focus b dir
            | _ -> false
          else if Focus.has_focus b.focus then
            dispatch_focus b dir
            ||
            match dir with
            | `Prev | `Up -> dispatch_focus a dir
            | _ -> false
          else
            match dir with
            | `Prev | `Up ->
                dispatch_focus b dir || dispatch_focus a dir
            | `Next | `Left | `Down | `Right ->
                dispatch_focus a dir || dispatch_focus b dir)
      | Z (a, b) ->
          if Focus.has_focus a.focus then dispatch_focus a dir
          else dispatch_focus b dir || dispatch_focus a dir

    let rec dispatch_key st key =
      match (dispatch_raw_key st key, key) with
      | `Handled, _ -> `Handled
      | `Unhandled, (`Arrow dir, []) ->
          let dir : [ `Down | `Left | `Right | `Up ] :>
              [ `Down | `Left | `Right | `Up | `Next | `Prev ] =
            dir
          in
          dispatch_key st (`Focus dir, [ `Meta ])
      | `Unhandled, (`Tab, mods) ->
          let dir = if List.mem `Shift mods then `Prev else `Next in
          dispatch_key st (`Focus dir, mods)
      | `Unhandled, (`Focus dir, _) ->
          if dispatch_focus st.view dir then `Handled else `Unhandled
      | `Unhandled, _ -> `Unhandled

    let dispatch_event t = function
      | `Key key -> dispatch_key t key
      | `Mouse mouse -> dispatch_mouse t mouse
      | `Paste _ -> `Unhandled
  end
end

module Nottui_lwt = struct
  open Nottui

  (* stolen from let-def/lwd/lib/nottui/nottui.ml* etc... *)
  let copy_until quit ~f input =
    let quit = Lwt.map (fun () -> None) quit in
    let stream, push = Lwt_stream.create () in
    let rec aux () =
      Lwt.bind (Lwt.choose [ quit; Lwt_stream.peek input ])
      @@ fun result ->
      match result with
      | None ->
          push None;
          Lwt.return_unit
      | Some x ->
          push (Some (f x));
          Lwt.bind (Lwt_stream.junk input) aux
    in
    Lwt.async aux;
    stream

  let render vg ?quit ~size events doc =
    let renderer = Renderer.make () in
    let refresh_stream, push_refresh = Lwt_stream.create () in
    let root =
      Lwd.observe
        ~on_invalidate:(fun _ ->
          if not (Lwt_stream.is_closed refresh_stream) then
            push_refresh (Some ()))
        doc
    in
    let quit, do_quit =
      match quit with
      | Some quit -> (quit, None)
      | None ->
          let t, u = Lwt.wait () in
          (t, Some u)
    in
    let events =
      copy_until quit events ~f:(fun e ->
          (e
            : [ `Resize of _ | Ui.event ]
            :> [ `Resize of _ | Ui.event ]))
    in
    let size = ref size in
    let result, push = Lwt_stream.create () in
    let refresh () =
      (* FIXME This should use [Lwd.sample] with proper release management. *)
      let ui = Lwd.quick_sample root in
      Renderer.update renderer !size ui;
      push (Some (Renderer.image vg renderer))
    in
    refresh ();
    let process_event e =
      Log.debug (fun m -> m "Nottui_lwt.render= process_event");
      match e with
      | `Key (`Uchar c, [ `Meta ]) as event
        when Uchar.(equal c (of_char 'q')) -> (
          match do_quit with
          | Some u -> Lwt.wakeup u ()
          | None -> ignore (Renderer.dispatch_event renderer event))
      | #Ui.event as event -> (
          match Renderer.dispatch_event renderer event with
          | `Handled -> refresh ()
          | `Unhandled ->
              Log.warn (fun m ->
                  m
                    "Nottui_lwt.render process_event #Ui.event -> \
                     `Unhandled"))
      | `Resize size' ->
          size := size';
          refresh ()
    in
    Lwt.async (fun () ->
        Lwt.finalize
          (fun () -> Lwt_stream.iter process_event events)
          (fun () ->
            push None;
            Lwt.return_unit));
    Lwt.async (fun () -> Lwt_stream.iter refresh refresh_stream);
    result

  (* let run ?quit doc =
     let term = Term.create () in
     let images =
       render ?quit ~size:(Term.size term) (Term.events term) doc
     in
     Lwt.finalize
       (fun () -> Lwt_stream.iter_s (Term.image term) images)
       (fun () -> Term.release term) *)
end

module Nottui_widgets = struct
  open Nottui

  let string ?(attr = A.empty) str = Ui.atom (I.string ~attr str)
  let int ?attr x = string ?attr (string_of_int x)
  let bool ?attr x = string ?attr (string_of_bool x)
  let float_ ?attr x = string ?attr (string_of_float x)
  let printf ?attr fmt = Printf.ksprintf (string ?attr) fmt
  let fmt ?attr fmt = Format.kasprintf (string ?attr) fmt

  let kprintf k ?attr fmt =
    Printf.ksprintf (fun str -> k (string ?attr str)) fmt

  let kfmt k ?attr fmt =
    Format.kasprintf (fun str -> k (string ?attr str)) fmt

  let attr_menu_main = A.(bg Color.green ++ fg Color.black)
  let attr_menu_sub = A.(bg Color.lightgreen ++ fg Color.black)
  let attr_clickable = A.(fg Color.lightblue)

  type window_manager = {
    overlays : ui Lwd.t Lwd_table.t;
    view : ui Lwd.t;
  }

  let window_manager base =
    let overlays = Lwd_table.make () in
    let composition =
      Lwd.join
        (Lwd_table.reduce (Lwd_utils.lift_monoid Ui.pack_z) overlays)
    in
    let view =
      Lwd.map2 base composition ~f:(fun base composite ->
          Ui.join_z base
            (Ui.resize_to (Ui.layout_spec base) composite))
    in
    { overlays; view }

  let window_manager_view wm = wm.view
  let window_manager_overlays wm = wm.overlays

  (* let menu_overlay wm g ?(dx = 0) ?(dy = 0) body around =
         let sensor ~x ~y ~w ~h () =
           let row = Lwd_table.append (window_manager_overlays wm) in
           let h_pad =
             match Gravity.h g with
             | `Negative -> Ui.space (x + dx) 0
             | `Neutral -> Ui.space (x + dx + (w / 2)) 0
             | `Positive -> Ui.space (x + dx + w) 0
           in
           let v_pad =
             match Gravity.v g with
             | `Negative -> Ui.space 0 (y + dy)
             | `Neutral -> Ui.space 0 (y + dy + (h / 2))
             | `Positive -> Ui.space 0 (y + dy + h)
           in
           let view =
             Lwd.map body ~f:(fun body ->
                 let body =
                   let pad = Ui.space 1 0 in
                   Ui.join_x pad (Ui.join_x body pad)
                 in
                 let bg =
                   Ui.resize_to (Ui.layout_spec body)
                     ~bg:A.(bg lightgreen)
                     Ui.empty
                 in
                 let catchall =
                   Ui.mouse_area
                     (fun ~x:_ ~y:_ -> function
                       | `Left ->
                           Lwd_table.remove row;
                           `Handled
                       | _ -> `Handled)
                     (Ui.resize ~sw:1 ~sh:1 Ui.empty)
                 in
                 Ui.join_z catchall @@ Ui.join_y v_pad @@ Ui.join_x h_pad
                 @@ Ui.join_z bg body)
           in
           Lwd_table.set row view
         in
         Ui.transient_sensor sensor around

       (*let menu_overlay wm ?(dx=0) ?(dy=0) handler body =
         let refresh = Lwd.var () in
         let clicked = ref false in
         Lwd.map' body @@ fun body ->
         let body = let pad = Ui.space 1 0 in Ui.join_x pad (Ui.join_x body pad) in
         let bg =
           Ui.resize_to (Ui.layout_spec body) ~bg:A.(bg lightgreen) Ui.empty
         in
         let click_handler ~x:_ ~y:_ = function
           | `Left -> clicked := true; Lwd.set refresh (); `Handled
           | _ -> `Unhandled
         in
         let ui = Ui.mouse_area click_handler (Ui.join_z bg body) in
         if !clicked then (
           clicked := false;
           let sensor ~x ~y ~w:_ ~h () =
             let row = Lwd_table.append (window_manager_overlays wm) in
             let h_pad = Ui.space (x + dx) 0 in
             let v_pad = Ui.space 0 (y + h + dy) in
             let view = Lwd.map' (handler ()) @@ fun view ->
               let catchall =
                 Ui.mouse_area
                   (fun ~x:_ ~y:_ -> function
                      | `Left -> Lwd_table.remove row; `Handled
                      | _ -> `Handled)
                   (Ui.resize ~sw:1 ~sh:1 Ui.empty)
               in
               Ui.join_z catchall (Ui.join_y v_pad (Ui.join_x h_pad view))
             in
             Lwd_table.set row view
           in
           Ui.transient_sensor sensor ui
         ) else ui*)

       let scroll_step = 1

       type scroll_state = {
         position : int;
         bound : int;
         visible : int;
         total : int;
       }

       let default_scroll_state =
         { position = 0; bound = 0; visible = 0; total = 0 }

       let vscroll_area ~state ~change t =
         let visible = ref (-1) in
         let total = ref (-1) in
         let scroll state delta =
           let position = state.position + delta in
           let position = max 0 (min state.bound position) in
           if position <> state.position then
             change `Action { state with position };
           `Handled
         in
         let focus_handler state = function
           (*| `Arrow `Left , _ -> scroll (-scroll_step) 0*)
           (*| `Arrow `Right, _ -> scroll (+scroll_step) 0*)
           | `Arrow `Up, [] -> scroll state (-scroll_step)
           | `Arrow `Down, [] -> scroll state (+scroll_step)
           | `Page `Up, [] -> scroll state (-scroll_step * 8)
           | `Page `Down, [] -> scroll state (+scroll_step * 8)
           | _ -> `Unhandled
         in
         let scroll_handler state ~x:_ ~y:_ = function
           | `Scroll `Up -> scroll state (-scroll_step)
           | `Scroll `Down -> scroll state (+scroll_step)
           | _ -> `Unhandled
         in
         Lwd.map2 t state ~f:(fun t state ->
             t
             |> Ui.shift_area 0 state.position
             |> Ui.resize ~h:0 ~sh:1
             |> Ui.size_sensor (fun ~w:_ ~h ->
                    let tchange =
                      if !total <> (Ui.layout_spec t).Ui.h then (
                        total := (Ui.layout_spec t).Ui.h;
                        true)
                      else false
                    in
                    let vchange =
                      if !visible <> h then (
                        visible := h;
                        true)
                      else false
                    in
                    if tchange || vchange then
                      change `Content
                        {
                          state with
                          visible = !visible;
                          total = !total;
                          bound = max 0 (!total - !visible);
                        })
             |> Ui.mouse_area (scroll_handler state)
             |> Ui.keyboard_area (focus_handler state))

       let scroll_area ?(offset = (0, 0)) t =
         let offset = Lwd.var offset in
         let scroll d_x d_y =
           let s_x, s_y = Lwd.peek offset in
           let s_x = max 0 (s_x + d_x) in
           let s_y = max 0 (s_y + d_y) in
           Lwd.set offset (s_x, s_y);
           `Handled
         in
         let focus_handler = function
           | `Arrow `Left, [] -> scroll (-scroll_step) 0
           | `Arrow `Right, [] -> scroll (+scroll_step) 0
           | `Arrow `Up, [] -> scroll 0 (-scroll_step)
           | `Arrow `Down, [] -> scroll 0 (+scroll_step)
           | `Page `Up, [] -> scroll 0 (-scroll_step * 8)
           | `Page `Down, [] -> scroll 0 (+scroll_step * 8)
           | _ -> `Unhandled
         in
         let scroll_handler ~x:_ ~y:_ = function
           | `Scroll `Up -> scroll 0 (-scroll_step)
           | `Scroll `Down -> scroll 0 (+scroll_step)
           | _ -> `Unhandled
         in
         Lwd.map2 t (Lwd.get offset) ~f:(fun t (s_x, s_y) ->
             t |> Ui.shift_area s_x s_y
             |> Ui.mouse_area scroll_handler
             |> keyboard_area focus_handler)

       let main_menu_item wm text f =
         let text = string ~attr:attr_menu_main (" " ^ text ^ " ") in
         let refresh = Lwd.var () in
         let overlay = ref false in
         let on_click ~x:_ ~y:_ = function
           | `Left ->
               overlay := true;
               Lwd.set refresh ();
               `Handled
           | _ -> `Unhandled
         in
         Lwd.map (Lwd.get refresh) ~f:(fun () ->
             let ui = Ui.mouse_area on_click text in
             if !overlay then (
               overlay := false;
               menu_overlay wm
                 (Gravity.make ~h:`Negative ~v:`Positive)
                 (f ()) ui)
             else ui)

       let sub_menu_item wm text f =
         let text = string ~attr:attr_menu_sub text in
         let refresh = Lwd.var () in
         let overlay = ref false in
         let on_click ~x:_ ~y:_ = function
           | `Left ->
               overlay := true;
               Lwd.set refresh ();
               `Handled
           | _ -> `Unhandled
         in
         Lwd.map (Lwd.get refresh) ~f:(fun () ->
             let ui = Ui.mouse_area on_click text in
             if !overlay then (
               overlay := false;
               menu_overlay wm
                 (Gravity.make ~h:`Positive ~v:`Negative)
                 (f ()) ui)
             else ui)

       let sub_entry text f =
         let text = string ~attr:attr_menu_sub text in
         let on_click ~x:_ ~y:_ = function
           | `Left ->
               f ();
               `Handled
           | _ -> `Unhandled
         in
         Ui.mouse_area on_click text

       type pane_state =
         | Split of { pos : int; max : int }
         | Re_split of { pos : int; max : int; at : int }

       let h_pane left right =
         let state_var = Lwd.var (Split { pos = 5; max = 10 }) in
         let render state (l, r) =
           let (Split { pos; max } | Re_split { pos; max; _ }) = state in
           let l = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:pos l in
           let r = Ui.resize ~w:0 ~h:0 ~sh:1 ~sw:(max - pos) r in
           let splitter =
             Ui.resize
               ~bg:Notty.A.(bg lightyellow)
               ~w:1 ~h:0 ~sw:0 ~sh:1 Ui.empty
           in
           let splitter =
             Ui.mouse_area
               (fun ~x:_ ~y:_ -> function
                 | `Left ->
                     `Grab
                       ( (fun ~x ~y:_ ->
                           match Lwd.peek state_var with
                           | Split { pos; max } ->
                               Lwd.set state_var
                                 (Re_split { pos; max; at = x })
                           | Re_split { pos; max; at } ->
                               if at <> x then
                                 Lwd.set state_var
                                   (Re_split { pos; max; at = x })),
                         fun ~x:_ ~y:_ -> () )
                 | _ -> `Unhandled)
               splitter
           in
           let ui = Ui.join_x l (Ui.join_x splitter r) in
           let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in
           let ui =
             match state with
             | Split _ -> ui
             | Re_split { at; _ } ->
                 Ui.transient_sensor
                   (fun ~x ~y:_ ~w ~h:_ () ->
                     Lwd.set state_var (Split { pos = at - x; max = w }))
                   ui
           in
           ui
         in
         Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair left right)

       let v_pane top bot =
         let state_var = Lwd.var (Split { pos = 5; max = 10 }) in
         let render state (top, bot) =
           let (Split { pos; max } | Re_split { pos; max; _ }) = state in
           let top = Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:pos top in
           let bot = Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:(max - pos) bot in
           let splitter =
             Ui.resize
               ~bg:Notty.A.(bg lightyellow)
               ~w:0 ~h:1 ~sw:1 ~sh:0 Ui.empty
           in
           let splitter =
             Ui.mouse_area
               (fun ~x:_ ~y:_ -> function
                 | `Left ->
                     `Grab
                       ( (fun ~x:_ ~y ->
                           match Lwd.peek state_var with
                           | Split { pos; max } ->
                               Lwd.set state_var
                                 (Re_split { pos; max; at = y })
                           | Re_split { pos; max; at } ->
                               if at <> y then
                                 Lwd.set state_var
                                   (Re_split { pos; max; at = y })),
                         fun ~x:_ ~y:_ -> () )
                 | _ -> `Unhandled)
               splitter
           in
           let ui = Ui.join_y top (Ui.join_y splitter bot) in
           let ui = Ui.resize ~w:10 ~h:10 ~sw:1 ~sh:1 ui in
           let ui =
             match state with
             | Split _ -> ui
             | Re_split { at; _ } ->
                 Ui.transient_sensor
                   (fun ~x:_ ~y ~w:_ ~h () ->
                     Lwd.set state_var (Split { pos = at - y; max = h }))
                   ui
           in
           ui
         in
         Lwd.map2 ~f:render (Lwd.get state_var) (Lwd.pair top bot)
  *)

  let sub' str p l =
    if p = 0 && l = String.length str then str else String.sub str p l

  let edit_field ?(focus = Focus.make ()) state ~on_change ~on_submit
      =
    let update focus_h focus (text, pos) =
      let pos = min (max 0 pos) (String.length text) in
      let content =
        Ui.atom @@ I.hcat
        @@
        if Focus.has_focus focus then
          let attr = attr_clickable in
          let len = String.length text in
          (if pos >= len then [ I.string ~attr text ]
          else [ I.string ~attr (sub' text 0 pos) ])
          @
          if pos < String.length text then
            [
              I.string ~attr:A.(bg Color.lightred) (sub' text pos 1);
              I.string ~attr (sub' text (pos + 1) (len - pos - 1));
            ]
          else [ I.string ~attr:A.(bg Color.lightred) " " ]
        else
          [
            I.string
              ~attr:A.(font Font.underline)
              (if text = "" then " " else text);
          ]
      in
      let handler k =
        Log.debug (fun m -> m "edit_field keyboard_area handler");
        match k with
        | `Uchar c, [ `Ctrl ] when Uchar.(equal c (of_char 'U')) ->
            on_change ("", 0);
            `Handled (* clear *)
        | `Escape, [] ->
            Focus.release focus_h;
            `Handled
        | `Uchar k, _ ->
            let k = Uchar.unsafe_to_char k in
            let text =
              if pos < String.length text then
                String.sub text 0 pos ^ String.make 1 k
                ^ String.sub text pos (String.length text - pos)
              else text ^ String.make 1 k
            in
            on_change (text, pos + 1);
            `Handled
        | `Backspace, _ ->
            let text =
              if pos > 0 then
                if pos < String.length text then
                  String.sub text 0 (pos - 1)
                  ^ String.sub text pos (String.length text - pos)
                else if String.length text > 0 then
                  String.sub text 0 (String.length text - 1)
                else text
              else text
            in
            let pos = max 0 (pos - 1) in
            on_change (text, pos);
            `Handled
        | `Enter, _ ->
            on_submit (text, pos);
            `Handled
        | `Arrow `Left, [] ->
            let pos = min (String.length text) pos in
            if pos > 0 then (
              on_change (text, pos - 1);
              `Handled)
            else `Unhandled
        | `Arrow `Right, [] ->
            let pos = pos + 1 in
            if pos <= String.length text then (
              on_change (text, pos);
              `Handled)
            else `Unhandled
        | _ -> `Unhandled
      in
      Ui.keyboard_area ~focus handler content
    in
    let node =
      Lwd.map2 ~f:(update focus) (Focus.status focus) state
    in
    node
  (* let mouse_grab (text, pos) ~x ~y:_ = function
       | `Left ->
           if x <> pos then on_change (text, x);
           Nottui.Focus.request focus;
           `Handled
       | _ -> `Unhandled
     in
     Lwd.map2 state node ~f:(fun state content ->
         Ui.mouse_area (mouse_grab state) content *)

  (*
       (** Tab view, where exactly one element of [l] is shown at a time. *)
       let tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t
           =
         match tabs with
         | [] -> Lwd.return Ui.empty
         | _ ->
             let cur = Lwd.var 0 in
             Lwd.get cur >>= fun idx_sel ->
             let _, f = List.nth tabs idx_sel in
             let tab_bar =
               tabs
               |> List.mapi (fun i (s, _) ->
                      let attr =
                        if i = idx_sel then A.(st underline) else A.empty
                      in
                      let tab_annot = printf ~attr "[%s]" s in
                      Ui.mouse_area
                        (fun ~x:_ ~y:_ l ->
                          if l = `Left then (
                            Lwd.set cur i;
                            `Handled)
                          else `Unhandled)
                        tab_annot)
               |> Ui.hcat
             in
             f () >|= Ui.join_y tab_bar

       (** Horizontal/vertical box. We fill lines until there is no room,
         and then go to the next ligne. All widgets in a line are considered to
         have the same height.
         @param width dynamic width  (default 80)
     *)
       let flex_box ?(w = Lwd.return 80) (l : Ui.t Lwd.t list) : Ui.t Lwd.t
           =
         Lwd_utils.flatten_l l >>= fun l ->
         w >|= fun w_limit ->
         let rec box_render (acc : Ui.t) (i : int) l : Ui.t =
           match l with
           | [] -> acc
           | ui0 :: tl ->
               let w0 = (Ui.layout_spec ui0).Ui.w in
               if i + w0 >= w_limit then
                 (* newline starting with ui0 *)
                 Ui.join_y acc (box_render ui0 w0 tl)
               else
                 (* same line *)
                 box_render (Ui.join_x acc ui0) (i + w0) tl
         in
         box_render Ui.empty 0 l

       (** Prints the summary, but calls [f()] to compute a sub-widget
         when clicked on. Useful for displaying deep trees. *)
       let unfoldable ?(folded_by_default = true) summary
           (f : unit -> Ui.t Lwd.t) : Ui.t Lwd.t =
         let open Lwd.Infix in
         let opened = Lwd.var (not folded_by_default) in
         let fold_content =
           Lwd.get opened >>= function
           | true ->
               (* call [f] and pad a bit *)
               f () |> Lwd.map ~f:(Ui.join_x (string " "))
           | false -> empty_lwd
         in
         (* pad summary with a "> " when it's opened *)
         let summary =
           Lwd.get opened >>= fun op ->
           summary >|= fun s ->
           Ui.hcat
             [
               string ~attr:attr_clickable (if op then "v" else ">");
               string " ";
               s;
             ]
         in
         let cursor ~x:_ ~y:_ = function
           | `Left when Lwd.peek opened ->
               Lwd.set opened false;
               `Handled
           | `Left ->
               Lwd.set opened true;
               `Handled
           | _ -> `Unhandled
         in
         let mouse =
           Lwd.map ~f:(fun m -> Ui.mouse_area cursor m) summary
         in
         Lwd.map2 mouse fold_content ~f:(fun summary fold ->
             (* TODO: make this configurable/optional *)
             (* newline if it's too big to fit on one line nicely *)
             let spec_sum = Ui.layout_spec summary in
             let spec_fold = Ui.layout_spec fold in
             (* TODO: somehow, probe for available width here? *)
             let too_big =
               spec_fold.Ui.h > 1
               || spec_fold.Ui.h > 0
                  && spec_sum.Ui.w + spec_fold.Ui.w > 60
             in
             if too_big then
               Ui.join_y summary (Ui.join_x (string " ") fold)
             else Ui.join_x summary fold)

       let hbox l = Lwd_utils.pack Ui.pack_x l
       let vbox l = Lwd_utils.pack Ui.pack_y l
       let zbox l = Lwd_utils.pack Ui.pack_z l

       let vlist ?(bullet = "- ") (l : Ui.t Lwd.t list) : Ui.t Lwd.t =
         l
         |> List.map (fun ui -> Lwd.map ~f:(Ui.join_x (string bullet)) ui)
         |> Lwd_utils.pack Ui.pack_y

       (** A list of items with a dynamic filter on the items *)
       let vlist_with ?(bullet = "- ")
           ?(filter = Lwd.return (fun _ -> true)) (f : 'a -> Ui.t Lwd.t)
           (l : 'a list Lwd.t) : Ui.t Lwd.t =
         let open Lwd.Infix in
         let rec filter_map_ acc f l =
           match l with
           | [] -> List.rev acc
           | x :: l' ->
               let acc' =
                 match f x with None -> acc | Some y -> y :: acc
               in
               filter_map_ acc' f l'
         in
         let l =
           l
           >|= List.map (fun x ->
                   (x, Lwd.map ~f:(Ui.join_x (string bullet)) @@ f x))
         in
         let l_filter : _ list Lwd.t =
           filter >>= fun filter ->
           l
           >|= filter_map_ [] (fun (x, ui) ->
                   if filter x then Some ui else None)
         in
         l_filter >>= Lwd_utils.pack Ui.pack_y

       let rec iterate n f x = if n = 0 then x else iterate (n - 1) f (f x)

       (** A grid layout, with alignment in all rows/columns.
         @param max_h maximum height of a cell
         @param max_w maximum width of a cell
         @param bg attribute for controlling background style
         @param h_space horizontal space between each cell in a row
         @param v_space vertical space between each row
         @param pad used to control padding of cells
         @param crop used to control cropping of cells
         TODO: control padding/alignment, vertically and horizontally
         TODO: control align left/right in cells
         TODO: horizontal rule below headers
         TODO: headers *)
       let grid ?max_h ?max_w ?pad ?crop ?bg ?(h_space = 0) ?(v_space = 0)
           ?(headers : Ui.t Lwd.t list option)
           (rows : Ui.t Lwd.t list list) : Ui.t Lwd.t =
         let rows =
           match headers with None -> rows | Some r -> r :: rows
         in
         (* build a [ui list list Lwd.t] *)
         Lwd_utils.map_l (fun r -> Lwd_utils.flatten_l r) rows
         >>= fun (rows : Ui.t list list) ->
         (* determine width of each column and height of each row *)
         let n_cols =
           List.fold_left (fun n r -> max n (List.length r)) 0 rows
         in
         let col_widths = Array.make n_cols 1 in
         List.iter
           (fun row ->
             List.iteri
               (fun col_j cell ->
                 let w = (Ui.layout_spec cell).Ui.w in
                 col_widths.(col_j) <- max col_widths.(col_j) w)
               row)
           rows;
         (match max_w with
         | None -> ()
         | Some max_w ->
             (* limit width *)
             Array.iteri
               (fun i x -> col_widths.(i) <- min x max_w)
               col_widths);
         (* now render, with some padding *)
         let pack_pad_x =
           if h_space <= 0 then (Ui.empty, Ui.join_x)
           else (Ui.empty, fun x y -> Ui.hcat [ x; Ui.space h_space 0; y ])
         and pack_pad_y =
           if v_space = 0 then (Ui.empty, Ui.join_y)
           else (Ui.empty, fun x y -> Ui.vcat [ x; Ui.space v_space 0; y ])
         in
         let rows =
           List.map
             (fun row ->
               let row_h =
                 List.fold_left
                   (fun n c -> max n (Ui.layout_spec c).Ui.h)
                   0 row
               in
               let row_h =
                 match max_h with
                 | None -> row_h
                 | Some max_h -> min row_h max_h
               in
               let row =
                 List.mapi
                   (fun i c ->
                     Ui.resize ~w:col_widths.(i) ~h:row_h ?crop ?pad ?bg c)
                   row
               in
               Lwd_utils.reduce pack_pad_x row)
             rows
         in
         (* TODO: mouse and keyboard handling *)
         let ui = Lwd_utils.reduce pack_pad_y rows in
         Lwd.return ui

       (** Turn the given [ui] into a clickable button, calls [f] when clicked. *)
       let button_of ui f =
         Ui.mouse_area
           (fun ~x:_ ~y:_ _ ->
             f ();
             `Handled)
           ui

       (** A clickable button that calls [f] when clicked, labelled with a string. *)
       let button ?(attr = attr_clickable) s f =
         button_of (string ~attr s) f

       (* file explorer for selecting a file *)
       let file_select ?(abs = false) ?filter ~(on_select : string -> unit)
           () : Ui.t Lwd.t =
         let rec aux ~fold path =
           try
             let p_rel = if path = "" then "." else path in
             if Sys.is_directory p_rel then
               let ui () =
                 let arr = Sys.readdir p_rel in
                 let l =
                   Array.to_list arr |> List.map (Filename.concat path)
                 in
                 (* apply potential filter *)
                 let l =
                   match filter with
                   | None -> l
                   | Some f -> List.filter f l
                 in
                 let l = Lwd.return @@ List.sort String.compare l in
                 vlist_with ~bullet:"" (aux ~fold:true) l
               in
               if fold then
                 unfoldable ~folded_by_default:true
                   (Lwd.return @@ string @@ path ^ "/")
                   ui
               else ui ()
             else
               Lwd.return
               @@ button
                    ~attr:A.(st underline)
                    path
                    (fun () -> on_select path)
           with e ->
             Lwd.return
             @@ Ui.vcat
                  [
                    printf ~attr:A.(bg red) "cannot list directory %s" path;
                    string @@ Printexc.to_string e;
                  ]
         in
         let start = if abs then Sys.getcwd () else "" in
         aux ~fold:false start

       let toggle, toggle' =
         let toggle_ st (lbl : string Lwd.t) (f : bool -> unit) :
             Ui.t Lwd.t =
           let mk_but st_v lbl_v =
             let lbl =
               Ui.hcat
                 [
                   printf "[%s|" lbl_v;
                   string ~attr:attr_clickable (if st_v then "✔" else "×");
                   string "]";
                 ]
             in
             button_of lbl (fun () ->
                 let new_st = not st_v in
                 Lwd.set st new_st;
                 f new_st)
           in
           Lwd.map2 ~f:mk_but (Lwd.get st) lbl
         in
         (* Similar to {!toggle}, except it directly reflects the state of a variable. *)
         let toggle' (lbl : string Lwd.t) (v : bool Lwd.var) : Ui.t Lwd.t =
           toggle_ v lbl (Lwd.set v)
         (* a toggle, with a true/false state *)
         and toggle ?(init = false) (lbl : string Lwd.t) (f : bool -> unit)
             : Ui.t Lwd.t =
           let st = Lwd.var init in
           toggle_ st lbl f
         in
         (toggle, toggle')

       type scrollbox_state = { w : int; h : int; x : int; y : int }

       let adjust_offset visible total off =
         let off =
           if off + visible > total then total - visible else off
         in
         let off = if off < 0 then 0 else off in
         off

       let decr_if x cond = if cond then x - 1 else x
       let scrollbar_bg = Notty.A.gray 4
       let scrollbar_fg = Notty.A.gray 7

       let scrollbar_click_step =
         3 (* Clicking scrolls one third of the screen *)

       let scrollbar_wheel_step =
         8 (* Wheel event scrolls 1/8th of the screen *)

       let hscrollbar visible total offset ~set =
         let prefix = offset * visible / total in
         let suffix = (total - offset - visible) * visible / total in
         let handle = visible - prefix - suffix in
         let render size color =
           Ui.atom Notty.(I.char (A.bg color) ' ' size 1)
         in
         let mouse_handler ~x ~y:_ = function
           | `Left ->
               if x < prefix then (
                 set (offset - max 1 (visible / scrollbar_click_step));
                 `Handled)
               else if x > prefix + handle then (
                 set (offset + max 1 (visible / scrollbar_click_step));
                 `Handled)
               else
                 `Grab
                   ( (fun ~x:x' ~y:_ ->
                       set (offset + ((x' - x) * total / visible))),
                     fun ~x:_ ~y:_ -> () )
           | `Scroll dir ->
               let dir = match dir with `Down -> 1 | `Up -> -1 in
               set (offset + (dir * max 1 (visible / scrollbar_wheel_step)));
               `Handled
           | _ -> `Unhandled
         in
         let ( ++ ) = Ui.join_x in
         Ui.mouse_area mouse_handler
           (render prefix scrollbar_bg
           ++ render handle scrollbar_fg
           ++ render suffix scrollbar_bg)

       let vscrollbar visible total offset ~set =
         let prefix = offset * visible / total in
         let suffix = (total - offset - visible) * visible / total in
         let handle = visible - prefix - suffix in
         let render size color =
           Ui.atom Notty.(I.char (A.bg color) ' ' 1 size)
         in
         let mouse_handler ~x:_ ~y = function
           | `Left ->
               if y < prefix then (
                 set (offset - max 1 (visible / scrollbar_click_step));
                 `Handled)
               else if y > prefix + handle then (
                 set (offset + max 1 (visible / scrollbar_click_step));
                 `Handled)
               else
                 `Grab
                   ( (fun ~x:_ ~y:y' ->
                       set (offset + ((y' - y) * total / visible))),
                     fun ~x:_ ~y:_ -> () )
           | `Scroll dir ->
               let dir = match dir with `Down -> 1 | `Up -> -1 in
               set (offset + (dir * max 1 (visible / scrollbar_wheel_step)));
               `Handled
           | _ -> `Unhandled
         in
         let ( ++ ) = Ui.join_y in
         Ui.mouse_area mouse_handler
           (render prefix scrollbar_bg
           ++ render handle scrollbar_fg
           ++ render suffix scrollbar_bg)

       let scrollbox t =
         (* Keep track of scroll state *)
         let state_var = Lwd.var { w = 0; h = 0; x = 0; y = 0 } in
         (* Keep track of size available for display *)
         let update_size ~w ~h =
           let state = Lwd.peek state_var in
           if state.w <> w || state.h <> h then
             Lwd.set state_var { state with w; h }
         in
         let measure_size body =
           Ui.size_sensor update_size
             (Ui.resize ~w:0 ~h:0 ~sw:1 ~sh:1 body)
         in
         (* Given body and state, composite scroll bars *)
         let compose_bars body state =
           let bw, bh = (Ui.layout_width body, Ui.layout_height body) in
           (* Logic to determine which scroll bar should be visible *)
           let hvisible = state.w < bw and vvisible = state.h < bh in
           let hvisible = hvisible || (vvisible && state.w = bw) in
           let vvisible = vvisible || (hvisible && state.h = bh) in
           (* Compute size and offsets based on visibility *)
           let state_w = decr_if state.w vvisible in
           let state_h = decr_if state.h hvisible in
           let state_x = adjust_offset state_w bw state.x in
           let state_y = adjust_offset state_h bh state.y in
           (* Composite visible scroll bars *)
           let crop b =
             Ui.resize ~sw:1 ~sh:1 ~w:0 ~h:0
               (Ui.shift_area state_x state_y b)
           in
           let set_vscroll y =
             let state = Lwd.peek state_var in
             if state.y <> y then Lwd.set state_var { state with y }
           in
           let set_hscroll x =
             let state = Lwd.peek state_var in
             if state.x <> x then Lwd.set state_var { state with x }
           in
           let ( <-> ) = Ui.join_y and ( <|> ) = Ui.join_x in
           match (hvisible, vvisible) with
           | false, false -> body
           | false, true ->
               crop body <|> vscrollbar state_h bh state_y ~set:set_vscroll
           | true, false ->
               crop body <-> hscrollbar state_w bw state_x ~set:set_hscroll
           | true, true ->
               crop body
               <|> vscrollbar state_h bh state_y ~set:set_vscroll
               <-> (hscrollbar state_w bw state_x ~set:set_hscroll
                   <|> Ui.space 1 1)
         in
         (* Render final box *)
         Lwd.map2 t (Lwd.get state_var) ~f:(fun ui size ->
             measure_size (compose_bars ui size)) *)
end