(*
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]

   
  
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 NVG = Graphv_webgl

module Logs_reporter = struct
  (* Console reporter *)

  open Jsoo_runtime

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

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

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

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

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

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

module Log = Logs
module Cohttp_backend = Cohttp_lwt_jsoo

module Git_af = struct
  open Lwt.Infix

  type error = |

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

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

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

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

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

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

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

module Git_console_http = struct
  open Lwt.Infix

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

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

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

    ctx

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

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

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

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

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

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

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

    let close _ = Lwt.return_unit

    type endpoint = Uri.t

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

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

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

module Nav = struct
  open Lwt.Infix

  module Config = struct
    open Irmin.Backend.Conf

    let spec = Spec.v "console_js_git"

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

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

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

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

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

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

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

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

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

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

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

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

    module Backend = struct
      include Backend
      module R = Remote

      module Remote = struct
        include R

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

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

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

  module Sync = Irmin.Sync.Make (S)

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

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

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

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

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

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

  type keyaction = [ `Press | `Release | `Repeat ]

  type keystate = {
    ctrl : bool;
    meta : bool;
    shift : bool;
    super : bool;
    code : code;
  }

  module KeyS = struct
    type t = keystate

    let compare = compare
  end

  module Bind = struct
    (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
    module S = Zed_input.Make (KeyS)

    type 'a t = 'a list S.t
    type 'a resolver = 'a list S.resolver
    type 'a result = 'a list S.result

    type 'a state = {
      mutable bindings : 'a t;
      mutable state : 'a result;
      mutable last_keyseq : keystate list;
      mutable last_actions : 'a list;
    }

    type mods = Ctrl | Meta | Super | Shift
    type key = C of char | U of code

    let keystate_of_mods ks m =
      List.fold_left
        (fun ks m ->
          match m with
          | Meta -> { ks with meta = true }
          | Ctrl -> { ks with ctrl = true }
          | Super -> { ks with super = true }
          | Shift -> { ks with shift = true })
        ks m

    let add events action bindings =
      let events =
        List.map
          (fun (m, k) ->
            keystate_of_mods
              {
                meta = false;
                ctrl = false;
                super = false;
                shift = false;
                code =
                  (match k with
                  | C c -> `Uchar (Uchar.of_char c)
                  | U c -> c);
              }
              m)
          events
      in
      S.add events action bindings

    let default_resolver b = S.resolver [ S.pack (fun x -> x) b ]

    let get_resolver result default =
      match result with S.Continue r -> r | _ -> default

    let init bindings =
      {
        bindings;
        state = S.Rejected;
        last_keyseq = [];
        last_actions = [];
      }

    let resolve = S.resolve
    let empty = S.empty

    type action = Custom of (unit -> unit) | Zed of Zed_edit.action

    let resolve_events (state : 'a state) events =
      List.flatten
        (List.filter_map
           (fun e ->
             match e with
             | `Key (`Press, (k : keystate)) -> (
                 (match state.state with
                 | Continue _ -> ()
                 | _ -> state.last_keyseq <- []);
                 state.state <-
                   resolve k
                     (get_resolver state.state
                        (default_resolver state.bindings));
                 state.last_keyseq <- k :: state.last_keyseq;
                 match state.state with
                 | Accepted a ->
                     state.last_actions <- a;
                     Some a
                 | Rejected ->
                     state.last_actions <- [];
                     None
                 | _ -> None)
             | _ -> None)
           events)

    let actions_of_events (state : action state) events =
      List.flatten
        (List.filter_map
           (fun e ->
             match e with
             | `Key (`Press, (k : keystate)) -> (
                 (match state.state with
                 | Continue _ -> ()
                 | _ -> state.last_keyseq <- []);
                 state.state <-
                   resolve k
                     (get_resolver state.state
                        (default_resolver state.bindings));
                 state.last_keyseq <- k :: state.last_keyseq;
                 match state.state with
                 | Accepted a ->
                     state.last_actions <- a;
                     Some a
                 | Rejected ->
                     state.last_actions <- [];
                     None
                 | _ -> None)
             | _ -> None)
           events)

    let process bindstate events =
      List.iter
        (function Custom f -> f () | Zed _ -> ())
        (actions_of_events bindstate events)
  end

  (* 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; "\"" ]

  let to_string key =
    Printf.sprintf
      "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }"
      key.ctrl key.meta key.shift key.super
      (string_of_code key.code)

  let to_string_compact key =
    let buffer = Buffer.create 32 in
    if key.ctrl then Buffer.add_string buffer "Ctrl-";
    if key.meta then Buffer.add_string buffer "Meta-";
    if key.shift then Buffer.add_string buffer "Shift-";
    if key.super then Buffer.add_string buffer "Super-";
    (match key.code with
    | `Uchar ch ->
        let code = Uchar.to_int ch in
        if Uchar.is_char ch then
          match Uchar.to_char ch with
          | ( 'a' .. 'z'
            | 'A' .. 'Z'
            | '0' .. '9'
            | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
            | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
            | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch ->
              Buffer.add_char buffer ch
          | ' ' -> Buffer.add_string buffer "space"
          | _ -> Printf.bprintf buffer "U+%02x" code
        else if code <= 0xffff then
          Printf.bprintf buffer "U+%04x" code
        else Printf.bprintf buffer "U+%06x" code
    | `Page `Down -> Buffer.add_string buffer "pgup"
    | `Page `Up -> Buffer.add_string buffer "pgdn"
    | code ->
        Buffer.add_string buffer
          (String.lowercase_ascii (string_of_code code)));
    Buffer.contents buffer
end

module Event = struct
  open Gg

  type mouse = V2.t
  type keystate = Key.keystate
  type keyaction = Key.keyaction

  type t =
    [ `Key of keyaction * keystate
    | `Mouse of mouse
    | `Quit
    | `Fullscreen of bool
    | `Unknown of string ]

  type events = t list

  let to_string : t -> string = function
    | `Key (x, k) ->
        "`Key "
        ^ (match x with
          | `Press -> "`Press "
          | `Release -> "`Release "
          | `Repeat -> "`Repeat ")
        ^ Key.to_string k
    | `Mouse m -> F.str "`Mouse %a" V2.pp m
    | `Quit -> "`Quit"
    | `Fullscreen b -> F.str "`Fullscreen %b" b
    | `Unknown s -> F.str "`Unknown %s" s

  let handle_keyevents (el : events) f = List.iter f el
  let empty = `Unknown "empty"
end

module Event_js = struct
  include Event
  open Js_of_ocaml

  type t = Dom_html.Keyboard_code.t

  let decode_single_uchar (str : string) =
    (* yea we return None if there is more than one Uchar bitch **)
    let rec decode dec (d : Uchar.t option) : Uchar.t option =
      match Uutf.decode dec with
      | `Malformed b ->
          F.epr "Backend.Key.decode_fst_uchar `Malformed \"%s\"@."
            (String.escaped b);
          None
      | `Await -> decode dec d
      | `End -> d
      | `Uchar u ->
          if Option.is_none d then decode dec (Some u) else None
    in
    decode
      (Uutf.decoder
         ~nln:(`Readline (Uchar.of_int 0x000A))
         (`String str))
      None

  let of_jskey = function
    | "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 decode_single_uchar s with
        | Some s -> `Uchar s
        | None -> `Unknown s)

  let evt_of_jskey (p : Key.keyaction)
      (evt : Dom_html.keyboardEvent Js.t) : Event.t =
    match Js.Optdef.to_option evt##.key with
    | Some s ->
        `Key
          ( p,
            Key.
              {
                meta = Js.to_bool evt##.altKey;
                shift = Js.to_bool evt##.shiftKey;
                ctrl = Js.to_bool evt##.ctrlKey;
                super = Js.to_bool evt##.metaKey;
                code = of_jskey (Js.to_string s);
              } )
    | None -> `Unknown "keypress .key is None?"
end

module Panel = struct
  open Gg
  open NVG

  (* current window state to be passed to window renderer *)
  type state = {
    box : box2;
        (* This is cannonically box within which the next element should draw *)
    renderer : NVG.t;
  }

  (* the box2 here is cannonically the place the returner drew
     (the Wall.image extents) *)
  type pane = state -> state * box2
  type actor = (Event.t -> P2.t) ref

  let pane_empty s = (s, Box2.of_pts (Box2.o s.box) (Box2.o s.box))

  let on_failure ~cleanup result =
    (match result with Ok _ -> () | Error _ -> cleanup ());
    result

  let draw_pane vg pane width height =
    let _, _ =
      pane
        {
          box = Box2.v (P2.v 0. 0.) (P2.v width height);
          renderer = vg;
        }
    in
    Ok ()

  let gray ?(a = 1.0) v = Color.rgbaf ~r:v ~g:v ~b:v ~a

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

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

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

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

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

      let default =
        ref
          {
            size = Some 20.;
            font = `Sans;
            weight = `Regular;
            italic = `None;
            underline = `None;
          }

      let size { size; _ } =
        match (size, !default.size) with
        | None, None -> 20.
        | None, Some s | Some s, _ -> s

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

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

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

    let gray a = Color.rgbf ~r:a ~g:a ~b:a

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

    let light = { empty with fg = gray 0.2 }
    let dark = { empty with fg = gray 0.8 }
    let equal = ( == )

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

    let fg fg = { empty with fg }
    let bg bg = { empty with bg }

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

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

  module Pad = struct
    type t = {
      t : Gg.size1;
      b : Gg.size1;
      l : Gg.size1;
      r : Gg.size1;
    }

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

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

  module Ui = struct
    (* Tree-like document structure of Ui elements, from the top level window down
       to individual glyphs, and built with Lwd.

       Probably an LCRS binary tree.
    *)

    open Gg

    type draw_context = { vg : NVG.t; style : Style.t }
    and draw = draw_context -> Gg.p2 -> Gg.p2

    module Page = struct
      type t =
        (* TODO figure out how to allow extending `node` with custom document tree combinators *)
        [ `Atom of atom | `Attr of attr * t | `Join of dir * t * t ]

      and step = [ `Next | `Left | `Right ]
      and path = step list
      and cursor = { path : path; root : t }

      and atom =
        [ (*`Lwd of t
            | *)
          `Image of
          image
        | `Uchar of Uchar.t
        | `Boundary of boundary
        | `Hint of [ `Line | `Other ]
        | `Empty ]

      and attr =
        [ `Style of style
        | `Pad of Pad.t
        | `Handler of handler
        | `Draw of draw ]

      and dir = [ `X | `Y | `Z ]
      and image = NVG.Image.image

      and boundary =
        [ `Char | `Word | `Phrase | `Line | `Page | `Text ]

      and style = Style.t
      and handler = t -> Event.t -> Event.t option

      let sub_left = function
        | `Atom _ as n -> n
        | `Attr (_, n) -> n
        | `Join (_, a, _) -> a

      let sub_right = function
        | `Atom _ as n -> n
        | `Attr (_, n) -> n
        | `Join (_, _, b) -> b

      let atom (a : atom) : t = `Atom a
      let attr (a : attr) (child : t) : t = `Attr (a, child)
      let join (d : dir) (a : t) (b : t) : t = `Join (d, a, b)
      let empty = `Atom `Empty
      let style (s : Style.t) t = attr (`Style s) t
      let pad v n = attr (`Pad (Pad.all v)) n

      (* left child, right sibiling *)
      let rec fold_preorder : ('a -> t -> 'a option) -> 'a -> t -> 'a
          =
       fun f acc n ->
        match f acc n with
        | Some acc' -> (
            match n with
            | `Atom _ -> acc'
            | `Attr (_, n'') -> fold_preorder f acc' n''
            | `Join (_, a, b) ->
                fold_preorder f (fold_preorder f acc' a) b)
        | None -> acc

      (* let rec fold_inorder : ('a -> node -> 'a option) -> 'a -> node -> 'a  =
          fun f acc n ->
           match n with
           | `Atom _ -> (match f acc n with
               Some acc' -> acc'
               | None -> acc)
           | `Attr (_, n') ->
             let acc' = (fold_inorder f acc n') in
             (match f acc' n with
               | Some acc'' -> acc''
               | None -> acc')
           | `Join (_, a, b) ->
               fold_inorder f (f (fold_inorder f acc a) n) b

         let rec fold_postorder : ('a -> node -> 'a option) -> 'a -> node -> 'a =
          fun f acc n ->
           match n with
           | `Atom _ -> f (Some acc) n
           | `Attr (_, n') -> f (fold_postorder f (Some acc) n') n
           | `Join (_, a, b) ->
               f (fold_postorder f (fold_postorder f (Some acc) a) b) n*)

      let is_atom_uchar = function
        | `Atom (`Uchar _) as n -> Some n
        | _ -> None

      let is_boundary b t =
        match (b, t) with
        | ( `Char, `Atom (`Uchar _)
          | `Word, `Atom (`Boundary `Word)
          | `Phrase, `Atom (`Boundary `Phrase)
          | `Line, `Atom (`Boundary `Line)
          | `Page, `Atom (`Boundary `Page) ) as x ->
            Some x
        | _ -> None

      let join_x = join `X
      let join_y = join `Y
      let join_z = join `Z

      module Text = struct
        let append_ d (l : t -> t) (a : t) (b : t) : t =
          l (join d a b)

        let empty_append = Fun.id
        let append_x = append_ `X
        let append_y = append_ `Y
        let append_z = append_ `Z

        let rec decode dec (l : 'a) :
            'a * [< `Await | `End | `Uchar of Uchar.t ] =
          match Uutf.decode dec with
          | `Malformed b ->
              F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@."
                (String.escaped b);
              decode dec (append_x l (of_string (String.escaped b)))
          | (`Await | `End | `Uchar _) as s -> (l, s)

        and _of_string dec l =
          match decode dec l with
          | l, `End -> l (atom (`Boundary `Text))
          | l, `Uchar c ->
              _of_string dec (append_x l (atom (`Uchar c)))
          | l, _ -> _of_string dec l

        and of_string str =
          _of_string
            (Uutf.decoder
               ~nln:(`Readline (Uchar.of_int 0x000A))
               (`String str))
            empty_append

        and _lines u d ly (lx, s) =
          match Uuseg.add u s with
          | `Boundary when Uuseg.mandatory u ->
              _lines u d
                (append_y ly (lx (atom (`Boundary `Line))))
                (empty_append, `Await)
          | `Boundary ->
              _lines u d ly (append_x lx (atom (`Hint `Line)), `Await)
          | `End -> ly (lx (atom (`Boundary `Text)))
          | `Await -> _lines u d ly (decode d lx)
          | `Uchar c ->
              _lines u d ly (append_x lx (atom (`Uchar c)), `Await)

        let lines str =
          _lines
            (Uuseg.create `Line_break)
            (Uutf.decoder
               ~nln:(`Readline (Uchar.of_int 0x000A))
               (`String str))
            empty_append (empty_append, `Await)

        let text = of_string
        let nl = atom (`Boundary `Line)
      end

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

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

        let uchar vg t (uc : Uchar.t) : P2.t =
          let module Buffer = Stdlib.Buffer in
          let b = Stdlib.Buffer.create 1 in
          let enc = Uutf.encoder `UTF_8 (`Buffer b) in
          let rec encode c =
            match Uutf.encode enc c with
            | `Ok -> ()
            | `Partial -> encode `Await
          in
          encode (`Uchar uc);
          encode `End;
          let text = Bytes.to_string (Buffer.to_bytes b) in
          let open NVG in
          let bounds = Text.bounds vg ~x:(V2.x t) ~y:(V2.y t) text in
          let metrics = Text.metrics vg in
          let x, y = (V2.x t, V2.y t +. metrics.ascender) in
          Text.text vg ~x ~y text;
          P2.v
            (P2.x t +. bounds.advance)
            (P2.y t +. metrics.ascender +. metrics.descender
           +. metrics.line_height)

        let rec atom { vg; _ } b (a : atom) : P2.t =
          match a with
          | `Image image ->
              let wi, hi = Image.size vg image in
              let w, h = (float wi, float hi) in
              Path.begin_ vg;
              Path.rect vg ~x:(P2.x b) ~y:(P2.y b) ~w ~h;
              let img_paint =
                Paint.image_pattern vg ~cx:(P2.x b) ~cy:(P2.y b) ~w ~h
                  ~angle:0.0 ~image ~alpha:0.
              in
              set_fill_paint vg ~paint:img_paint;
              fill vg;
              P2.v (P2.x b +. w) (P2.y b +. h)
          | `Uchar uc -> uchar vg b uc
          | `Boundary _ -> b
          | `Hint _ -> b
          | `Empty -> b

        and attr t b ((a : attr), n) : P2.t =
          match a with
          | `Style s ->
              path_box t.vg s.bg
                (Box2.of_pts b
                   (node { t with style = Style.merge t.style s } b n))
          | `Pad p -> pad t b p n
          | `Draw d -> d t b
          | `Handler _ -> node t b n

        and pad vg t (p : Pad.t) n =
          let nv = node vg P2.(v (p.l +. x t) (p.t +. y t)) n in
          P2.(v (x nv +. p.r) (y nv +. p.b))

        and join vg t (d, a, b) : P2.t =
          let av = node vg t a in
          let bv =
            node vg
              (match d with
              | `X -> P2.v (P2.x av) (P2.y t)
              | `Y -> P2.v (P2.x t) (P2.y av)
              | `Z -> t)
              b
          in
          match d with
          | `X -> V2.v (V2.x bv) (Float.max_num (V2.y av) (V2.y bv))
          | `Y -> V2.v (Float.max_num (V2.x av) (V2.x bv)) (V2.y bv)
          | `Z ->
              V2.v
                (Float.max_num (V2.x av) (V2.x bv))
                (Float.max_num (V2.y av) (V2.y bv))

        and node vg b n : P2.t =
          let b' =
            match n with
            | `Atom a -> atom vg b a
            | `Attr a -> attr vg b a
            | `Join a -> join vg b a
          in
          ignore
            (path_box vg.vg
               (NVG.Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2)
               (Box2.of_pts b b'));
          b'
      end

      module Pp = struct
        let pp_uchar ppf v =
          if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
          else Fmt.Dump.uchar ppf v

        let pp_boundary ppf v =
          F.any
            (match v with
            | `Char -> "`Char"
            | `Word -> "`Word"
            | `Phrase -> "`Phrase"
            | `Line -> "`Line"
            | `Page -> "`Page"
            | `Text ->
                "`Text"
                (* text is like a file (unicode calls it End Of Text) *))
            ppf ()

        let pp_atom ppf v =
          let open Fmt in
          (match v with
          | `Image _ -> any "`Image"
          | `Uchar c -> any "`Uchar " ++ const pp_uchar c
          | `Boundary b -> any "`Boundary " ++ const pp_boundary b
          | `Hint h ->
              any "`Hint "
              ++ any
                   (match h with
                   | `Line -> "`Line"
                   | `Other -> "`Other")
          | `Empty -> any "`Empty")
            ppf ()

        let pp_attr ppf v =
          let open Fmt in
          (any
             (match v with
             | `Style _ -> "`Style"
             | `Pad _ -> "`Pad"
             | `Shift _ -> "`Shift"
             | `Cursor -> "`Cursor"
             | `Handler _ -> "`Handler"
             | `Draw _ -> "`Draw"))
            ppf ()

        let pp_dir ppf v =
          F.pf ppf "%s"
            (match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")

        let rec _pp_t child ppf v =
          let open Fmt in
          match v with
          | `Atom x -> pf ppf "`Atom %a" pp_atom x
          | `Attr (a, n) ->
              pf ppf "`Attr %a"
                (F.pair (const pp_attr a) (const child n))
                (a, n)
          | `Join (d, a, b) ->
              pf ppf "`Join %a"
                (parens
                   (const pp_dir d ++ comma ++ const child a ++ comma
                  ++ const child b))
                ()

        and pp_node ppf = _pp_t pp_node ppf
        and pp_dump_node ppf = _pp_t pp_dump_node ppf

        let pp_t ppf = F.pf ppf "@[<hov>%a@]" pp_node

        let rec pp_node_structure ppf t =
          F.(
            parens
              (concat ~sep:comma
                 (match t with
                 | `Atom a -> [ const pp_atom a ]
                 | `Attr (a, n) ->
                     [ const pp_attr a; const pp_node_structure n ]
                 | `Join (d, l, r) ->
                     [
                       const pp_dir d;
                       const pp_node_structure l;
                       const pp_node_structure r;
                     ])))
            ppf ()

        let pp_step ppf s =
          F.any
            (match s with
            | `Next -> "`Next"
            | `Left -> "`Left"
            | `Right -> "`Right")
            ppf ()

        let rec pp_path ppf (p : path) = F.list pp_step ppf p
      end
    end

    type node = Page.t
    type t = node Lwd.t

    let empty = Lwd.pure Page.empty
    let pad v = Lwd.map ~f:(Page.pad v)
    let join d = Lwd.map2 ~f:(Page.join d)
    let join_x, join_y, join_z = (join `X, join `Y, join `Z)
    let ( ^^ ) = join_x
    let ( ^/^ ) = join_y
    let ( ^*^ ) = join_z
    let pack d = Lwd_utils.lift_monoid Page.(empty, join d)
    let pack_x, pack_y, pack_z = (pack `X, pack `Y, pack `Z)
    let cat d = Lwd_utils.reduce (pack d)
    let hcat, vcat, zcat = (cat `X, cat `Y, cat `Z)

    open Page.Pp

    module Action = struct
      open Page

      type segment =
        [ `Beginning of boundary
        | `Forward of boundary
        | `Backward of boundary
        | `End of boundary ]

      and t =
        [ `Move of segment
        | `Insert of t
        | `Overwrite of t
        | `Yank of segment
        | `Kill of segment
        | `Ascend
        | `Descend
        | `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ]

      and dir =
        [ `Next
        | `Prev
        | `Up
        | `Down
        | `Left
        | `Right
        | `Fwd
        | `Enter
        | `In
        | `Out ]

      open Fmt

      let pp_dir ppf v =
        any
          (match v with
          | `Next -> "`Next"
          | `Prev -> "`Prev"
          | `Up -> "`Up"
          | `Down -> "`Down"
          | `Left -> "`Left"
          | `Right -> "`Right"
          | `Fwd -> "`Fwd"
          | `Enter -> "`Enter"
          | `In -> "`In"
          | `Out -> "`Out")
          ppf ()

      let pp_segment ppf v =
        (match v with
        | `Beginning s -> any "`Beginning " ++ const pp_boundary s
        | `Forward s -> any "`Forward " ++ const pp_boundary s
        | `Backward s -> any "`Backward " ++ const pp_boundary s
        | `End s -> any "`End " ++ const pp_boundary s)
          ppf ()

      let pp_t ppf v =
        (match v with
        | `Move s -> any "`Move " ++ const pp_segment s
        | `Insert n -> any "`Insert " ++ const pp_node n
        | `Overwrite n -> any "`Overwrite " ++ const pp_node n
        | `Yank s -> any "`Yank " ++ const pp_segment s
        | `Kill s -> any "`Kill " ++ const pp_segment s
        | `Ascend -> any "`Ascend"
        | `Descend -> any "`Descend"
        | `Custom (s, _) ->
            fun ppf () -> pf ppf "`Custom \"%a\"" string s)
          ppf ()
    end

    let perform_action (a : Action.t) ({ path; root } : Page.cursor) :
        node option =
      match a with
      | `Move (`Forward `Line) ->
          (*
          let i = ref 0 in
          ignore
            (search_backward
               (function
                 | { t = `Atom (`Boundary `Line); _ } -> Some ()
                 | { t = `Atom (`Uchar _); _ } ->
                     incr i;
                     None
                 | _ -> None)
               path);
          match search_forward (is_boundary `Line) path with
          | Some n' ->
              Some
                (tree_iter
                   (fun nn ->
                     Option.value
                       (search_forward (is_boundary `Char) nn)
                       ~default:nn)
                   n' !i)
          | None -> *)
          None
      | `Move (`Backward `Line) ->
          (* let i = ref 0 in
             match
               search_backward
                 (function
                   | { t = `Atom (`Boundary `Line); _ } as n' -> Some n'
                   | { t = `Atom (`Uchar _); _ } ->
                       incr i;
                       None
                   | _ -> None)
                 c.sel
             with
             | Some n' ->
                 Option.map
                   (fun n -> tree_iter tree_uchar_back n !i)
                   (search_backward (is_boundary `Line) n')
               | None ->*)
          None
      (* | `Move (`Forward b) ->
           Option.map tree_uchar_fwd
               (search_forward (is_boundary b) c.sel)
         | `Move (`End b) ->
             Option.map tree_uchar_back
               (search_forward (is_boundary b) c.sel)
         | `Move (`Backward b) ->
             Option.map tree_uchar_back
               (search_backward (is_boundary b) c.sel)
         | `Move (`Beginning b) ->
             Option.map tree_uchar_fwd
               (search_backward (is_boundary b) c.sel)
         | `Insert n ->
             ignore (insert_join_l `X (super c.sel) n);
             Some c.sel *)
      | `Overwrite _s -> None
      | `Yank _s -> None
      | `Kill (`Forward `Char) -> None (*kill_forward_char c.sel *)
      (*      | `Kill (`Backward `Char) -> kill_backward_char c.sel *)
      | `Kill _s -> None
      (*      | `Descend -> Some (sub c.sel) *)
      (*       | `Ascend -> option_of_parent c.sel.parent*)
      | `Custom _s -> None

    type event_status = [ `Handled | `Event of Event.t ]

    let textedit_bindings =
      let open Key.Bind in
      empty
      |> add [ ([ Ctrl ], C 'f') ] [ `Move (`Forward `Char) ]
      |> add [ ([], U (`Arrow `Right)) ] [ `Move (`Forward `Char) ]
      |> add [ ([ Ctrl ], C 'b') ] [ `Move (`Backward `Char) ]
      |> add [ ([], U (`Arrow `Left)) ] [ `Move (`Backward `Char) ]
      |> add [ ([ Meta ], C 'f') ] [ `Move (`Forward `Word) ]
      |> add [ ([ Meta ], C 'b') ] [ `Move (`Backward `Word) ]
      |> add
           [ ([ Ctrl ], C 'c'); ([ Ctrl ], C 'n') ]
           [ `Move (`Forward `Phrase) ]
      |> add
           [ ([ Ctrl ], C 'c'); ([ Ctrl ], C 'p') ]
           [ `Move (`Backward `Phrase) ]
      |> add [ ([ Ctrl ], C 'n') ] [ `Move (`Forward `Line) ]
      |> add [ ([], U (`Arrow `Down)) ] [ `Move (`Forward `Line) ]
      |> add [ ([ Ctrl ], C 'p') ] [ `Move (`Backward `Line) ]
      |> add [ ([], U (`Arrow `Up)) ] [ `Move (`Backward `Line) ]
      |> add [ ([ Ctrl ], C 'v') ] [ `Move (`Forward `Page) ]
      |> add [ ([ Meta ], C 'v') ] [ `Move (`Backward `Page) ]
      |> add [ ([ Ctrl ], C 'a') ] [ `Move (`Beginning `Line) ]
      |> add [ ([ Ctrl ], C 'e') ] [ `Move (`End `Line) ]
      |> add [ ([ Ctrl ], C 'k') ] [ `Kill (`End `Line) ]
      |> add [ ([], U `Backspace) ] [ `Kill (`Backward `Char) ]
      |> add [ ([], U `Delete) ] [ `Kill (`Forward `Char) ]
      |> add [ ([ Ctrl ], U `Backspace) ] [ `Kill (`Backward `Word) ]
      |> add [ ([ Meta ], U `Backspace) ] [ `Kill (`Backward `Word) ]
      |> add
           [ ([ Ctrl ], C 'x'); ([], U `Backspace) ]
           [ `Kill (`Backward `Phrase) ]
      |> add [ ([ Ctrl ], C 'q') ] [ `Ascend ]
      |> add [ ([ Ctrl ], C 'z') ] [ `Descend ]

    let cursor_attr =
      `Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.))

    (* this was a hack?
       let draw_node_structure (doc : node Lwd.var) : node =
             let open Gg in
             attr
               (`Draw
                 (fun (t : draw_context) (b : P2.t) ->
                   Draw.node t b
                     (Text.lines
                        (Fmt.to_to_string pp_node_structure (Lwd.peek doc)))))
               (atom `Empty) *)

    let node_structure root =
      Lwd.map
        ~f:(fun node ->
          Page.Text.lines (Fmt.to_to_string pp_node_structure node))
        root

    let draw_path path =
      Lwd.map
        ~f:(fun path ->
          Page.Text.lines (Fmt.to_to_string pp_path path))
        path

    let textedit ?(bindings = textedit_bindings)
        (initial : node * Page.path) =
      Format.pp_set_max_boxes F.stderr 64;
      (*full screen fynn  *)
      Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230;
      let doc = Lwd.var (fst initial) in
      let path = Lwd.var (snd initial) in
      join_y
        (pad 5. (Lwd.get doc))
        (join_y
           (pad 5. (draw_path (Lwd.get path)))
           (pad 5. (node_structure (Lwd.get doc))))

    (* let bind = Key.Bind.init bindings in
       let sel = insert_attr cursor_attr n in
       let c = { root = attr (`Handler (fun _ _ -> None)) sel; sel } in
       c.root.t <-
         `Attr
           ( `Handler
               (fun (_ : node) (e : Event.t) : Event.t option ->
                 let a =
                   match Key.Bind.resolve_events bind [ e ] with
                   | x :: _ -> Some x
                   | [] -> (
                       match e with
                       | `Key (`Press, (k : Key.keystate)) -> (
                           match k.code with
                           | `Uchar c ->
                               Some (`Insert (atom (`Uchar c)))
                           | _ -> None)
                       | _ -> None)
                 in
                 let r =
                   match a with
                   | Some x ->
                       c.sel <- remove_attr c.sel;
                       (match perform_action x c with
                       | Some n' ->
                           F.epr "textedit action @[%a@] Success@."
                             Action.pp_t x;
                           c.sel <- n'
                       | None ->
                           F.epr "textedit action @[%a@] Failure@."
                             Action.pp_t x);
                       c.sel <- insert_attr cursor_attr c.sel;
                       None
                   | None -> None
                 in
                 r),
             n );
       join_y (pad 5. c.root)
         (join_y
            (pad 5. (draw_cursor_sel c))
            (pad 5. (draw_cursor_root c))) *)

    (*
    let is_handler (n : node) : handler option =
      match n with `Attr (`Handler f, _) -> Some f | _ -> None
    (** receives a node document and event and returns a node document where that event is handled *)
    let handle_event (n : t) (ev : Event.t) : t =
      Lwd.map
        ~f:
          (fold_preorder
             (fun ev' n' ->
               match is_handler n' with
               | Some f -> f n' ev'
               | None -> None)
             ev)
        n

    let panel (vg : NVG.t) (p : P2.t) (t : t) (ev : Event.t) : P2.t =
      (match handle_event t ev with
      | `Handled -> F.epr "Handled %s@." (Event.to_string ev)
      | `Event _e ->
          F.epr "Unhandled event: %s@." (Event.to_string _e));
      Draw.node { vg; style = Style.dark } p t
      *)
    (* I feel like the Wall module from github.com/let-def/wall includes another layer on top
       of the drawing functions, missing from graphv, that
       specificall allows the composability and cache-ability i want, so instead of writing in from
       scratch i will try to steal it.
    *)

    (* we need to determine how "document types" should be implemented:
       * as a module that implements a common interface which allows
       production of a Ui.t which is then rendered.
         * this will require exposing the Ui and all drawing related functions.
         *
    *)

    module Text = struct
      let lines = Lwd.map ~f:Page.Text.lines
      let of_string = Lwd.map ~f:Page.Text.of_string
    end

    module View = struct
      type path = Nav.path

      type t = {
        tree : Nav.tree;
        view : path list Lwd.var;
        cursor : Nav.path Lwd.var;
        doc : node Lwd.t;
      }

      open Lwt.Infix

      let of_path path =
        join_x
          (Text.of_string (Lwd.pure "/"))
          (Lwd_utils.map_reduce
             (fun step -> Lwd.pure (Page.Text.of_string ("/" ^ step)))
             pack_x path)

      let of_tree ?(path = []) tree =
        Nav.S.Tree.list tree path >>= fun l ->
        Lwt.return
          {
            tree;
            view = Lwd.var [ path ];
            cursor = Lwd.var path;
            doc =
              Lwd_utils.map_reduce
                (fun (step, _t') -> Text.of_string (Lwd.pure step))
                pack_y l;
          }

      let list_logs hook =
        let var = Lwd.var Page.empty in
        (hook :=
           fun level s ->
             Lwd.set var
               Page.(
                 join_y
                   (Text.of_string
                      (Logs.level_to_string (Some level) ^ ": " ^ s))
                   (Lwd.peek var)));
        Lwd.get var

      let draw (vg, p) (t : node Lwd.t) : Page.Draw.p Lwt.t =
        let root =
          Lwd.observe
            ~on_invalidate:(fun _ ->
              Log.warn (fun m -> m "View.draw doc_root on_invalidate"))
            t
        in
        Lwt.return (Page.Draw.node vg p (Lwd.quick_sample root))
    end

    open Lwt.Infix

    let render_lwt (vg : NVG.t) (p : Gg.p2) (_ev : Event.t) :
        Gg.p2 Lwt.t =
      let t = { vg; style = Style.dark } in
      Nav.test_pull () >>= fun tree ->
      View.of_tree tree >>= fun doc ->
      View.draw (t, p)
        (Lwd_utils.reduce pack_y
           [
             doc.doc;
             View.of_path (Lwd.peek doc.cursor);
             View.list_logs Logs_reporter.hook;
           ])
  end
end

(* Implement the "window management" as just toplevel defined functions that manipulate the window tree *)

(* FUTURE: (thinking now this should be based on react for that sweet incremental compuation)

   type panetree
   type eventree
   type imagetree

   Display.run should be:
   Init: setup initial panetree and compute eventree and imagetree from it.last_actions
   New events trigger parsing the eventree, the results of which update the imagetree
      which is then parsed and displayed. *)

(* 220805: This is fundamentally trying to:
   - display lines of text in a variety of ways
   - allow manipulation of the display of the document
   - display and manipulate history of the document
   - turn the document into a tree
   the

   your previous idea around the binary tree display layout is ok but is it really trying to shove documents into trees when you can't then de-encode them into a file? That seems rough...

   you have an in-memory irmin store, and you really just want to be able to navigate it
   but it's going to be lots of linear things (the internet, lol), so you still need linear document navigation
   but what if you can rethink linear document navigation but switching the tree structure around while still making the layout a tree (Irmin.Tree), but now the history is a tree (Irmin.History) which just encodes the state of the display. This would require an in-memory Irmin store that

   If the Irmin Tree is better implemented than the garbage i am trying to make ad hoc, (i.e. we can implement all our cursor movement and editing mechanisms with the Irmin.Tree interface easily, then yea lol)
*)

(* would be nice to be able to switch arbitrary nodes between their drawn representation and the sort of node structure representation. This might be a more general philsophy to apply to the entire system, where you want to be able to switch between representations (i.e. "view-source" but with further higher level analysis views built on top as well *)
