(*

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)

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" 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 ]

  (* 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; "\"" ]
    | _ -> "Code Unknown!"

  let pp_code ppf v = F.pf ppf "%s" (string_of_code v)

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

  let pp_mods =
    F.(
      list (fun ppf -> function
        | `Super -> pf ppf "`Super"
        | `Meta -> pf ppf "`Meta"
        | `Ctrl -> pf ppf "`Ctrl"
        | `Shift -> pf ppf "`Shift"))

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

  type paste = [ `Start | `End ]
  type keyaction = [ `Press | `Release | `Repeat ]
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 ( = ) a b = a.r = b.r && a.g = b.g && a.b = b.b && a.a = b.a

    let ( ++ ) a b =
      {
        r = Float.clamp ~min:0. ~max:1. (a.r +. b.r);
        g = Float.clamp ~min:0. ~max:1. (a.g +. b.g);
        b = Float.clamp ~min:0. ~max:1. (a.b +. b.b);
        a = Float.clamp ~min:0. ~max:1. (a.a +. b.a);
      }

    let replace ~prev ~next = if next = none then prev else next

    let pp ppf t : unit =
      if t != none then
        F.(
          fmt "%a" ppf
            (list (fmt "%02X"))
            (List.map
               (fun e -> int_of_float (e *. 255.))
               [ t.r; t.g; t.b; t.a ]))
      else F.fmt "_" ppf
  end
end

module Color = NVG.Color

(* 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
  include NVG.Text

  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 "\"%s\"" ppf s)
end

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 pp ppf =
      F.(
        fmt "%a" ppf
          (record [ field "size" (fun a -> a.size) (option float) ]))

    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"
      | _ -> ()

    let replace ~prev ~next = merge prev next
  end

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

  let pp ppf a =
    F.(fmt "@[<h>%a/%a@]" ppf Color.pp a.fg Color.pp a.bg)

  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 =
    {
      fg = Color.(a1.fg ++ a2.fg);
      bg = Color.(a1.bg ++ a2.bg);
      font = Font.merge a1.font a2.font;
    }

  let replace ~prev ~next =
    {
      fg = Color.replace ~prev:prev.fg ~next:next.fg;
      bg = Color.replace ~prev:prev.bg ~next:next.bg;
      font = Font.replace ~prev:prev.font ~next:next.font;
    }

  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

module A = Style

module I = struct
  open Gg

  type dim = p2

  type t =
    | Empty
    | Segment of Text.t (* box2 is +crop/-pad of drawn 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 bounds_segment vg p : Text.t -> NVG.Text.bounds = function
    | String s ->
        let open NVG.Text in
        let { ascender; _ } = NVG.Text.metrics vg in
        bounds vg ~x:(V2.x p) ~y:(V2.y p +. ascender) s

  let rec size vg p = function
    | Empty -> V2.zero
    | Segment s ->
        let NVG.Text.{ box = { ymax; ymin; _ }; advance } =
          bounds_segment vg p s
        in
        V2.v advance (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) ->
        (* positive values are crop, negative is pad *)
        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.(replace ~prev:a0 ~next:a))
    | 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)

  (* crop is positive value, pad is negative *)

  let hcrop left right img =
    (* Log.debug (fun m -> m "Hcrop (%f, %f)" left right); *)
    Hcrop (img, left, right)

  let vcrop top bottom img =
    (* Log.debug (fun m -> m "Vcrop (%f, %f)" top bottom); *)
    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 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
      NVG.save vg;
      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;
      NVG.restore vg;
      (* Log.debug (fun m -> m "fill_box: %a" Box2.pp b); *)
      Box2.size 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.size b

    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 ?(attr = A.empty) ppf : t -> unit =
      let open F in
      let compose = pair (parens (pp ~attr)) (parens (pp ~attr)) in
      function
      | Empty -> fmt "Empty" ppf
      | Segment v -> fmt "@[<h>Segment %a@]" ppf Text.pp v
      | Attr (t, a) ->
          fmt "@[<h>Attr %a@]" ppf
            (pair ~sep:comma A.pp
               (pp ~attr:A.(replace ~prev:attr ~next:a)))
            (A.(replace ~prev:attr ~next:a), t)
      | Hcompose a -> fmt "Hcat %a" ppf compose a
      | Vcompose a -> fmt "Vcat %a" ppf compose a
      | Zcompose a -> fmt "Zcat %a" ppf compose a
      | Hcrop (t, left, right) ->
          fmt "Hcrop (%.1f,%.1f,%a)" ppf left right (pp ~attr) t
      | Vcrop (t, top, bottom) ->
          fmt "Vcrop (%.1f,%.1f,%a)" ppf top bottom (pp ~attr) t
      | Void dim -> fmt "Void %a" ppf (parens V2.pp) dim

    let segment_kern_cache = ref (Box2.zero, "")

    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 p' =
               let cache_p, cache_s = !segment_kern_cache in
               (* tries to get the kerning right across segments *)
               if V2.(equal (Box2.max cache_p) p) then
                 V2.(
                   Box2.o cache_p
                   + v
                       ((bounds_segment vg (Box2.o cache_p)
                           (Text.of_string (cache_s ^ s)))
                          .advance
                      -. (bounds_segment vg p (Text.of_string s)).advance
                       )
                       0.)
               else p
             in *)
          let metrics = NVG.Text.metrics vg in
          NVG.Text.text vg ~x:(V2.x p)
            ~y:(V2.y p +. metrics.ascender)
            s;

          let sz =
            V2.v (bounds_segment vg p (Text.of_string s)).advance
              metrics.line_height
          in
          segment_kern_cache := (Box2.(v p sz), s);
          sz

    and node vg attr p n : p2 =
      (* returns the *size* of the drawn area not the max coordinates anymore *)
      let b' =
        match n with
        | Empty | Void _ -> p
        | Segment text -> segment vg p text
        | Attr (i, a) ->
            let a0 = A.(replace ~prev:attr ~next:a) in
            if
              (A.(a.bg) != A.(attr.bg))
              && A.(a0.bg) != NVG.Color.transparent
            then fill_box vg a0.bg (Box2.v p (size vg p i)) |> ignore;
            if A.(attr.fg) != a.fg then (
              NVG.set_fill_color vg ~color:Style.(a0.fg);
              NVG.set_stroke_color vg ~color:Style.(a0.fg));
            node vg 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) ->
            let p0 = size vg p i in
            NVG.save vg;
            NVG.Scissor.scissor vg ~x:(V2.x p) ~y:(V2.y p)
              ~w:(V2.x p0 -. right)
              ~h:(V2.y p0);
            let p1 = node vg attr V2.(p - v left 0.) i in
            NVG.restore vg;
            V2.(p1 - v (left +. right) 0.)
        | Vcrop (i, top, bottom) ->
            let p0 = size vg p i in
            NVG.save vg;
            NVG.Scissor.scissor vg ~x:(V2.x p) ~y:(V2.y p)
              ~w:(V2.x p0)
              ~h:(V2.y p0 -. bottom);
            let p1 = node vg attr V2.(p - v 0. top) i in
            NVG.restore vg;
            V2.(p1 - v 0. (top +. bottom))
      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
    val pp_var : Format.formatter -> var -> unit
    val pp_status : Format.formatter -> status -> unit
  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;
      Log.debug (fun m ->
          m "Focus.request_var v=%d clock=%d" (Lwd.peek v) !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 | Handle (0, _)), x | x, (Empty | Handle (0, _)) -> x
      | 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

    let pp_var ppf v = F.pf ppf "%d" (Lwd.peek v)

    let pp_status ppf = function
      | Empty -> F.pf ppf "Empty"
      | Handle (i, v) -> F.pf ppf "Handle (%d, %a)" i pp_var v
      | Conflict i -> F.pf ppf "Conflict %d" i
  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 = { h : direction; v : direction }

    let default = { h = `Neutral; v = `Neutral }
    let make ~h ~v = { h; v }
    let h x = x.h
    let v x = x.v

    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)

    type t2 = t * t

    let pair t1 t2 = (t1, t2)
    let p1 (t, _) = t
    let p2 (_, t) = t
  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 -> float
    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 ]

    let may_handle (type a) (v : a option) (f : a -> may_handle) :
        may_handle =
      match v with Some v' -> f v' | None -> `Unhandled

    let pp_may_handle ppf = function
      | `Unhandled -> F.pf ppf "`Unhandled"
      | `Handled -> F.pf ppf "`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

    let pp_key =
      F.(
        pair
          (fun ppf v ->
            match v with
            | `Copy -> pf ppf "`Copy"
            | `Paste -> pf ppf "`Paste"
            | `Focus v ->
                pf ppf "`Focus %s"
                  (match v with
                  | `Next -> "`Next"
                  | `Prev -> "`Prev"
                  | `Left -> "`Left"
                  | `Right -> "`Right"
                  | `Up -> "`Up"
                  | `Down -> "`Down")
            | a -> pf ppf "%a" Input.pp_code a)
          Input.pp_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_float ppf = F.fmt "%.1f" ppf

    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 image = I.t
    type cache = { vx : Interval.t; vy : Interval.t; image : image }

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

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

    let layout_spec (t : 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 pp_layout_spec ppf { w; h; sw; sh; _ } =
      let p = pp_float in
      Format.fprintf ppf "{w=%a;@ h=%a;@ sw=%a;@ sh=%a}" p w p h p sw
        p sh

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

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

    let atom img : t =
      {
        w = 0.;
        h = 0.;
        sw = 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) : 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 ?(attr = A.empty) (t : t) : t
        =
      let _ = attr in
      let wo, ho = (w, h) in
      let g = prepare_gravity (pad, crop) in
      match ((w, t.w), (h, t.h), (sw, t.sw), (sh, t.sh)) with
      | ( (Some w, _ | _, w),
          (Some h, _ | _, h),
          (Some sw, _ | _, sw),
          (Some sh, _ | _, sh) ) ->
          { t with w; h; sw; sh; desc = Resize (t, wo, ho, g) }

    let resize_to (l : layout_spec) ?pad ?crop ?(attr = A.empty) t : t
        =
      let _ = attr in
      let g = prepare_gravity (pad, crop) in
      { t with desc = Resize (t, Some l.w, Some l.h, g) }

    let event_filter ?focus f (t : 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 : t) (b : t) =
      {
        empty with
        w = a.w +. b.w;
        h = max a.h b.h;
        sw = a.sw +. b.sw;
        sh = max a.sh b.sh;
        flags = a.flags lor b.flags;
        focus = Focus.merge a.focus b.focus;
        desc = X (a, b);
      }

    let join_y (a : t) (b : t) =
      {
        empty with
        w = max a.w b.w;
        h = a.h +. b.h;
        sw = max a.sw b.sw;
        sh = a.sh +. b.sh;
        flags = a.flags lor b.flags;
        focus = Focus.merge a.focus b.focus;
        desc = Y (a, b);
      }

    let join_z (a : t) (b : t) =
      {
        empty with
        w = max a.w b.w;
        h = max a.h b.h;
        sw = max a.sw b.sw;
        sh = max a.sh b.sh;
        flags = a.flags lor b.flags;
        focus = Focus.merge a.focus b.focus;
        desc = Z (a, b);
      }

    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 =
      F.pf ppf "@[<hov>focus=%a %a@]" Focus.pp_status t.focus pp_desc
        t.desc

    and pp_desc ppf = function
      | Atom a ->
          Format.fprintf ppf "Atom @[<hov>(%a)@]"
            (I.Draw.pp ?attr:None) a
      | 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, x, y, _gravity) ->
          F.pf ppf "Resize (%a, %a,@ _,@ %a)" (F.option pp_float) x
            (F.option pp_float) y
            (* Gravity.pp (Gravity.p1 gravity) Gravity.pp
               (Gravity.p2 gravity) *)
            pp desc
      | Mouse_handler (n, _) ->
          Format.fprintf ppf "%a" (*"Mouse (%a,@ _)"*) pp n
      | Focus_area (n, _) -> Format.fprintf ppf "Focus (%a,@ _)" pp n
      | Shift_area (n, x, y) ->
          Format.fprintf ppf "Shift (%.0f,%.0f,%a)" x y pp n
      | Event_filter (n, _) ->
          Format.fprintf ppf "Event (%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 = {
      vg : NVG.t;
      mutable size : size;
      mutable view : ui;
      mutable mouse_grab : grab_function option;
    }

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

    let size t = t.size

    let iter f (ui : 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

    let solve_focus (ui : 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 _ -> iter aux ui
      in
      aux ui

    let split ~a ~sa ~b ~sb total =
      let stretch = sa +. sb in
      let flex = total -. a -. b in
      let a', b' =
        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)
      in
      (* Log.debug (fun m ->
               m
                 "split: a=%.1f sa=%.1f b=%.1f sb=%.1f total=%.1f (%.1f, \
                  %.1f)"
                 a sa b sb total a' b'); *)
      (a', b')

    let pack ~fixed ~stretch total g1 g2 =
      let v1, v2 =
        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)
      in
      (* Log.debug (fun m ->
           m "pack fixed=%.1f stretch=%.1f total=%.1f (%.1f, %.1f)"
             fixed stretch total v1 v2); *)
      (v1, v2)

    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 : 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, x, y, g) ->
            let open Gravity in
            let dx, rw =
              pack
                ~fixed:(Option.value x ~default:t.w)
                ~stretch:t.sw sw
                (h (p1 g))
                (h (p2 g))
            in
            let dy, rh =
              pack
                ~fixed:(Option.value y ~default: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 rec t_size_desc_of_t vg (size : box2) (ui : Ui.t desc) =
      match ui with
      | Atom _ as a -> a
      | Size_sensor (t, v) -> Size_sensor (t_size_of_t vg size t, v)
      | Mouse_handler (t, v) ->
          Mouse_handler (t_size_of_t vg size t, v)
      | Focus_area (t, v) -> Focus_area (t_size_of_t vg size t, v)
      | Event_filter (t, v) -> Event_filter (t_size_of_t vg size t, v)
      | Transient_sensor (t, v) ->
          Transient_sensor (t_size_of_t vg size t, v)
      | Permanent_sensor (t, v) ->
          Permanent_sensor (t_size_of_t vg size t, v)
      | Resize (t, w, h, g2) ->
          Resize
            ( t_size_of_t vg
                (Box2.v (Box2.o size)
                   (V2.v
                      (Option.value w ~default:(Box2.w size))
                      (Option.value h ~default:(Box2.h size))))
                t,
              w,
              h,
              g2 )
      | Shift_area (t, sx, sy) ->
          Shift_area
            ( t_size_of_t vg
                (Box2.of_pts
                   V2.(Box2.o size - of_tuple (sx, sy))
                   (Box2.max size))
                t,
              sx,
              sy )
      | X (a, b) ->
          let a' = t_size_of_t vg size a in
          let b' =
            t_size_of_t vg
              (Box2.of_pts
                 V2.(v (Box2.minx size +. a'.w) (Box2.miny size))
                 (Box2.max size))
              b
          in
          X (a', b')
      | Y (a, b) ->
          let a' = t_size_of_t vg size a in
          let b' =
            t_size_of_t vg
              (Box2.of_pts
                 V2.(v (Box2.minx size) (Box2.miny size +. a'.h))
                 (Box2.max size))
              b
          in
          Y (a', b')
      | Z (a, b) -> Z (t_size_of_t vg size a, t_size_of_t vg size b)

    and t_size_of_t vg (size : box2) (ui : Ui.t) : ui =
      let desc = t_size_desc_of_t vg size ui.desc in
      let w, h =
        match desc with
        | Atom i -> V2.to_tuple (I.size vg (Box2.o size) i)
        | Size_sensor (t, _)
        | Mouse_handler (t, _)
        | Focus_area (t, _)
        | Event_filter (t, _)
        | Transient_sensor (t, _)
        | Permanent_sensor (t, _) ->
            (t.w, t.h)
        | Resize (t, w, h, _) ->
            (Option.value w ~default:t.w, Option.value h ~default:t.h)
        | Shift_area (t, x, y) -> (t.w +. x, t.h +. y)
        | X (a, b) -> (a.w +. b.w, max a.h b.h)
        | Y (a, b) -> (max a.w b.w, a.h +. b.h)
        | Z (a, b) -> (max a.w b.w, max a.h b.h)
      in
      { ui with w; h; desc; sensor_cache = None; cache }

    let update t size (ui : Ui.t) =
      t.size <- size;
      t.view <- t_size_of_t t.vg (Box2.v V2.zero size) ui;
      update_sensors 0. 0. (P2.x size) (P2.y size) t.view;
      update_focus t.view

    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) ->
            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
      (* Log.debug (fun m ->
           m "resize_canvas: w=%.1f rw=%.1f h=%.1f rh=%.1f" w rw h rh); *)
      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 =
      (* Log.debug (fun m ->
           m
             "render_node vx1=%.0f@ vy1=%.0f@ vx2=%.0f@ vy2=%.0f@ \
              sw=%.0f@ sh=%.0f@ @[%a@]"
             vx1 vy1 vx2 vy2 sw sh pp t); *)
      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) ->
              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 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) -> (
                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
            dispatch_focus t' dir || grab_focus t
          else if Focus.has_focus t.focus then false
          else 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, _) ->
          Log.warn (fun m ->
              m "Renderer.dispatch_focus %a" pp_key key);
          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 vg () 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 =
      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 -> ()
          | `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.((bg @@ Color.rgbf ~r:0.2 ~g:0.2 ~b:0.5) ++ (fg @@ Color.light))

  let attr_cursor = A.((fg @@ Color.dark) ++ (bg @@ Color.yellow))

  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)
                ~attr:A.(bg Color.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 = 7.

  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*)
        |> Ui.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 : float; max : float }
    | Re_split of { pos : float; max : float; at : float }

  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
          ~attr:A.(bg Color.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:100. ~h:100. ~sw:10. ~sh:10. 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
          ~attr:A.(bg Color.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 ()) ?(on_change = Fun.id) state
      =
    let on_change a = Lwd.set state (on_change a) in
    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; I.string ~attr:attr_cursor " " ]
          else
            [
              I.string ~attr (String.sub text 0 pos);
              I.string ~attr:attr_cursor (String.sub text pos 1);
              I.string ~attr
                (String.sub text (pos + 1) (len - pos - 1));
            ]
        else [ I.string (if text = "" then " " else text) ]
      in
      let handler k =
        (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, [] ->
            if pos > 0 then (
              let text =
                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
              in
              let pos = max 0 (pos - 1) in
              on_change (text, pos);
              `Handled)
            else `Unhandled
        (* | `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)
        |> fun r ->
        Log.debug (fun m ->
            m "edit_field keyboard_area handler %a -> %a" Ui.pp_key k
              Ui.pp_may_handle r);
        r
      in
      Ui.keyboard_area ~focus handler content
    in
    let node =
      Lwd.map2 ~f:(update focus) (Focus.status focus) (Lwd.get 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 *)

  open Lwd.Infix

  let eq_uc_c uc c = Uchar.(equal uc (of_char c))

  type line = {
    focus : Focus.handle;
    state : (string * int) Lwd.var;
    ui : Ui.t Lwd.t;
  }

  let line_make ?(focus = Focus.make ()) str =
    let state = Lwd.var (str, 0) in
    { focus; state; ui = edit_field ~focus state }

  let line_append ?(table = Lwd_table.make ()) ?focus str =
    let row = Lwd_table.append table in
    Lwd_table.set row (line_make ?focus str)

  let copy_line_cursor (x : line) (y : line) =
    let _, xi = Lwd.peek x.state in
    let ys, _ = Lwd.peek y.state in
    let yi = Int.max 0 (Int.min xi (String.length ys)) in
    Lwd.set y.state (ys, yi)

  let row_of_cursor cursor f =
    Ui.may_handle (Lwd.peek cursor) (fun row -> f row)

  let line_of_cursor cursor
      (f : line Lwd_table.row -> line -> Ui.may_handle) :
      Ui.may_handle =
    Ui.may_handle (Lwd.peek cursor) (fun row ->
        Ui.may_handle (Lwd_table.get row) (fun line -> f row line))

  let cursor_move cursor
      (f : line Lwd_table.row -> line Lwd_table.row option) =
    match Lwd.peek cursor with
    | Some cursor_row -> (
        match f cursor_row with
        | Some new_row ->
            (match Lwd_table.get new_row with
            | Some new_line ->
                cursor_row |> Lwd_table.get
                |> Option.iter (fun cursor_line ->
                       copy_line_cursor cursor_line new_line;
                       Focus.release cursor_line.focus);
                Focus.request new_line.focus
            | None -> ());
            Lwd.set cursor (Some new_row);
            `Handled
        | None -> `Unhandled)
    | None -> `Unhandled

  let line_table_of_string ?(table = Lwd_table.make ())
      ?(focus = Focus.make ()) (s : string) : Ui.t Lwd.t =
    (* Append lines from s to table *)
    List.iter (line_append ~table) (String.split_on_char '\n' s);
    (* create the cursor var *)
    let cursor = Lwd.var @@ Lwd_table.first table in
    Option.iter
      (fun cursor ->
        Option.iter (fun first -> Focus.request first.focus)
        @@ Lwd_table.get cursor)
      (Lwd.peek cursor);

    (* Build view of table *)
    Lwd_table.map_reduce
      (fun _ { ui; _ } -> ui)
      (Lwd_utils.lift_monoid Ui.pack_y)
      table
    |> Lwd.join
    |> Lwd.map2
         ~f:(fun focus ->
           Ui.keyboard_area ~focus (fun k ->
               Log.debug (fun m ->
                   m "line_table handler %a" Ui.pp_key k);
               match k with
               | `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
                   cursor_move cursor (fun c -> Lwd_table.next c)
               | `Arrow `Down, _ ->
                   cursor_move cursor (fun c -> Lwd_table.next c)
               | `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
                   cursor_move cursor (fun c -> Lwd_table.prev c)
               | `Arrow `Up, _ ->
                   cursor_move cursor (fun c -> Lwd_table.prev c)
               | `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
                   cursor_move cursor (fun _ -> Lwd_table.first table)
               | `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
                   cursor_move cursor (fun _ -> Lwd_table.last table)
               | `Enter, [] ->
                   line_of_cursor cursor (fun old_row old_line ->
                       let str, pos = Lwd.peek old_line.state in
                       let o_str = String.sub str 0 pos in
                       let n_str =
                         String.(sub str pos (length str - pos))
                       in
                       Lwd.set old_line.state (o_str, pos);
                       let new_line = line_make n_str in
                       Focus.release old_line.focus;
                       Focus.request new_line.focus;
                       Lwd.set cursor
                         (Some (Lwd_table.after old_row ~set:new_line));
                       `Handled)
               | `Backspace, [] ->
                   line_of_cursor cursor (fun row line ->
                       let str, pos = Lwd.peek line.state in
                       Ui.may_handle (Lwd_table.prev row)
                         (fun row_prev ->
                           if pos = 0 then
                             Ui.may_handle (Lwd_table.get row_prev)
                               (fun line_prev ->
                                 let str_prev, _ =
                                   Lwd.peek line_prev.state
                                 in
                                 Focus.release line.focus;
                                 Focus.request line_prev.focus;
                                 Lwd.set line_prev.state
                                   ( str_prev ^ str,
                                     String.length str_prev );
                                 Lwd.set cursor (Some row_prev);
                                 Lwd_table.remove row;
                                 `Handled)
                           else `Unhandled))
               | _ -> `Unhandled))
         (Focus.status focus)

  (** 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.(bg Color.blue) 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 : float;
    h : float;
    x : float;
    y : float;
  }

  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 scrollbar_width = 10.
  let decr_if x cond = if cond then x -. scrollbar_width else x
  let scrollbar_bg = Color.gray 0.4
  let scrollbar_fg = Color.gray 0.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 (I.attr (A.bg color) (I.void size scrollbar_width))
    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 (I.char ~attr:(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:scrollbar_width ~sh:scrollbar_width ~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 scrollbar_width scrollbar_width)
    in
    (* Render final box *)
    Lwd.map2 t (Lwd.get state_var) ~f:(fun ui size ->
        measure_size (compose_bars ui size))
end