open Lwt.Infix
module Gv = Graphv_gles2_native
module F = Fmt
module Str = Re.Str

type stroke = { width : float; color : Gv.Color.t }

let debugsec = ref false
let stroke_none = { width = 0.; color = Gv.Color.transparent }

let pp_text_row : Gv.Text.text_row F.t =
  F.(
    record
      [
        field "start_index" (fun r -> Gv.Text.(r.start_index)) int;
        field "end_index" (fun r -> Gv.Text.(r.end_index)) int;
        field "width" (fun r -> Gv.Text.(r.width)) float;
        field "minx" (fun r -> Gv.Text.(r.minx)) float;
        field "maxx" (fun r -> Gv.Text.(r.maxx)) float;
        field "next" (fun r -> Gv.Text.(r.next)) int;
      ])

let pp_color : Gv.Color.t Fmt.t =
  F.(
    hbox
    @@ record
         [
           field "r" (fun (s : Gv.Color.t) -> s.r) float;
           field "g" (fun (s : Gv.Color.t) -> s.g) float;
           field "b" (fun (s : Gv.Color.t) -> s.b) float;
           field "a" (fun (s : Gv.Color.t) -> s.a) float;
         ])

module Margin = struct
  open Gg

  type t = {
    left : size1;
    right : size1;
    top : size1;
    bottom : size1;
  }

  let empty = { left = 0.; right = 0.; top = 0.; bottom = 0. }
  let symmetric h w = { left = w; right = w; top = h; bottom = h }
  let sum t : size2 = Size2.v (t.left +. t.right) (t.top +. t.bottom)

  let inner t b : box2 =
    Box2.v
      (V2.v (Box2.minx b +. t.left) (Box2.miny b +. t.top))
      (V2.v (Box2.maxx b -. t.right) (Box2.maxy b -. t.bottom))

  let outer t b =
    Box2.(
      v
        (V2.v (minx b -. t.left) (miny b -. t.top))
        (V2.v (maxx b +. t.right) (maxy b +. t.bottom)))

  let pp ppf t =
    F.pf ppf "l=%f@;r=%f@;t=%f@;b=%f" t.left t.right t.top t.bottom
end

type margin = Margin.t

let string_of_utf_8_uchar uc =
  Buffer.(
    let b = create 4 in
    add_utf_8_uchar b uc;
    contents b)

let pp_uchar : Uchar.t F.t =
 fun ppf u -> F.pf ppf "%S" (string_of_utf_8_uchar u)

module Sense = struct
  type t = {
    click : bool;
    drag : bool;
    focusable : bool;
    edit : bool;
  }

  let click =
    { click = true; drag = false; focusable = true; edit = false }

  let hover =
    { click = false; drag = false; focusable = true; edit = false }
end

module TextBuffer = struct
  type t = {
    mutable path : string list;
    mutable tree : Store.S.tree;
    repo : Store.Sync.db Lwt.t;
  }

  let of_repo ~path ~(repo : Store.Sync.db Lwt.t) =
    let tree = Lwt_main.run (repo >>= Store.S.tree) in
    { path; tree; repo }

  let of_string ~path ?(repo = None) str =
    {
      path;
      tree = Store.S.Tree.singleton path str;
      repo =
        ( Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' ->
          Option.value ~default:Store.S.(empty repo') repo );
    }

  let insert_uchar t n uc : t Lwt.t =
    F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;

    match t with
    | { path; tree; _ } as tt ->
        Store.S.Tree.update tree path (function
          | Some src ->
              let sn = String.length src in
              assert (n <= sn);
              let ucbuf = Bytes.create 8 in
              let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in
              let dst = Bytes.create (sn + uclen) in
              BytesLabels.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0
                ~len:n;
              BytesLabels.blit ~src:ucbuf ~src_pos:0 ~dst ~dst_pos:n
                ~len:uclen;
              if sn > n + uclen then
                BytesLabels.blit_string ~src ~src_pos:n ~dst
                  ~dst_pos:(n + uclen)
                  ~len:(sn - (n + uclen));
              Some (Bytes.to_string dst)
          | None -> None)
        >>= fun tree -> Lwt.return { tt with tree }

  let remove t (a, b) : t Lwt.t =
    let a, b = (min a b, max a b) in
    F.epr "TextBuffer.remove (%d, %d)@." a b;
    match t with
    | { path; tree; _ } as tt ->
        Store.S.Tree.update tree path (function
          | Some src ->
              let srcn = String.length src in
              assert (max a b <= srcn);
              let dst = Bytes.create (srcn - (b - a)) in
              Bytes.blit_string src 0 dst 0 a;
              Bytes.blit_string src b dst a (srcn - b);
              Some (Bytes.to_string dst)
          | v -> v)
        >>= fun tree -> Lwt.return { tt with tree }

  let remove_uchar t n : t Lwt.t =
    F.epr "TextBuffer.remove_subset n=%d @." n;
    match t with
    | { path; tree; _ } as tt ->
        Store.S.Tree.update tree path (function
          | Some src ->
              let srcn = String.length src in
              assert (n < srcn);
              let ucn =
                Uchar.utf_decode_length (String.get_utf_8_uchar src n)
              in
              let dst = Bytes.create (srcn - ucn) in
              Bytes.blit_string src 0 dst 0 n;
              Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn);
              Some (Bytes.to_string dst)
          | v -> v)
        >>= fun tree -> Lwt.return { tt with tree }

  let fold_string t (f : string -> 'a) : 'a Lwt.t =
    match t with
    | { path; tree; _ } ->
        Store.S.Tree.get tree path >>= fun text -> Lwt.return (f text)

  let contents { path; tree; _ } =
    (try Store.S.Tree.get tree path with
    | Not_found | Invalid_argument _ ->
        Lwt.return
        @@ F.str
             "print_newline \"/%s: Not_found | Invalid_argument\";;"
             (String.concat "/" path)
    | exc ->
        Lwt.return
          (F.str "Store.S.Tree.get /%s exception: %s"
             (String.concat "/" path)
             (Printexc.to_string exc)))
    >>= fun text -> Lwt.return text

  let length { path; tree; _ } =
    Store.S.Tree.get tree path >>= fun text ->
    Lwt.return (String.length text)
end

module Event = struct
  type key_action = GLFW.key_action
  type key = GLFW.key
  type key_mod = GLFW.key_mod
  type event = Key of key_action * key * key_mod list

  (* Stolen from zed_input.ml *)
  module EventMap = Map.Make (struct
    type t = event

    let compare = compare
  end)

  type 'a t = 'a node EventMap.t
  and 'a node = Set of 'a t | Val of 'a

  let empty = EventMap.empty

  let rec add (events : event list) value set =
    match events with
    | [] -> invalid_arg "Event.add"
    | [ event ] -> EventMap.add event (Val value) set
    | event :: events -> (
        match
          try Some (EventMap.find event set) with Not_found -> None
        with
        | None | Some (Val _) ->
            EventMap.add event (Set (add events value empty)) set
        | Some (Set s) ->
            EventMap.add event (Set (add events value s)) set)

  let adds (events : event list list) value set =
    List.fold_left (fun s e -> add e value s) set events

  let rec remove events set =
    match events with
    | [] -> invalid_arg "Event.remove"
    | [ event ] -> EventMap.remove event set
    | event :: events -> (
        match
          try Some (EventMap.find event set) with Not_found -> None
        with
        | None | Some (Val _) -> set
        | Some (Set s) ->
            let s = remove events s in
            if EventMap.is_empty s then EventMap.remove event set
            else EventMap.add event (Set s) set)

  let fold f set acc =
    let rec loop prefix set acc =
      EventMap.fold
        (fun event node acc ->
          match node with
          | Val v -> f (List.rev (event :: prefix)) v acc
          | Set s -> loop (event :: prefix) s acc)
        set acc
    in
    loop [] set acc

  let bindings set =
    List.rev
      (fold (fun events action l -> (events, action) :: l) set [])

  module type Pack = sig
    type a
    type b

    val set : a t
    val map : a -> b
  end

  type 'a pack = (module Pack with type b = 'a)
  type 'a resolver = 'a pack list

  let pack (type u v) map set =
    let module Pack = struct
      type a = u
      type b = v

      let set = set
      let map = map
    end in
    (module Pack : Pack with type b = v)

  let resolver l = l

  type 'a result =
    | Accepted of 'a
    | Continue of 'a resolver
    | Rejected

  let rec resolve_rec :
        'a. event -> 'a pack list -> 'a pack list -> 'a result =
   fun (type u) event acc packs ->
    match packs with
    | [] -> if acc = [] then Rejected else Continue (List.rev acc)
    | p :: packs -> (
        let module Pack = (val p : Pack with type b = u) in
        match
          try Some (EventMap.find event Pack.set)
          with Not_found -> None
        with
        | Some (Set set) ->
            resolve_rec event (pack Pack.map set :: acc) packs
        | Some (Val v) -> Accepted (Pack.map v)
        | None -> resolve_rec event acc packs)

  let resolve event sets = resolve_rec event [] sets

  include Glfw_types

  let pp_event : event F.t =
   fun ppf e ->
    let open Glfw_types in
    match e with
    | Key (a, k, m) ->
        F.pf ppf "Key %a, %a, %a" pp_key_action a pp_key k pp_mods m
end

type event = Event.event

module Align = struct
  open Gg

  type range = size1 * size1

  type t =
    | Min (* Left or top. *)
    | Center (* Horizontal or vertical center *)
    | Max (* Right or bottom *)

  let pp_t ppf =
    F.(
      function
      | Min -> pf ppf "Min"
      | Center -> pf ppf "Center"
      | Max -> pf ppf "Max")

  let size_within_rect (size : size2) (frame : box2) : box2 =
    let size_within_range (size : size1) (range : range) : range =
      let min, max = range in
      if max -. min == Float.infinity && size == Float.infinity then
        range
      else range
    in
    let x_range =
      size_within_range (P2.x size) (Box2.minx frame, Box2.maxx frame)
    in
    let y_range =
      size_within_range (P2.y size) (Box2.miny frame, Box2.maxy frame)
    in
    Box2.v
      (P2.v (fst x_range) (fst y_range))
      (P2.v (snd x_range) (snd y_range))
end

type align = Align.t

module Fonts = struct
  open Gg

  let pixels_per_point = ref 1.0

  type t = { gv : Gv.Text.font; pixels_per_point : size1 }

  let find_font gv name : t option =
    Option.fold
      ~some:(fun gv ->
        Some { gv; pixels_per_point = !pixels_per_point })
      ~none:None
      (Gv.Text.find_font gv ~name)
end

module TextLayout = struct
  open Gg

  type font_selection = Default | FontId of (string * float)

  type format = {
    font_id : font_selection;
    extra_letter_spacing : float;
    line_height : float option;
    color : Gv.Color.t;
    background : Gv.Color.t;
    italics : bool;
    underline : stroke;
    strikethrough : stroke;
    valign : align;
  }

  type text_wrapping = {
    max_width : float;
    max_rows : int;
    break_anywhere : bool;
    overflow_character : string option;
  }

  type section = { byte_range : int * int; format : format }

  type layout = {
    text : TextBuffer.t;
    sections : section list;
    wrap : text_wrapping;
    halign : align;
    justify : bool;
    line_height : float option;
  }

  type cursor = { index : int; last_col : int }

  let pp_format : format F.t =
    F.(
      record
        [
          field "font_id" (fun _ -> "...") string;
          field "extra_letter_spacing"
            (fun s -> s.extra_letter_spacing)
            float;
          field "line_height"
            (fun (s : format) -> s.line_height)
            (option float);
          field "color" (fun s -> s.color) pp_color;
          field "background" (fun s -> s.background) pp_color;
        ])

  let format_default =
    {
      font_id = FontId ("mono", 18.0);
      extra_letter_spacing = 0.0;
      line_height = Some 19.;
      color = Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9;
      background = Gv.Color.transparent;
      italics = false;
      underline = stroke_none;
      strikethrough = stroke_none;
      valign = Max;
    }

  let format_simple font_id color : format =
    { format_default with font_id; color }

  let pp_text_wrapping =
    F.(
      record
        [
          field "max_width" (fun s -> s.max_width) float;
          field "max_rows" (fun s -> s.max_rows) int;
          field "break_anywhere" (fun s -> s.break_anywhere) bool;
          field "overflow_character"
            (fun s -> s.overflow_character)
            (option string);
        ])

  let default_text_wrapping () =
    {
      max_width = Float.infinity;
      max_rows = 100;
      (* TODO *)
      break_anywhere = false;
      overflow_character = Some "…";
    }

  let pp_section : Format.formatter -> 'a -> unit =
    F.(
      record
        [
          field "byte_range"
            (fun s -> s.byte_range)
            (pair ~sep:(any ",") int int);
          (* field "format" (fun s -> s.format) pp_format; *)
        ])

  let section_default =
    { byte_range = (0, 0); format = format_default }

  let pp_layout =
    F.(
      record
        [
          field "text"
            (fun s -> str "path=%s" (String.concat "/" s.text.path))
            string;
          field "sections"
            (fun s -> s.sections)
            (brackets @@ list pp_section);
          field "wrap" (fun s -> s.wrap) pp_text_wrapping;
          field "halign" (fun s -> s.halign) Align.pp_t;
          field "justify" (fun s -> s.justify) bool;
        ])

  let layout_default =
    {
      text = TextBuffer.of_string ~path:[] "";
      sections = [ section_default ];
      wrap = default_text_wrapping ();
      halign = Min;
      justify = false;
      line_height = Some 18.;
    }

  let pp_text_row : Format.formatter -> Gv.Text.text_row -> unit =
    F.(
      record
        [
          field "start_index"
            (fun (s : Gv.Text.text_row) -> s.start_index)
            int;
          field "end_index"
            (fun (s : Gv.Text.text_row) -> s.end_index)
            int;
          field "width" (fun (s : Gv.Text.text_row) -> s.width) float;
          field "minx" (fun (s : Gv.Text.text_row) -> s.minx) float;
          field "maxx" (fun (s : Gv.Text.text_row) -> s.maxx) float;
        ])

  let cursor_default = { index = 0; last_col = 0 }

  let cursor ?(last_col = 0) index : cursor =
    F.epr "cursor last_col=%d index=%d@." last_col index;
    { index; last_col }

  let simple text ?(start = 0) ?(format = format_default) wrap_width :
      layout Lwt.t =
    TextBuffer.fold_string text (fun s ->
        {
          layout_default with
          text;
          sections =
            [ { byte_range = (start, String.length s); format } ];
          wrap =
            { (default_text_wrapping ()) with max_width = wrap_width };
        })

  let cursor_color = ref (Gv.Color.rgbf ~r:0.5 ~g:0.5 ~b:0.)

  let default_cursor_formatter (f : format) =
    { f with background = !cursor_color }

  let default_mark_formatter (f : format) =
    { f with background = Gv.Color.rgbf ~r:0.3 ~g:0.3 ~b:0.3 }

  let with_range ((cs, ce) : int * int)
      ?(format = default_cursor_formatter) layout : layout =
    {
      layout with
      sections =
        List.fold_left
          (fun (l : section list) sec ->
            let s, e = sec.byte_range in
            if !debugsec then
              F.epr "with_range section cs=%d ce=%d s=%d e=%d@." cs ce
                s e;

            l
            @ (if
                 e < cs || ce < s
                 (* cursor start is after this section or cursor end is before this section *)
               then [ sec ]
               else [])
            @ (if
                 cs > s
                 && cs <= e (* if cursor start is in this section *)
               then [ { sec with byte_range = (s, cs) } ]
               else [])
            @ (if
                 cs <= e && ce >= s
                 (* if cursor start is at or before the end this section and cursor end is at or after the beginning of this section *)
               then
                 [
                   {
                     format = format sec.format;
                     byte_range = (max cs s, min ce e);
                   };
                 ]
               else [])
            @
            if
              ce > s && ce <= e (* if cursor end is in this section *)
            then [ { sec with byte_range = (ce, e) } ]
            else [])
          [] layout.sections;
    }

  let with_cursor (cur : cursor) ?(format = default_cursor_formatter)
      layout : layout =
    let c = with_range (cur.index, cur.index + 1) ~format layout in
    if !debugsec then
      F.epr "with_cursor %a@."
        F.(brackets @@ list ~sep:cut pp_section)
        c.sections;
    c

  let with_mark (mark : int option) (cur : int)
      ?(format = default_mark_formatter) layout : layout =
    match mark with
    | Some mark' ->
        with_range ~format (min mark' cur, max mark' cur) layout
    | None -> layout
end

let rec nth_tl n = function
  | hd :: tl -> if n > 0 then nth_tl (n - 1) tl else hd :: tl
  | [] -> []

let _ =
  assert (List.equal Int.equal (nth_tl 2 [ 0; 1; 2; 3 ]) [ 2; 3 ]);
  assert (List.equal Int.equal (nth_tl 3 [ 0; 1; 2 ]) []);
  assert (List.equal Int.equal (nth_tl 0 [ 0; 1 ]) [ 0; 1 ])

module Style = struct
  open Gg

  type text_style = unit

  type spacing = {
    item_spacing : Gg.size2;
    window_margin : Margin.t;
    indent : Gg.size1;
    interact_size : Gg.size2;
    slider_width : Gg.size1;
    text_edit_width : Gg.size1;
    icon_width : Gg.size1;
    icon_width_inner : Gg.size1;
    icon_spacing : Gg.size1;
  }

  type t = {
    override_text_style : text_style option;
    override_font : TextLayout.font_selection option;
    wrap : bool option;
    spacing : spacing;
    (*interaction: Interaction.t; *)
    animation_time : float;
  }

  let default =
    {
      override_text_style = None;
      override_font = None;
      wrap = None;
      spacing =
        {
          item_spacing = Size2.v 10. 10.;
          window_margin = Margin.symmetric 5. 5.;
          indent = 5.;
          slider_width = 5.;
          text_edit_width = 500.;
          icon_width = 40.;
          icon_width_inner = 35.;
          icon_spacing = 50.;
          interact_size = P2.v 500. 500.;
        };
      animation_time = 0.1;
    }
end

module Ui = struct
  type t = {
    mutable rect : Gg.box2;
    style : Style.t;
    enabled : bool;
    gv : Gv.t;
    glfw_window : GLFW.window option;
    mutable bindings : action list Event.t;
  }

  and action = Custom of (unit -> unit Lwt.t)

  let id = ref 0
  let spacing ui = ui.style.spacing

  let window gv ?(window : GLFW.window option) rect : t =
    {
      rect;
      style = Style.default;
      enabled = true;
      gv;
      glfw_window = window;
      bindings = Event.empty;
    }

  let callback_resolver : action list Event.resolver option ref =
    ref Option.None

  let keycallback t (state : Event.key_action) (key : Event.key)
      (mods : Event.key_mod list) : bool Lwt.t =
    let res =
      match !callback_resolver with
      | Some res -> res
      | None -> Event.resolver [ Event.pack Fun.id t.bindings ]
    in

    Event.(
      F.epr "Ui.keycallback %a %a %a@." pp_key key pp_key_action state
        pp_mods mods);
    match Event.resolve (Key (state, key, mods)) res with
    | Event.Accepted actions ->
        callback_resolver := None;
        let rec exec : action list -> bool Lwt.t = function
          | Custom f :: actions -> f () >>= fun () -> exec actions
          | [] -> Lwt.return false
        in
        exec actions
    | Event.Continue res ->
        callback_resolver := Some res;
        Lwt.return true
    | Event.Rejected ->
        callback_resolver := None;
        Lwt.return false

  let update_bindings ui
      (f : action list Event.t -> action list Event.t) =
    ui.bindings <- f ui.bindings

  let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
    ref (fun c ->
        F.epr "chrcallback: '%a'@." pp_uchar c;
        Lwt.return_unit)

  let chrcallback _t (chr : int) : unit Lwt.t =
    !chrcallback_ref @@ Uchar.of_int chr

  module Style = struct
    type t = {
      stroke : float option * Gv.Color.t;
      fill : Gv.Color.t;
      margin : Margin.t;
    }

    let default =
      {
        stroke = (None, Gv.Color.transparent);
        fill = Gv.Color.transparent;
        margin = Margin.empty;
      }

    let pp ppf t =
      F.pf ppf "%a"
        F.(
          record
            [
              field "stroke"
                (fun t -> t.stroke)
                (hbox
                @@ pair ~sep:comma
                     (option ~none:(any "None") float)
                     pp_color);
              field "fill" (fun t -> t.fill) pp_color;
              field "margin" (fun t -> t.margin) Margin.pp;
            ])
        t
  end
end

module TextEdit = struct
  open Gg

  type t = {
    mutable text : TextBuffer.t;
    mutable cursor : TextLayout.cursor;
    mutable mark : int option;
    mutable scroll : int;
    mutable rows : int;
    text_format : TextLayout.format;
    formatter :
      (Ui.t -> TextBuffer.t -> float -> TextLayout.layout) option;
    password : bool;
    frame : bool;
    margin : margin;
    multiline : bool;
    interactive : bool;
    desired_width : float option;
    desired_height_rows : int;
    cursor_at_end : bool;
    min_size : v2;
    align : align;
    clip_text : bool;
    char_limit : int; (* return_key : keyboard_shortcut; *)
  }

  let col t =
    TextBuffer.fold_string t.text (fun s ->
        t.cursor.index
        - Str.search_backward (Str.regexp "^") s t.cursor.index)

  let rec newlines (s : string) (i : int) : int list =
    match String.index_from_opt s i '\n' with
    | Some i' -> i :: newlines s i'
    | None -> []

  let rec index_rows_from (s : string) (start : int) (rows : int) :
      int option =
    match String.index_from_opt s start '\n' with
    | Some start' ->
        if rows - 1 > 0 then index_rows_from s (start' + 1) (rows - 1)
        else Some (start' + 1)
    | None -> None (* eof *)

  let rec rindex_rows_from (s : string) (start : int) (rows : int) :
      int option =
    match String.rindex_from_opt s start '\n' with
    | Some start' ->
        if start' - 1 <= 0 then None
        else if rows - 1 > 0 then
          rindex_rows_from s (start' - 1) (rows - 1)
        else Some (start' + 1)
    | None -> None (* eof *)

  let scroll_update ({ text; cursor; scroll; rows; _ } as t : t) :
      unit Lwt.t =
    TextBuffer.fold_string text (fun s ->
        let slen = String.length s in
        (if cursor.index < scroll then
           match
             String.rindex_from_opt s
               (min (slen - 1) (cursor.index - 1))
               '\n'
           with
           | Some i' -> t.scroll <- i' + 1
           | None -> t.scroll <- 0
         else
           match index_rows_from s scroll rows with
           | None -> ()
           | Some eow -> (
               F.epr "eow=%d@." eow;
               if cursor.index >= eow then
                 match
                   rindex_rows_from s
                     (min (slen - 1) cursor.index)
                     rows
                 with
                 | None -> ()
                 | Some i' -> t.scroll <- i'));
        F.epr
          "scroll_update slen=%d cursor=%d scroll=%d c-s=%d rows=%d@."
          (String.length s) t.cursor.index t.scroll
          (cursor.index - t.scroll)
          rows;
        debugsec := true)

  let cursor_update (t : t) (f : int -> int) : unit Lwt.t =
    col t >>= fun last_col ->
    TextBuffer.fold_string t.text (fun s ->
        t.cursor <-
          TextLayout.cursor ~last_col
            (f t.cursor.index |> max 0 |> min (String.length s)))
    >>= fun () -> scroll_update t

  let cursor_move (t : t) (amt : int) : unit Lwt.t =
    cursor_update t (( + ) amt)

  let cursor_set (t : t) (index : int) : unit Lwt.t =
    cursor_update t (Fun.const index)

  let default_bindings (t : t) (ui : Ui.t) : unit Lwt.t =
    let open GLFW in
    let open Event in
    let open Ui in
    Ui.update_bindings ui (fun a ->
        a
        |> adds
             [
               [ Key (Press, F, [ Control ]) ];
               [ Key (Repeat, F, [ Control ]) ];
               [ Key (Press, Right, []) ];
               [ Key (Repeat, Right, []) ];
             ]
             [ Custom (fun () -> cursor_move t 1) ]
        |> adds
             [
               [ Key (Press, B, [ Control ]) ];
               [ Key (Repeat, B, [ Control ]) ];
               [ Key (Press, Left, []) ];
               [ Key (Repeat, Left, []) ];
             ]
             [ Custom (fun () -> cursor_move t (-1)) ]
        |> adds
             [
               [ Key (Press, N, [ Control ]) ];
               [ Key (Repeat, N, [ Control ]) ];
               [ Key (Press, Down, []) ];
               [ Key (Repeat, Down, []) ];
             ]
             [
               Custom
                 (fun () ->
                   TextBuffer.fold_string t.text (fun s ->
                       let sn = String.length s in
                       let seol =
                         Str.search_forward (Str.regexp "$")
                       in
                       let next_bol =
                         min sn (seol s t.cursor.index + 1)
                       in
                       let next_line_len =
                         seol s next_bol - next_bol
                       in
                       next_bol
                       +
                       if t.cursor.last_col > next_line_len then
                         next_line_len
                       else min next_line_len t.cursor.last_col)
                   >>= cursor_set t);
             ]
        |> adds
             [
               [ Key (Press, P, [ Control ]) ];
               [ Key (Repeat, P, [ Control ]) ];
               [ Key (Press, Up, []) ];
               [ Key (Repeat, Up, []) ];
             ]
             [
               Custom
                 (fun () ->
                   TextBuffer.fold_string t.text (fun s ->
                       let sbol =
                         Str.search_backward (Str.regexp "^") s
                       in
                       let bol = sbol t.cursor.index in
                       if bol > 0 then
                         let prev_bol = sbol (max 0 (bol - 1)) in
                         let prev_line_len = bol - 1 - prev_bol in

                         (*F.epr
                           "up: index=%d bol=%d prev_bol=%d \
                            prev_line_len=%d @."
                           t.cursor.index bol prev_bol prev_line_len; *)
                         prev_bol
                         +
                         if t.cursor.last_col > prev_line_len then
                           prev_line_len
                         else min prev_line_len t.cursor.last_col
                       else t.cursor.index)
                   >>= cursor_set t);
             ]
        |> adds (* EOL *)
             [
               [ Key (Press, E, [ Control ]) ];
               [ Key (Press, End, []) ];
             ]
             [
               Custom
                 (fun () ->
                   TextBuffer.fold_string t.text (fun s ->
                       let bol =
                         Str.search_backward (Str.regexp "^") s
                           t.cursor.index
                       in
                       let eol =
                         Str.search_forward (Str.regexp "$") s
                           t.cursor.index
                       in
                       t.cursor <-
                         TextLayout.cursor ~last_col:(eol - bol) eol));
             ]
        |> adds (* BOL *)
             [
               [ Key (Press, A, [ Control ]) ];
               [ Key (Press, Home, []) ];
             ]
             [
               Custom
                 (fun () ->
                   TextBuffer.fold_string t.text (fun s ->
                       t.cursor <-
                         TextLayout.cursor ~last_col:0
                           (Str.search_backward (Str.regexp "^") s
                              t.cursor.index)));
             ]
        |> adds
             [
               [ Key (Press, Backspace, []) ];
               [ Key (Repeat, Backspace, []) ];
             ]
             [
               Custom
                 (fun () ->
                   match t.mark with
                   | Some mark ->
                       TextBuffer.remove t.text (mark, t.cursor.index)
                       >>= fun text ->
                       t.text <- text;
                       t.mark <- None;
                       cursor_set t (min mark t.cursor.index)
                   | None ->
                       if t.cursor.index > 0 then (
                         TextBuffer.remove_uchar t.text
                           (t.cursor.index - 1)
                         >>= fun text ->
                         t.text <- text;
                         cursor_move t (-1))
                       else Lwt.return_unit);
             ]
        |> adds
             [ [ Key (Press, K, [ Control ]) ] ]
             [
               Custom
                 (fun () ->
                   TextBuffer.fold_string t.text (fun s ->
                       TextBuffer.remove t.text
                         ( t.cursor.index,
                           let eol =
                             Str.search_forward (Str.regexp "$") s
                               t.cursor.index
                           in
                           if
                             eol == t.cursor.index
                             && String.length s > eol
                           then eol + 1
                           else eol )
                       >>= fun text ->
                       t.text <- text;
                       t.mark <- None;
                       cursor_set t t.cursor.index)
                   >>= fun u -> u);
             ]
        |> adds
             [
               [ Key (Press, Enter, []) ]; [ Key (Repeat, Enter, []) ];
             ]
             [
               Custom
                 (fun () ->
                   TextBuffer.insert_uchar t.text t.cursor.index
                     (Uchar.of_char '\n')
                   >>= fun text ->
                   t.text <- text;
                   cursor_move t 1);
             ]
        |> adds
             [ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
             [
               Custom
                 (fun () ->
                   t.mark <-
                     (match t.mark with
                     | Some _ -> None
                     | None -> Some t.cursor.index);
                   Lwt.return_unit);
             ]);
    (* WARN XXX TKTK TODO this is probably "breaking" the lwt context and being used in other calls to Lwt_main.run *)
    (Ui.chrcallback_ref :=
       fun c ->
         TextBuffer.insert_uchar t.text t.cursor.index c
         >>= fun text ->
         t.text <- text;
         cursor_move t 1
       (* This creates a giant stack of calls lol
          >>= fun () -> !Ui.chrcallback_ref c *));
    Lwt.return_unit

  let multiline ui ?(text_format = TextLayout.format_default)
      (text : TextBuffer.t) : t =
    let t =
      {
        text;
        cursor = TextLayout.cursor 0;
        mark = None;
        scroll = 0;
        rows = 0;
        text_format;
        formatter = None;
        password = false;
        frame = true;
        margin = Margin.symmetric 4.0 2.0;
        multiline = true;
        interactive = true;
        desired_width = None;
        desired_height_rows = 4;
        cursor_at_end = true;
        min_size = Gg.V2.zero;
        align = Min;
        clip_text = false;
        char_limit = Int.max_int;
        (* return_key = keyboard_shortcut; *)
      }
    in
    Lwt_main.run (default_bindings t ui);
    t
end

module Layout = struct
  open Gg
  module Style = Ui.Style

  type frame = { t : t; mutable size : size; style : Style.t }

  and t =
    [ `Box of [ `H | `V | `Z ] * frame list
    | `String of string
    | `Buffer of TextBuffer.t
    | `TextEdit of TextEdit.t
    | `None ]

  and size = [ `Fixed of size2 | `Max | `Min ]

  let frame ?(size = `Max) ?(style = Style.default) t : frame =
    { t; size; style }

  let box d ?style t = frame ?style (`Box (d, t))
  let hbox, vbox, zbox = (box `H, box `V, box `Z)

  let textedit_style =
    Style.
      {
        default with
        stroke = (Some 1.2, Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9);
        margin = Margin.symmetric 10. 10.;
      }

  let textedit ?size ?(style = textedit_style) te =
    frame ?size ~style (`TextEdit te)

  let pp_dir ppf (t : [ `H | `V | `Z ]) =
    F.pf ppf "%s"
      (match t with `H -> "`H" | `V -> "`V" | `Z -> "`Z")

  let pp_t ppf (t : t) =
    F.pf ppf "%s"
      (match t with
      | `Box (d, _) -> F.str "`Box %a" pp_dir d
      | `Buffer _ -> "`Buffer"
      | `TextEdit _ -> "`TextEdit"
      | `String s -> F.str "`String %s" s
      | `None -> "`None")

  let pp_size ppf = function
    | `Fixed p -> F.pf ppf "`Fixed %a" Gg.V2.pp p
    | `Max -> F.pf ppf "`Max"
    | `Min -> F.pf ppf "`Min"

  let pp_frame =
    F.(
      record
        [
          field "t" (fun t -> t.t) pp_t;
          field "size" (fun t -> t.size) pp_size;
          field "style" (fun t -> t.style) Style.pp;
        ])

  let parse_t_frame s =
    match s with
    | "`Box" -> `Vbox
    | "`Buffer" -> `Buffer
    | "`TextEdit" -> `TextEdit
    | "`None" -> `None
    | s -> `S s
end

module Painter = struct
  open Layout
  open Gg

  let draw_box (t : Gv.t) ~(box : Gg.box2) ~(style : Layout.Style.t) =
    let open Gv in
    let open Box2 in
    Path.begin_ t;
    Path.rect t ~x:(minx box) ~y:(miny box) ~w:(w box) ~h:(h box);
    set_fill_color t ~color:style.fill;
    set_stroke_color t ~color:(snd style.stroke);
    (match style.stroke with
    | None, _ -> ()
    | Some width, _ ->
        set_stroke_width t ~width;
        stroke t);
    fill t

  let set_text_format (t : Gv.t) (format : TextLayout.format) =
    let font_name, font_size =
      match format.font_id with
      | Default -> ("mono", 18.)
      | FontId (s, size) -> (s, size)
    in
    let open Gv in
    Text.set_font_face t ~name:font_name;
    Text.set_size t ~size:font_size;
    Text.set_align t ~align:Align.(left lor top)

  let text_layout (t : Gv.t) (rect : box2) (te : TextEdit.t)
      (g : TextLayout.layout) : box2 Lwt.t =
    let line_height =
      Option.value ~default:(Gv.Text.metrics t).line_height
        g.line_height
    in
    let max_rows = Int.of_float (Box2.h rect /. line_height) in
    te.rows <- max_rows;
    let lines = Gv.Text.make_empty_rows max_rows in
    TextBuffer.contents g.text >>= fun contents ->
    let contents_len = String.length contents in
    let row_count =
      Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows
        ~lines ~start:te.scroll contents
    in
    Seq.fold_left
      (fun ((cur, start) : p2 * int) (row : Gv.Text.text_row) ->
        if !debugsec then
          F.epr "start=%d row=%a %a @." start pp_text_row row
            F.(brackets @@ list TextLayout.pp_section)
            g.sections;
        debugsec := false;
        let sections =
          List.filter
            (fun (r : TextLayout.section) ->
              fst r.byte_range <= row.end_index
              && snd r.byte_range > start)
            g.sections
        in
        List.fold_left
          (fun (cur' : p2) (sec : TextLayout.section) ->
            let start, end_ =
              ( start |> max (fst sec.byte_range) |> min contents_len,
                row.end_index |> min contents_len
                |> min (snd sec.byte_range) )
            in
            let width =
              if start == row.end_index then
                (* hack to display cursor at end of row *)
                (Gv.Text.bounds t ~x:(P2.x cur') ~y:0. " ").advance
              else
                (Gv.Text.bounds t ~x:(P2.x cur') ~y:0. ~start ~end_
                   contents)
                  .advance
            in
            let line_height =
              Option.value ~default:(Gv.Text.metrics t).line_height
                sec.format.line_height
            in
            draw_box t
              ~box:
                (Box2.v
                   (V2.v (P2.x cur') (P2.y cur))
                   (V2.v width line_height))
              ~style:
                Layout.Style.
                  { default with fill = sec.format.background };
            set_text_format t sec.format;
            Gv.set_fill_color t ~color:sec.format.color;
            V2.v
              (Gv.Text.text_w t ~x:(P2.x cur') ~y:(P2.y cur) ~start
                 ~end_ contents)
              Float.(max (P2.y cur +. line_height) (P2.y cur')))
          P2.(v (Box2.minx rect) (y cur))
          sections
        |> fun cur'' ->
        (V2.(v (max (x cur) (x cur'')) (y cur'')), row.next))
      (Box2.o rect, te.scroll)
      (Seq.take row_count (Array.to_seq lines))
    |> fst
    |> Box2.(of_pts (o rect))
    |> Lwt.return

  let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t
      =
    let box' = Margin.inner frame.style.margin box in
    (match frame.t with
    | `Box (dir, ll) ->
        Lwt_list.fold_left_s
          (fun (c : box2) f ->
            layout c ui f >>= fun r ->
            let c' =
              Box2.(
                match dir with
                | `V -> of_pts (V2.v (minx c) (maxy r)) (max c)
                | `H -> of_pts (V2.v (maxx r) (miny c)) (max c)
                | `Z -> box)
            in
            Lwt.return c')
          box' ll
    | `TextEdit t ->
        TextLayout.(
          simple t.text ~start:t.scroll ~format:t.text_format
            (Option.value ~default:(Box2.w box') t.desired_width)
          >>= fun layout ->
          with_cursor t.cursor layout
          |> with_mark t.mark t.cursor.index
          |> text_layout ui.gv box' t)
    | _ -> Lwt.return box)
    >>= fun r ->
    let r' = Margin.outer frame.style.margin r in
    draw_box ui.gv ~box:r' ~style:frame.style;
    Lwt.return r'
end