(* why *)

(*

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

let when_some (f : 'b -> 'a -> 'a) (o : 'b option) (v : 'a) : 'a =
  match o with Some a -> f a v | None -> v

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 store = S.t
  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 () : store Lwt.t =
    (* test_populate ()*)
    S.Repo.v (Config.init "") >>= fun repo ->
    S.of_branch repo "current" >>= fun t ->
    Git_console_http.connect Mimic.empty >>= fun ctx ->
    let upstream =
      S.remote ~ctx "https://localhost:8080/console/rootstore.git"
    in
    Sync.fetch_exn t upstream >>= fun _ -> Lwt.return t
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 | `Alt ] list

  let pp_mods =
    F.(
      list ~sep:F.sp (fun ppf -> function
        | `Super -> pf ppf "`Super"
        | `Alt -> pf ppf "`Alt"
        | `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 [ `Alt ] 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 [ `Meta ] 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

  let menu_main = bg Color.green ++ fg Color.black
  let menu_sub = bg Color.lightgreen ++ fg Color.black

  let clickable =
    (bg @@ Color.rgbf ~r:0.2 ~g:0.2 ~b:0.5) ++ (fg @@ Color.light)

  let cursor = (fg @@ Color.dark) ++ (bg @@ Color.yellow)
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 *)
      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:
               - w, h are positive only
            *)
            NVG.Scissor.scissor vg
              ~x:(V2.(x p) +. left)
              ~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) +. top)
              ~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
            (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
            (Box2.v p 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 var : handle -> var
    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 var (h : handle) : var = fst h
    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) =
      Log.debug (fun m ->
          m "Focus.release v=%d clock=%d" (Lwd.peek v) !clock);
      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

    type keys = key list

    let pp_key =
      F.(
        pair ~sep:F.sp
          (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)

    let pp_keys = F.(list ~sep:F.comma pp_key)

    type mouse = Input.mouse

    type event =
      [ `Keys of keys | `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
      | Attr of 'a * Style.t
      | 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 * (keys -> may_handle)
      | Pad of 'a * (float * float * float * float)
      | Shift_area of 'a * float * float
      | Event_filter of
          'a * ([ `Keys of keys | `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 attr a t = { t with desc = Attr (t, a) }
    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 pad ?a ?(l = 0.) ?(r = 0.) ?(t = 0.) ?(b = 0.) tt =
      when_some attr a { tt with desc = Pad (tt, (l, r, t, b)) }

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

    and pp_desc ppf = function
      | Atom a ->
          Format.fprintf ppf "Atom @[<hov>(%a)@]"
            (I.Draw.pp ?attr:None) a
      | Attr (desc, a) -> F.pf ppf "Attr (%a, %a)" Style.pp a pp desc
      | 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
      | Pad (n, (l, r, t, b)) ->
          F.pf ppf "Pad (%.0f,%.0f,%.0f,%.0f,%a)" l r t b 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 _ -> ()
      | Attr (u, _)
      | Size_sensor (u, _)
      | Transient_sensor (u, _)
      | Permanent_sensor (u, _)
      | Resize (u, _, _, _)
      | Mouse_handler (u, _)
      | Focus_area (u, _)
      | Pad (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 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 _ -> ()
        | Attr (t, _)
        | 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
        | Pad (tt, (l, r, t, b)) ->
            update_sensors (ox +. l) (oy +. t) (sw +. r) (sh +. b) tt
        | 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
      | Attr (t, v) -> Attr (t_size_of_t vg size t, v)
      | 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 )
      | Pad (tt, (l, r, t, b)) ->
          Pad
            ( t_size_of_t vg
                (Box2.of_pts
                   V2.(Box2.o size + of_tuple (l, t))
                   V2.(Box2.max size + of_tuple (r, b)))
                tt,
              (l, r, t, b) )
      | 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)
        | Attr (t, _)
        | 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)
        | Pad (tt, (l, r, t, b)) -> (tt.w +. l +. r, tt.h +. t +. b)
        | 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)
        | Attr (desc, _)
        | Size_sensor (desc, _)
        | Transient_sensor (desc, _)
        | Permanent_sensor (desc, _)
        | Focus_area (desc, _) ->
            aux ox oy sw sh desc
        | Pad (desc, (l, r, t, b)) ->
            aux (ox +. l) (oy +. t) (sw +. r) (sh +. b) 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 ->
              let image =
                if Focus.has_focus t.focus then (
                  Log.debug (fun m -> m "render_node Atom has_focus");
                  I.attr A.clickable image)
                else image
              in
              {
                vx = Interval.make 0. sw;
                vy = Interval.make 0. sh;
                image = resize_canvas vg sw sh image;
              }
          | Attr (desc, attr) ->
              let cache = render_node vg vx1 vy1 vx2 vy2 sw sh desc in
              { cache with image = I.attr attr cache.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, _) ->
              render_node vg vx1 vy1 vx2 vy2 sw sh 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 }
          | Pad (t', (l, r, t, b)) ->
              let cache =
                render_node vg (vx1 +. l) (vy1 +. t)
                  (vx2 +. l +. r)
                  (vy2 +. t +. b)
                  (sw +. r) (sh +. b) t'
              in
              let vx = Interval.make vx1 vx2
              and vy = Interval.make vy1 vy2 in
              let image =
                resize_canvas vg sw sh (I.pad ~l ~r ~t ~b 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 keys =
      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 keys with
                    | `Handled -> `Handled
                    | `Unhandled -> iter tl))
            | Attr (t, _)
            | Mouse_handler (t, _)
            | Size_sensor (t, _)
            | Transient_sensor (t, _)
            | Permanent_sensor (t, _)
            | Pad (t, _)
            | Shift_area (t, _, _)
            | Resize (t, _, _, _) ->
                iter (t :: tl)
            | Event_filter (t, f) -> (
                match f (`Keys keys) 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
      Log.debug (fun m -> m "grab_focus");
      try
        aux ui;
        false
      with Acquired_focus ->
        Log.warn (fun m -> m "grab_focus Acquired_focus -> true");
        true

    let rec dispatch_focus t dir =
      match t.desc with
      | Atom _ -> false
      | Attr (t, _)
      | Mouse_handler (t, _)
      | Size_sensor (t, _)
      | Transient_sensor (t, _)
      | Permanent_sensor (t, _)
      | Pad (t, _)
      | Shift_area (t, _, _)
      | Resize (t, _, _, _)
      | Event_filter (t, _) ->
          dispatch_focus t dir
      | Focus_area (t', _) ->
          if Focus.has_focus t'.focus then (
            Log.debug (fun m ->
                m
                  "dispatch_focus Focus_area has_focus t'.focus = \
                   true");

            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 (keys : Ui.keys) =
      match (dispatch_raw_key st keys, keys) 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) ]
        when mods == [] || mods = [ `Shift ] ->
          dispatch_key st
            [
              ( `Focus (if List.mem `Shift mods then `Prev else `Next),
                mods );
            ]
      | `Unhandled, [ (`Focus dir, _) ] ->
          let r = dispatch_focus st.view dir in
          (if r then Log.debug else Log.warn) (fun m ->
              m "Renderer.dispatch_focus key:%a -> %b" pp_keys keys r);
          if r then `Handled else `Unhandled
      | `Unhandled, _ -> `Unhandled

    let dispatch_event t = function
      | `Keys keys -> dispatch_key t keys
      | `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 key_list = ref [] in
    let process_event e =
      match e with
      | `Keys [ (`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))
      | `Keys [ (`Unknown _, _) ] -> ()
      | `Keys k -> (
          key_list := !key_list @ k;
          match
            Renderer.dispatch_event renderer (`Keys !key_list)
          with
          | `Handled -> key_list := []
          | `Unhandled -> ())
      | #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 Widgets = struct
  (* Majority of this was adapted from Nottui_widgets *)

  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 eq_uc_c uc c = Uchar.(equal uc (of_char c))

  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

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

  let display_keys (k : Ui.keys option Lwd.var) : Ui.t Lwd.t =
    Lwd.map (Lwd.get k) ~f:(function
      | Some k' -> string (F.str "%a" Ui.pp_keys k')
      | None -> string "---")

  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 keys = Lwd.var None in
    let view =
      Lwd.map2 base composition ~f:(fun base composite ->
          Ui.event_filter
            (function
              | `Keys k' ->
                  Log.debug (fun m ->
                      m "event_filter: window_manager `Keys %a"
                        Ui.pp_keys k');
                  Lwd.set keys (Some k');
                  if
                    List.mem
                      (`Uchar (Uchar.of_char 'g'), [ `Ctrl ])
                      k'
                  then `Handled
                  else `Unhandled
              | _ -> `Unhandled)
            (Ui.join_z base
               (Ui.resize_to (Ui.layout_spec base) composite)))
    in
    let view =
      Lwd.map2 view (display_keys keys) ~f:(fun view extra ->
          Ui.join_y view extra)
    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 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 (fun e ->
               Log.debug (fun m ->
                   m "keyboard_area: scroll_area focus_handler");
               match e with
               | [ (`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))

  let main_menu_item wm text f =
    let text = string ~attr:A.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:A.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:A.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 edit_field ?(focus = Focus.make ()) ?(on_change = Fun.id) state
      =
    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 = A.clickable in
          let len = String.length text in
          if pos >= len then
            [ I.string ~attr text; I.string ~attr:A.cursor " " ]
          else
            [
              I.string ~attr (String.sub text 0 pos);
              I.string ~attr:A.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 =
        let on_change a =
          Lwd.set state (on_change a);
          `Handled
        in
        (match k with
        | [ (`Uchar c, [ `Ctrl ]) ] when Uchar.(equal c (of_char 'U'))
          ->
            on_change ("", 0) (* clear *)
        | [ (`End, []) ] -> on_change (text, String.length text)
        | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'e' ->
            on_change (text, String.length text)
        | [ (`Home, []) ] -> on_change (text, 0)
        | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'a' ->
            on_change (text, String.length text)
        | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'k' ->
            (* TODO put killed text into kill-ring *)
            if pos < String.length text then
              on_change (String.sub text 0 pos, pos)
            else `Unhandled (* kill *)
        | [ (`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)
            else `Unhandled
        | [ (`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)
        | [ _; (`Escape, []) ] ->
            Focus.release focus_h;
            `Handled
        | [ (`Arrow `Left, []) ] ->
            if pos > 0 then on_change (text, pos - 1) else `Unhandled
        | [ (`Arrow `Right, []) ] ->
            let pos = pos + 1 in
            if pos <= String.length text then on_change (text, pos)
            else `Unhandled
        | _ -> `Unhandled)
        |> fun r ->
        Log.debug (fun m ->
            m "edit_field keyboard_area handler %a -> %a" Ui.pp_keys 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 *)

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

  type lines = line Lwd_table.t

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

  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 string_of_line { state; _ } =
    let str, _ = Lwd.peek state in
    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 ?(update : 'a -> 'a -> unit = fun _ _ -> ())
      (cursor : 'a Lwd_table.row option Lwd.var)
      (new_row : 'a Lwd_table.row -> 'a Lwd_table.row option) =
    match Lwd.peek cursor with
    | Some cursor_row -> (
        match new_row cursor_row with
        | Some new_row ->
            (match Lwd_table.get new_row with
            | Some new_line ->
                Lwd_table.get cursor_row
                |> Option.iter (fun cursor_line ->
                       update 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 ()) (s : string) :
      line Lwd_table.t =
    (* Append lines from s to table *)
    List.iter (line_append ~table) (String.split_on_char '\n' s);
    table

  let focus_val focus : int =
    Focus.(
      match focus with
      | Empty -> 0
      | Handle (i, _) -> i
      | Conflict i -> i)

  let rec find_focus (ui : ui) : ui =
    Focus.(
      match (ui.focus, ui.desc) with
      | Empty, _ -> Ui.empty
      | Handle (_, _), _ -> ui
      | Conflict _, (X (a, b) | Y (a, b) | Z (a, b)) ->
          if focus_val a.focus < focus_val b.focus then find_focus b
          else find_focus a
      | Conflict _, Atom _ -> Ui.empty
      | ( Conflict _,
          ( Attr (t, _)
          | Size_sensor (t, _)
          | Mouse_handler (t, _)
          | Focus_area (t, _)
          | Event_filter (t, _)
          | Transient_sensor (t, _)
          | Permanent_sensor (t, _)
          | Resize (t, _, _, _)
          | Pad (t, _)
          | Shift_area (t, _, _) ) ) ->
          find_focus t)

  let focus_handle_compare a b =
    if
      Lwd.peek (Focus.var (snd a).focus)
      < Lwd.peek (Focus.var (snd b).focus)
    then b
    else a

  let focused_row_of_table (table : line Lwd_table.t) =
    Lwd_table.map_reduce
      (fun row (line : line) -> (Some row, line))
      ((None, line_empty ()), focus_handle_compare)
      table

  let to_lwt_lwd e = Lwt.return @@ Lwd.pure e
  let lwt_lwd_string s = to_lwt_lwd @@ string s

  let edit_area ?(table = Lwd_table.make ()) ?(focus = Focus.make ())
      () : Ui.t Lwd.t =
    let cursor = Lwd.var @@ Lwd_table.first table in
    Lwd.peek cursor
    |> Option.iter (fun cursor ->
           Lwd_table.get cursor
           |> Option.iter (fun first -> Focus.request first.focus));

    (* Build view of table *)
    Lwd_table.map_reduce
      (fun _ { ui; _ } -> ui)
      (Lwd_utils.lift_monoid Ui.pack_y)
      table
    |> Lwd.join
    |> Lwd.map2 (Focus.status focus) ~f:(fun focus ->
           Ui.keyboard_area ~focus (fun k ->
               Log.debug (fun m ->
                   m "keyboard_area: edit_area handler %a" Ui.pp_keys
                     k);
               let cursor_move =
                 cursor_move ~update:copy_line_cursor cursor
               in
               match k with
               | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'n' ->
                   cursor_move Lwd_table.next
               | [ (`Arrow `Down, _) ] -> cursor_move Lwd_table.next
               | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'p' ->
                   cursor_move Lwd_table.prev
               | [ (`Arrow `Up, _) ] -> cursor_move Lwd_table.prev
               | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '<' ->
                   cursor_move (fun _ -> Lwd_table.first table)
               | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '>' ->
                   cursor_move (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_table.remove row;
                                 `Handled)
                           else `Unhandled))
               | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'k' ->
                   `Handled
               | _ -> `Unhandled))

  (* TODO: view_metadata *)

  let node_edit_area ?(table = Lwd_table.make ())
      ?(focus = Focus.make ()) ((store, path) : Nav.S.t * Nav.path) :
      Ui.t Lwd.t Lwt.t =
    let open Lwt.Infix in
    Nav.S.tree store >>= fun tree ->
    let save_stream, save_push = Lwt_stream.create () in
    Lwt.async (fun () ->
        Lwt_stream.iter_s
          (fun contents ->
            Nav.S.Tree.add tree path contents >>= fun tree' ->
            Nav.S.set_tree
              ~info:(fun () ->
                Nav.S.Info.v
                  ~message:
                    ("node_edit_area " ^ String.concat "/" path
                   ^ " 'save'")
                  (Int64.of_float
                     ((new%js Js.date_now)##getTime /. 1000.)))
              store path tree'
            >>= fun _ -> Lwt.return_unit)
          save_stream);
    Nav.S.Tree.find_all tree path >>= function
    | None ->
        lwt_lwd_string
          ("Nav.S.Tree.find_all " ^ String.concat "/" path
         ^ " -> None")
    | Some (contents, _metadata) ->
        line_table_of_string ~table contents |> ignore;
        let cursor = Lwd.var (Lwd_table.first table) in
        Lwd.peek cursor
        |> Option.iter (fun r ->
               Lwd_table.get r
               |> Option.iter (fun l -> Focus.request l.focus));
        (* Build view of table *)
        Lwt.return
          (Lwd_table.map_reduce
             (fun _ { ui; _ } -> ui)
             (Lwd_utils.lift_monoid Ui.pack_y)
             table
          |> Lwd.join
          |> Lwd.map2 (Focus.status focus) ~f:(fun focus' ->
                 if Focus.has_focus focus' then
                   Lwd.peek cursor
                   |> Option.iter (fun r ->
                          Lwd_table.get r
                          |> Option.iter (fun l ->
                                 Focus.request l.focus));

                 Ui.keyboard_area ~focus:focus' (fun k ->
                     Log.debug (fun m ->
                         m "node_edit_area handler %a" Ui.pp_keys k);
                     let cursor_move =
                       cursor_move ~update:copy_line_cursor cursor
                     in
                     match k with
                     | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'n' ->
                         cursor_move Lwd_table.next
                     | [ (`Arrow `Down, _) ] ->
                         cursor_move Lwd_table.next
                     | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'p' ->
                         cursor_move Lwd_table.prev
                     | [ (`Arrow `Up, _) ] ->
                         cursor_move Lwd_table.prev
                     | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '<' ->
                         cursor_move (fun _ -> Lwd_table.first table)
                     | [ (`Uchar u, [ `Meta ]) ] when eq_uc_c u '>' ->
                         cursor_move (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 n_str =
                               String.(sub str pos (length str - pos))
                             in
                             Lwd.set old_line.state
                               (String.sub str 0 pos, 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_table.remove row;
                                       `Handled)
                                 else `Unhandled))
                     | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'k' ->
                         `Handled
                     | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'x' ->
                         let b = Buffer.create 1024 in
                         Lwd_table.iter
                           (fun line ->
                             Buffer.add_string b
                             @@ string_of_line line)
                           table;
                         save_push (Some (Buffer.contents b));
                         `Handled
                     | _ -> `Unhandled)))

  module Cursor = struct
    type 'a t = 'a Lwd_table.row option Lwd.var

    let get t ~f =
      Lwd.peek t
      |> Option.iter (fun t_row ->
             Option.iter (f t_row) (Lwd_table.get t_row))
  end

  let tree_nav ?(focus = Focus.make ()) ?(selection = Lwd.var @@ None)
      ((store, path) : Nav.S.t * Nav.path) : Ui.t Lwd.t Lwt.t =
    let table = Lwd_table.make () in
    let cursor_move cursor f =
      Ui.may_handle (Lwd.peek cursor) (fun cursor_row ->
          Ui.may_handle (f cursor_row) (fun new_row ->
              Lwd_table.get new_row
              |> Option.iter (fun (new_line_focus, new_line_sel) ->
                     Lwd.set selection (Some new_line_sel);
                     Lwd_table.get cursor_row
                     |> Option.iter (fun (cursor_line_focus, _) ->
                            Focus.release cursor_line_focus);
                     Focus.request new_line_focus);
              Lwd.set cursor (Some new_row);
              `Handled))
    in
    (* Build view of tree *)
    let open Lwt.Infix in
    Nav.S.list store path >>= fun treelist ->
    List.iter
      (fun (step, _tree) ->
        Lwd_table.append' table (Focus.make (), step))
      treelist;
    let cursor = Lwd.var @@ Lwd_table.first table in
    Lwd.peek cursor
    |> Option.iter (fun cursor ->
           Lwd_table.get cursor
           |> Option.iter (fun (f, _) -> Focus.request f));
    Lwt.return
      (Lwd_table.map_reduce
         (fun _ (f, s) ->
           Lwd.map (Focus.status f) ~f:(fun focus_h ->
               if Focus.has_focus focus_h then string ~attr:A.cursor s
               else string s))
         (Lwd_utils.lift_monoid Ui.pack_y)
         table
      |> Lwd.join
      |> Lwd.map2 (Focus.status focus) ~f:(fun focus' ->
             if Focus.has_focus focus' then
               Lwd.peek cursor
               |> Option.iter (fun cursor ->
                      Lwd_table.get cursor
                      |> Option.iter (fun (f, _) -> Focus.request f));
             Ui.keyboard_area ~focus:focus' (fun k ->
                 Log.debug (fun m ->
                     m "keyboard_area: tree_nav %a" Ui.pp_keys k);
                 match k with
                 | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'n' ->
                     cursor_move cursor Lwd_table.next |> ignore;
                     `Handled
                 | [ (`Arrow `Down, _) ] ->
                     cursor_move cursor Lwd_table.next |> ignore;
                     `Handled
                 | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'p' ->
                     cursor_move cursor Lwd_table.prev |> ignore;
                     `Handled
                 | [ (`Arrow `Up, _) ] ->
                     cursor_move cursor Lwd_table.prev |> ignore;
                     `Handled
                 | [ (`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)
                 | [ (`Uchar u, [ `Ctrl ]) ] when eq_uc_c u 'k' ->
                     `Handled
                 | [ (`Enter, []) ] -> `Unhandled
                 | [ (`Backspace, []) ] -> `Unhandled
                 | _ -> `Unhandled)))

  (* let cursorview =
       Lwd.var @@ Lwd.pure @@ string "initializing..."
     in
     let cv, push_cv = Lwt_stream.create () in
     let cvroot =
       Lwd.observe ~on_invalidate:(fun _ ->
           Log.info (fun m ->
               m
                 "tree_nav cursorviewroot on_invalidate push_cv \
                  triggered??");
           push_cv (Some ()))
       @@ Lwd.map (Lwd.get cursor) ~f:(function
            | Some cursor_row -> (
                match Lwd_table.get cursor_row with
                | Some (focus, step) -> (
                    let path' = path @ [ step ] in
                    Nav.S.kind store path' >>= function
                    | Some `Node -> lwt_lwd_string "Sub-node??"
                    | Some `Contents -> node_edit_area (store, path')
                    | None ->
                        lwt_lwd_string
                          ("Nav.S.kind " ^ String.concat "/" path'
                         ^ " -> None?"))
                | None ->
                    lwt_lwd_string "cursor table row doesn't exist")
            | None -> lwt_lwd_string "cursor doesn't exist")
     in
     Lwt.async (fun () ->
         Lwt_stream.iter_s
           (fun _ ->
             Lwd.quick_sample cvroot >>= fun cursorview'' ->
             Log.info (fun m ->
                 m "tree_nav Lwt.async (Lwd.set cursorview)");
             Lwt.return (Lwd.set cursorview cursorview''))
           cv);
       push_cv (Some ()); *)
  (*|> Lwd.map2
       (Lwd.join @@ Lwd.get cursorview)
       ~f:(fun cursorview' tree_view ->
         Ui.join_x tree_view cursorview') *)

  open Lwt.Infix

  let rec node_ui ?(focus = Focus.make ()) store path
      (f : Focus.handle * ui Lwd.t -> unit) : unit =
    Lwt.async (fun () ->
        Nav.S.tree store >>= fun tree ->
        Nav.S.Tree.kind tree path >>= function
        | None ->
            f
              ( focus,
                Lwd.pure
                @@ string
                     ("Nav.S.Tree.kind " ^ String.concat "/" path
                    ^ " how'd you get here??") );
            Lwt.return_unit
        | Some `Node ->
            let selection = Lwd.var None in
            tree_nav ~selection ~focus (store, path) >>= fun ui ->
            f
              ( focus,
                Lwd.map2
                  (Lwd.pair (Focus.status focus) (Lwd.get selection))
                  ui
                  ~f:(fun (focus', selection) ui ->
                    Ui.keyboard_area ~focus:focus'
                      (fun k ->
                        Log.debug (fun m ->
                            m "keyboard_area: node_ui %a" Ui.pp_keys k);

                        match k with
                        | [ (`Enter, []) ] -> (
                            Focus.release focus;
                            match selection with
                            | Some sel ->
                                Log.info (fun m ->
                                    m "node_ui selecting '%s'" sel);
                                node_ui store (path @ [ sel ]) f;
                                Log.info (fun m ->
                                    m "node_ui done selecting '%s'"
                                      sel);

                                `Handled
                            | None -> `Unhandled)
                        | _ -> `Unhandled)
                      ui) );
            Lwt.return_unit
        | Some `Contents ->
            node_edit_area ~focus (store, path) >>= fun ui ->
            f (focus, ui);
            Lwt.return_unit)

  let h_node_area ?(table = Lwd_table.make ())
      ?(focus = Focus.make ())
      ((store, paths) : Nav.S.t * Nav.path list) : Ui.t Lwd.t =
    List.iter
      (fun path ->
        node_ui store path (fun v -> Lwd_table.append' table v))
      paths;
    let _cursor = Lwd.var @@ Lwd_table.first table in
    Lwd_table.map_reduce
      (fun _row (focus, ui) ->
        Lwd.map2 ui (Focus.status focus) ~f:(fun ui focus ->
            Ui.pad
              ?a:
                (if Focus.has_focus focus then
                 Some
                   A.(bg (NVG.Color.rgbaf ~r:1. ~g:1. ~b:1. ~a:0.5))
                else None)
              ~l:5. ~r:10. ~t:15. ~b:20. ui))
      (Lwd_utils.lift_monoid Ui.pack_x)
      table
    |> Lwd.join
    |> Lwd.map2 (Focus.status focus) ~f:(fun focus' ->
           Ui.keyboard_area ~focus:focus' (fun k ->
               Log.debug (fun m ->
                   m "keyboard_area: h_node_area_handler %a"
                     Ui.pp_keys k);
               match k with
               | [ (`Enter, []) ] -> `Unhandled
               | _ -> `Unhandled))

  (** 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
      =
    let open Lwd.Infix in
    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 -> Lwd.return Ui.empty
    in
    (* pad summary with a "> " when it's opened *)
    let summary =
      Lwd.get opened >>= fun op ->
      summary >|= fun s ->
      Ui.hcat
        [
          string ~attr:A.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 > 20.
          || spec_fold.Ui.h > 20.
             && spec_sum.Ui.w +. spec_fold.Ui.w > 240.
        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)
    |> vbox

  (** 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 vlist_of_text ?(focus = Focus.make ())
      ?(key_handler = fun _ -> `Unhandled) =
    Lwd.map2 (Focus.status focus) ~f:(fun focus s ->
        Ui.vcat @@ List.map string @@ String.split_on_char '\n' s
        |> Ui.keyboard_area ~focus key_handler)

  (* 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.keyboard_area
      (function
        | [ (`Enter, _) ] ->
            f ();
            `Handled
        | _ -> `Unhandled)
      (* @@ Ui.mouse_area
         (fun ~x:_ ~y:_ _ ->
           f ();
           `Handled) *)
      ui

  (** A clickable button that calls [f] when clicked, labelled with a string. *)
  let button ?(attr = A.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.(font Font.underline)
               path
               (fun () -> on_select path)
      with e ->
        Lwd.return
        @@ Ui.vcat
             [
               printf
                 ~attr:A.(bg Color.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:A.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