(*

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

*)

module F = Fmt
module NVG = Graphv_webgl

module Nav = struct
  open Lwt.Infix

  module Maker =
    Irmin_git.KV (Irmin_git.Mem) (Git.Mem.Sync (Irmin_git.Mem))

  module S = Maker.Make (Irmin.Contents.String)
  module Sync = Irmin.Sync.Make (S)

  type t = S.tree

  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 ()
  (* S.Repo.v (Irmin_git.config "") >>= fun repo ->
     S.of_branch repo "master" >>= fun t ->
     let upstream = Irmin.Sync.remote_store (module S) t in
                        Sync.pull_exn t upstream `Set >>= fun _ -> S.tree t *)
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 structure of Ui elements, from the entire display down to individual glyphs. *)
    (* i think this is gonna end up being a binary tree?? *)

    (* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *)

    open Gg

    type t =
      [ `Atom of atom
      | `Attr of attr * node
      | `Join of dir * node * node ]

    and node = { mutable parent : parent; mutable t : t; n : int }
    and parent = [ `Left of node | `Right of node | `None ]
    and cursor = { root : node; mutable sel : node }

    and atom =
      [ `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 = node -> Event.t -> Event.t option
    and draw_context = { vg : NVG.t; style : Style.t }
    and draw = draw_context -> P2.t -> P2.t

    let node_count = ref 0

    let node_n () =
      node_count := !node_count + 1;
      !node_count - 1

    let set_parent_on_children n : node =
      (match n.t with
      | `Atom _ -> ()
      | `Attr (_, a) -> a.parent <- `Left n
      | `Join (_, a, b) ->
          a.parent <- `Left n;
          b.parent <- `Right n);
      n

    let sub (n : node) : node =
      match n.t with
      | `Atom _ -> n
      | `Attr (_, n) -> n
      | `Join (_, a, _) -> a

    let super (n : node) : node =
      match n.parent with `Left n' | `Right n' -> n' | `None -> n

    let set_children_on_parent n =
      match n.parent with
      | `Left ({ t = `Attr (a, _); _ } as s)
      | `Right ({ t = `Attr (a, _); _ } as s) ->
          s.t <- `Attr (a, n);
          n
      | `Left ({ t = `Join (d, _, b); _ } as s) ->
          s.t <- `Join (d, n, b);
          n
      | `Right ({ t = `Join (d, a, _); _ } as s) ->
          s.t <- `Join (d, a, n);
          n
      | _ -> n

    let option_of_parent = function
      | `None -> None
      | `Left a | `Right a -> Some a

    let node (t : t) =
      set_parent_on_children { parent = `None; t; n = node_n () }

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

    let rec node_up_ (d : [ `Left | `Right ]) n' =
      match (d, n'.parent) with
      | _, `None -> None
      | ( _,
          ( `Left ({ t = `Attr _; _ } as p)
          | `Right ({ t = `Attr _; _ } as p) ) ) ->
          node_up_ d p
      | `Right, `Right ({ t = `Join _; _ } as p)
      | `Left, `Left ({ t = `Join _; _ } as p) ->
          node_up_ d p
      | `Left, `Right { t = `Join (_, l, _); _ } -> Some l
      | `Right, `Left { t = `Join (_, _, r); _ } -> Some r
      | _, (`Left { t = `Atom _; _ } | `Right { t = `Atom _; _ }) ->
          assert false

    let node_next_ (d : [ `Left | `Right ]) (n : node) =
      match (d, n.t) with
      | _, `Atom _ -> node_up_ d n
      | _, `Attr (_, n') -> Some n'
      | `Right, `Join (_, _, r) -> Some r
      | `Left, `Join (_, l, _) -> Some l

    let rec search_preorder (f : node -> 'a option) (n : node) :
        'a option =
      match f n with
      | None -> (
          match node_next_ `Left n with
          | Some n -> search_preorder f n
          | None -> None)
      | x -> x

    let rec search_reverse_preorder (f : node -> 'a option) (n : node)
        : 'a option =
      match f n with
      | None -> (
          match node_next_ `Right n with
          | Some n -> search_reverse_preorder f n
          | None -> None)
      | x -> x

    let replace_parents_child parent n : node =
      match parent with
      | `Left ({ t = `Attr (a, _); _ } as p)
      | `Right ({ t = `Attr (a, _); _ } as p) ->
          p.t <- `Attr (a, n);
          n
      | `Left ({ t = `Join (d, _, r); _ } as p) ->
          p.t <- `Join (d, n, r);
          n
      | `Right ({ t = `Join (d, l, _); _ } as p) ->
          p.t <- `Join (d, l, n);
          n
      | _ -> n

    let rec tree_iter f n i =
      if i <> 0 then tree_iter f (f n) (i - 1) else f n

    let search_forward f (n : node) = search_preorder f n
    let search_backward f (n : node) = search_reverse_preorder f n

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

    let tree_uchar_fwd n =
      Option.value (search_forward is_atom_uchar n) ~default:n

    let tree_uchar_back n =
      Option.value (search_backward is_atom_uchar n) ~default:n

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

    let search_back_opt (f : node -> node option) (n : node option) =
      Option.bind n (search_backward f)

    let search_back_uchar_opt = search_back_opt is_atom_uchar

    let rec traverse_nodes ~(f : node -> node option) (n : node) :
        unit =
      match f n with
      | Some { t = `Atom _; _ } -> ()
      | Some { t = `Attr (_, n'); _ } -> traverse_nodes ~f n'
      | Some { t = `Join (_, a, b); _ } ->
          traverse_nodes ~f a;
          traverse_nodes ~f b
      | None -> ()

    let insert_join_l (d : dir) (n : node) (n' : node) : node =
      let p = n.parent in
      let n'' = join d n' n in
      n''.parent <- p;
      set_children_on_parent n''

    let remove_join_l (n : node) : node =
      match n.parent with
      | `Left ({ t = `Attr (_, n'); _ } as s)
      | `Right ({ t = `Attr (_, n'); _ } as s)
      | `Left ({ t = `Join (_, _, n'); _ } as s) ->
          s.t <- n'.t;
          n'
      | _ -> n

    let kill_backward_char (n : node) : node option =
      search_forward is_atom_uchar
        (replace_parents_child (super (tree_uchar_back n)).parent n)

    let insert_attr (a : attr) (n : node) : node =
      let p = n.parent in
      let n' = node (`Attr (a, n)) in
      n'.parent <- p;
      set_children_on_parent n'

    let remove_attr (n : node) : node =
      match n.t with
      | `Attr (_, n') ->
          (match n.parent with
          | `Left ({ t = `Join (d, _, b); _ } as p) ->
              p.t <- `Join (d, n', b);
              ignore (set_parent_on_children p)
          | `Right ({ t = `Join (d, a, _); _ } as p) ->
              p.t <- `Join (d, a, n');
              ignore (set_parent_on_children p)
          | `Left ({ t = `Attr (a, _); _ } as p)
          | `Right ({ t = `Attr (a, _); _ } as p) ->
              p.t <- `Attr (a, n');
              ignore (set_parent_on_children p)
          | _ -> ());
          n'
      | _ -> assert false

    let join_x = join `X
    let join_y = join `Y
    let join_z = join `Z
    let ( ^^ ) = join_x
    let ( ^/^ ) = join_y
    let ( ^*^ ) = join_z

    let append_ d (l : node -> node) (a : node) : node -> node =
     fun n -> l (join d a n)

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

    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 pp_node_n ppf v = F.(pf ppf "%a" int v.n)

      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"
              (parens (const pp_attr a ++ comma ++ const child n))
              ()
        | `Join (d, a, b) ->
            pf ppf "`Join %a"
              (parens
                 (const pp_dir d ++ comma ++ const child a ++ comma
                ++ const child b))
              ()

      and _pp_parent ppf v =
        let open Fmt in
        match v with
        | `None -> pf ppf "`None"
        | `Left n -> pf ppf "`Left %a" pp_node_n n
        | `Right n -> pf ppf "`Right %a" pp_node_n n

      and _pp_node child ppf v =
        let open Fmt in
        pf ppf "@[<hov>%a@]"
          (braces
             (record
                [
                  field "n" (fun v -> v.n) int;
                  field "t" (fun v -> v.t) (_pp_t child);
                  field "parent" (fun v -> v.parent) _pp_parent;
                ]))
          v

      and pp_node_n_record =
        F.(
          braces
            (record ~sep:semi
               [ field "n" Fun.id pp_node_n; any "..." ]))

      and pp_node ppf = _pp_node pp_node_n ppf
      and pp_dump_node ppf = _pp_node pp_dump_node ppf

      let pp_t ppf = F.pf ppf "@[<hov>%a@]" (_pp_t pp_node_n_record)

      let pp_n ppf n =
        F.pf ppf "@[<h>%a: %a@]" pp_node_n n (_pp_t pp_node_n) n.t

      let rec pp_node_structure ppf v =
        F.(
          const int v.n
          ++ parens
               (concat ~sep:comma
                  (match v.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 ()
    end

    open Pp

    module Text = struct
      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
      open NVG

      type d = [ `X | `Y | `Z ]
      type t = draw_context

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

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

      and t =
        [ `Move of segment
        | `Insert of node
        | `Overwrite of node
        | `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) (c : 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)
               c.sel);
          match search_forward (is_boundary `Line) c.sel 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.))

    let draw_cursor_root (c : cursor) : 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 c.root))))
        (atom `Empty)

    let draw_cursor_sel (c : cursor) : 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 (sub c.sel)))))
        (atom `Empty)

    let textedit ?(bindings = textedit_bindings) (n : node) =
      Format.pp_set_max_boxes F.stderr 64;
      (*full screen fynn  *)
      Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230;
      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 handler_of_node (n : node) : handler option =
      let f n =
        match n.t with `Attr (`Handler f, _) -> Some f | _ -> None
      in
      match f n with Some a -> Some a | None -> search_forward f n

    let handle_event (n : node) (ev : Event.t) : event_status =
      match handler_of_node n with
      | Some f -> (
          match f n ev with Some ev -> `Event ev | None -> `Handled)
      | None -> `Event ev

    let panel (vg : NVG.t) (p : P2.t) (t : node) (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

    let storetree = ref (Nav.test_pull ())
    let storecursor = ref []

    open Lwt.Infix

    let render_lwt (vg : NVG.t) (p : P2.t) (_ev : Event.t) :
        unit Lwt.t =
      !storetree >>= fun tree ->
      Nav.S.Tree.list tree !storecursor >>= fun l ->
      let contents =
        String.concat "\n" (List.map (fun (step, _t') -> step) l)
      in

      Draw.node { vg; style = Style.dark } p (Text.lines contents)
      |> ignore;
      Lwt.return_unit
  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 *)