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

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

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

module Margin = struct
  open Gg

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

  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))
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;
  }

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

  let of_string ~path ?(repo = None) str =
    Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' ->
    Option.value ~default:Store.S.(empty repo') repo >>= fun repo ->
    Lwt.return { path; tree = Store.S.Tree.singleton path str; 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 ->
              assert (n <= String.length src);
              let ucbuf = Bytes.create 8 in
              let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in
              let dst = Bytes.create (String.length src + 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;
              BytesLabels.blit_string ~src ~src_pos:n ~dst
                ~dst_pos:(n + uclen)
                ~len:(String.length src - (n + uclen));
              Some (Bytes.to_string dst)
          | None -> None)
        >>= 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
  (* | Char u -> F.pf ppf "Char %a" pp_uchar u
     | AnyChar -> F.pf ppf "AnyChar" *)
end

type event = Event.event
type id = int

module Response = struct
  type t = {
    (* layer_id : LayerId.t; *)
    id : id;
    rect : Gg.box2;
    interact_rect : Gg.box2;
    sense : Sense.t;
    enabled : bool;
    contains_pointer : bool;
    hovered : bool;
    highlighted : bool;
    clicked : bool;
    fake_primary_click : bool;
    long_touched : bool;
    drag_started : bool;
    dragged : bool;
    drag_stopped : bool;
    is_pointer_button_down_on : bool;
    interact_pointer_pos : Gg.p2 option;
    changed : bool;
  }
end

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

let pp_color : Gv.Color.t Fmt.t =
  F.(
    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 TextLayout = struct
  open Gg

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

  type text_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;
  }

  let pp_text_format : text_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 -> s.line_height) (option float);
          field "color" (fun s -> s.color) pp_color;
          field "background" (fun s -> s.background) pp_color;
        ])

  let text_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 text_format_simple font_id color : text_format =
    { text_format_default with font_id; color }

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

  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 "…";
    }

  type layout_section = {
    leading_space : float;
    byte_range : int * int;
    format : text_format;
  }

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

  let layout_section_default =
    {
      leading_space = 0.0;
      byte_range = (0, 0);
      format = text_format_default;
    }

  type layout_job = {
    text : TextBuffer.t;
    sections : layout_section array;
    wrap : text_wrapping;
    first_row_min_height : float;
    break_on_newline : bool;
    halign : align;
    justify : bool;
    line_height : float option;
  }

  let pp_layout_job =
    F.(
      record
        [
          field "text"
            (fun s -> str "path=%s" (String.concat "/" s.text.path))
            string;
          field "sections"
            (fun s -> s.sections)
            (brackets @@ array pp_layout_section);
          field "wrap" (fun s -> s.wrap) pp_text_wrapping;
          field "first_row_min_height"
            (fun s -> s.first_row_min_height)
            float;
          field "break_on_newline" (fun s -> s.break_on_newline) bool;
          field "halign" (fun s -> s.halign) Align.pp_t;
          field "justify" (fun s -> s.justify) bool;
        ])

  let layout_job_of_text text =
    {
      text;
      sections = Array.make 0 layout_section_default;
      wrap = default_text_wrapping ();
      first_row_min_height = 0.0;
      break_on_newline = true;
      halign = Min;
      justify = false;
      line_height = Some 18.;
    }

  type uv_rect = {
    offset : Gg.v2;
    size : Gg.v2;
    min : Gg.p2; (* Top left corner UV in texture *)
    max : Gg.p2; (* Bottom right corner (exclusive) *)
  }

  type glyph = {
    chr : string;
    pos : Gg.p2;
    ascent : float;
    size : Gg.size2;
    uv_rect : uv_rect;
    section_index : int;
  }

  type row_visuals = {
    (*     mesh : mesh; *)
    mesh_bounds : Gg.box2;
    glyph_vertex_range : int * int;
  }

  let pp_row_visuals =
    F.(
      record
        [
          field "mesh_bounds"
            (fun (s : row_visuals) -> s.mesh_bounds)
            Gg.Box2.pp;
          field "glyph_vertex_range"
            (fun (s : row_visuals) -> s.glyph_vertex_range)
            (pair ~sep:(any ",") int int);
        ])

  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;
        ])

  type row = {
    text_row : Gv.Text.text_row;
    section_index_at_start : int;
    glyphs : glyph list;
    rect : Gg.box2;
    visuals : row_visuals;
    ends_with_newline : bool;
  }

  let pp_row : Format.formatter -> row -> unit =
    F.(
      record
        [
          field "text_row" (fun s -> s.text_row) pp_text_row;
          field "section_index_at_start"
            (fun (s : row) -> s.section_index_at_start)
            int;
          field "format" (fun (s : row) -> List.length s.glyphs) int;
          field "rect" (fun (s : row) -> s.rect) Gg.Box2.pp;
          field "visuals" (fun (s : row) -> s.visuals) pp_row_visuals;
          field "ends_with_newline"
            (fun (s : row) -> s.ends_with_newline)
            bool;
        ])

  let row_default () =
    {
      text_row =
        {
          start_index = 0;
          end_index = 0;
          width = 0.;
          minx = 0.;
          maxx = 0.;
          next = 0;
        };
      section_index_at_start = 0;
      glyphs = [];
      rect = Box2.zero;
      visuals =
        { mesh_bounds = Box2.zero; glyph_vertex_range = (0, 0) };
      ends_with_newline = false;
    }

  type galley = {
    job : layout_job;
    rows : row array;
    elided : bool;
    rect : Gg.box2;
    mesh_bounds : Gg.box2;
    num_vertices : int;
    num_indices : int;
    pixels_per_point : float;
  }

  type rich_text = {
    text : string;
    size : float option;
    extra_letter_spacing : float;
    line_height : float option;
    font : string option;
    background_color : Gv.Color.t;
    text_color : Gv.Color.t;
    code : bool;
    strong : bool;
    weak : bool;
    strikethrough : bool;
    underline : bool;
    italics : bool;
    raised : bool;
  }

  let rich_text_default =
    {
      text = "";
      size = None;
      extra_letter_spacing = 0.0;
      line_height = None;
      font = None;
      background_color = Gv.Color.transparent;
      text_color = Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9;
      code = false;
      strong = false;
      weak = false;
      strikethrough = false;
      underline = false;
      italics = false;
      raised = false;
    }

  type widget_text =
    | RichText of rich_text
    | LayoutJob of layout_job
    | Galley of galley

  type cursor = {
    index : int;
    row : int option;
    last_col : int;
    prefer_next_row : bool;
  }

  let cursor_default =
    { index = 0; row = None; last_col = 0; prefer_next_row = false }

  let cursor ?(row : int option) ?(last_col = 0) index : cursor =
    F.epr "cursor row=%a last_col=%d index=%d@."
      F.(option int)
      row last_col index;
    { index; row; last_col; prefer_next_row = false }

  let simple text ?(format = text_format_default) wrap_width :
      layout_job Lwt.t =
    TextBuffer.length text >>= fun textlen ->
    Lwt.return
      {
        (layout_job_of_text text) with
        sections =
          Array.make 1
            { leading_space = 0.0; byte_range = (0, textlen); format };
        wrap =
          { (default_text_wrapping ()) with max_width = wrap_width };
        break_on_newline = true;
      }

  let singleline (text : TextBuffer.t) (format : text_format) :
      layout_job Lwt.t =
    simple text ~format Float.infinity >>= fun simple ->
    Lwt.return
      {
        simple with
        wrap = default_text_wrapping ();
        break_on_newline = true;
      }

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

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

  let with_cursor (cur : cursor)
      ?(cursor_format = default_cursor_formatter) layout_job :
      layout_job =
    (* this is more like a general range application to layout sections, but i don't need it yet *)
    let cs, ce = (cur.index, cur.index + 1) in
    {
      layout_job with
      sections =
        Array.of_list
          (* Lol maybe this is inefficient? (or maybe not) *)
          (List.fold_left
             (fun (l : layout_section list) sec ->
               let s, e = sec.byte_range in

               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
                    [
                      {
                        sec with
                        format = cursor_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 [])
             []
             (Array.to_list layout_job.sections));
    }

  let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job)
      (pos : v2) : galley Lwt.t =
    (* F.epr "TextLayout.layout@.";
       F.epr "job.wrap.max_width=%f@." job.wrap.max_widtha;
       F.epr "job.wrap.max_rows=%d@." job.wrap.max_rows; *)
    if job.wrap.max_rows == 0 then
      Lwt.return
        {
          job;
          rows = Array.make 1 (row_default ());
          rect = Box2.move pos Box2.zero;
          mesh_bounds = Box2.zero;
          elided = true;
          num_vertices = 0;
          num_indices = 0;
          pixels_per_point = fonts.pixels_per_point;
        }
    else
      let metrics = Gv.Text.metrics gv in
      let lines = Gv.Text.make_empty_rows job.wrap.max_rows in
      TextBuffer.contents job.text >>= fun contents ->
      let row_count =
        Gv.Text.break_lines gv ~break_width:job.wrap.max_width
          ~max_rows:job.wrap.max_rows ~lines contents
      in
      (* F.epr "row_count=%d@." row_count; *)
      let height = ref (V2.y pos) in
      let max_width = ref 0. in
      let line_height =
        Option.value ~default:metrics.line_height job.line_height
      in
      Lwt.return
        {
          job;
          rows =
            Array.init row_count (fun n ->
                let text_row = Array.get lines n in
                height := !height +. line_height;
                let rect =
                  Box2.v
                    (P2.v (V2.x pos) !height)
                    (P2.v
                       (text_row.width +. V2.x pos)
                       (!height +. line_height))
                in
                max_width := Float.max text_row.maxx !max_width;
                {
                  text_row;
                  section_index_at_start = 0;
                  glyphs = [ (* TODO *) ];
                  rect;
                  visuals =
                    {
                      mesh_bounds = rect;
                      glyph_vertex_range =
                        (text_row.start_index, text_row.end_index);
                    };
                  ends_with_newline = false (* TODO *);
                });
          rect =
            Box2.v Size2.zero
              (P2.v job.wrap.max_width
                 (Float.of_int row_count *. line_height));
          elided = row_count > job.wrap.max_rows (* TODO *);
          mesh_bounds = Box2.v Size2.zero (P2.v !max_width !height);
          num_indices = 0 (* TODO *);
          num_vertices = 0 (* TODO *);
          pixels_per_point = fonts.pixels_per_point;
        }
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 fonts ui (reader : Gv.t -> 'a) : 'a = reader ui

  let allocate_space (_gv : Gv.t) (size : Gg.box2) : id * Gg.box2 =
    id := !id + 1;
    (!id, size)

  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 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
end

module TextEdit = struct
  open Gg

  type t = {
    mutable text : TextBuffer.t;
    mutable cursor : TextLayout.cursor;
    id : id option;
    id_source : id option;
    text_format : TextLayout.text_format;
    layouter :
      (Ui.t -> TextBuffer.t -> float -> TextLayout.galley) 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 ->
        Str.search_backward (Str.regexp "^") s t.cursor.index)

  let cursor_move (t : t) (amt : int) : unit Lwt.t =
    TextBuffer.fold_string t.text (fun s ->
        let index' =
          t.cursor.index + amt |> max 0 |> min (String.length s)
        in
        t.cursor <-
          TextLayout.cursor
            ~last_col:
              (index' - Str.search_backward (Str.regexp "^") s index')
            index')

  let add_bindings (t : t) (ui : Ui.t) : unit Lwt.t =
    let open GLFW in
    let open Event in
    let open Ui in
    ui.bindings <-
      empty
      |> adds
           [
             [ Key (Press, F, [ Control ]) ];
             [ Key (Press, Right, []) ];
           ]
           [ Custom (fun () -> cursor_move t 1) ]
      |> adds
           [
             [ Key (Press, B, [ Control ]) ];
             [ Key (Press, Left, []) ];
           ]
           [ Custom (fun () -> cursor_move t (-1)) ]
      |> adds
           [
             [ Key (Press, N, [ Control ]) ];
             [ Key (Press, 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
                     (* F.epr
                        "Down: index=%d last_col=%d eol=%d eol'=%d \
                         bol=%d @."
                         t.cursor.index last_col  eol' bol; *)
                     t.cursor <-
                       {
                         t.cursor with
                         index =
                           (next_bol
                           +
                           if t.cursor.last_col > next_line_len then
                             next_line_len
                           else min next_line_len t.cursor.last_col);
                       }));
           ]
      |> adds
           [
             [ Key (Press, P, [ Control ]) ]; [ Key (Press, 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;
                       t.cursor <-
                         {
                           t.cursor with
                           index =
                             (prev_bol
                             +
                             if t.cursor.last_col > prev_line_len then
                               prev_line_len
                             else min prev_line_len t.cursor.last_col
                             );
                         })));
           ]
      |> 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, []) ] ]
           [
             Custom
               (fun () ->
                 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);
           ];

    (* 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.text_format_default)
      (text : TextBuffer.t) : t =
    let t =
      {
        text;
        cursor = TextLayout.cursor 0;
        id = None;
        id_source = None;
        text_format;
        layouter = 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 (add_bindings t ui);
    t

  (*
  let show_content (t : t) (ui : Ui.t) : output =
    let state = load_state (Option.value ~default:(-1) t.id) in
    Lwt_main.run (add_bindings t ui state);
    let origin = Ui.cursor_origin ui in
    (* TODO .or(ui.visuals().override_text_color) *)
    (* let row_height = (Gv.Text.metrics ui.gv).line_height in *)
    let available_width =
      Ui.available_width ui -. (t.margin.left +. t.margin.right)
    in
    let desired_width =
      Option.fold ~none:(Ui.spacing ui).text_edit_width ~some:Fun.id
        t.desired_width
    in
    let wrap_width =
      if Layout.horizontal_justify ui.placer.layout then
        available_width
      else Float.min desired_width available_width
    in
    let galley_size = galley.mesh_bounds in
    let desired_width =
      if t.clip_text then wrap_width
      else Float.max (Size2.w (Box2.size galley_size)) wrap_width
    in
    let desired_inner_size =
      V2.v desired_width (Box2.maxy galley_size)
    in
    let desired_outer_size =
      V2.(desired_inner_size + Margin.sum t.margin)
    in
    let (_auto_id, outer_rect) : id * box2 =
      Ui.allocate_space ui.gv (Box2.v origin desired_outer_size)
    in
    let rect = Margin.inner t.margin outer_rect in
    (* TODO id = ui.make_persistent_id(id_source) else auto_id *)
    (* TODO state = TextEditState::load(ui.ctx(), id)... *)
    (* TODO moved up let state = load_state (Option.value ~default:(-1) t.id) in *)
    (* TODO allow_drag_to_select = ... *)
    let _sense = if t.interactive then Sense.click else Sense.hover in

    (* let response = Ui.interact ui outer_rect t.id sense in *)
    (* TODO *)
    let text_clip_rect = rect in
    (*    let painter = Ui.painter_at ui text_clip_rect in *)
    let cursor_range = None in
    (* TODO cursor_range *)
    let galley_pos =
      Align.size_within_rect (Box2.size galley_size) rect
    in

    (*    if Ui.is_rect_visible ui rect then  *)
    (* Painter.galley ui.gv galley; *)
    let _align_offset = rect in
    {
      galley;
      galley_pos = Box2.o galley_pos;
      text_clip_rect;
      state;
      cursor_range;
    }
  let show (t : t) ui : output =
    let _margin = t.margin in
    let output = show_content t ui in
    (*    let _outer_rect = output.response.rect in *)
    output
     *)
end

module Layout = struct
  open Gg

  type frame = { t : t; mutable size : size }

  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 p2 | `Percent (* of container *) of p2 | `Auto ]

  let frame ?(size = `Auto) t : frame = { t; size }
  let box d t = frame (`Box (d, t))
  let hbox, vbox, zbox = (box `H, box `V, box `Z)

  let pp_t_frame ppf f =
    F.pf ppf "%s"
      (match f with
      | `Hbox -> "`Hbox"
      | `Vbox -> "`Vbox"
      | `Buffer -> "`Buffer"
      | `TextEdit -> "`TextEdit"
      | `S s -> F.str "%s" s
      | `None -> "`None")

  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 paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 Lwt.t =
    (* F.epr
         "Painter.galley (String.length g.job.text)=%d (Array.length \
          g.rows)=%d @."
         (Lwt_main.run (TextBuffer.length g.job.text))
         (Array.length g.rows);
       F.epr "g.job=%a@." TextLayout.pp_layout_job g.job;
         F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows; *)
    TextBuffer.contents g.job.text >>= fun contents ->
    let contents_len = String.length contents in
    g.rows
    |> Array.fold_left
         (fun (br : box2) (row : TextLayout.row) ->
           let sections =
             List.filter
               (fun (r : TextLayout.layout_section) ->
                 fst r.byte_range <= row.text_row.end_index
                 && snd r.byte_range > row.text_row.start_index)
               (Array.to_list
               @@ Array.sub g.job.sections row.section_index_at_start
                    (Array.length g.job.sections
                    - row.section_index_at_start))
           in
           assert (List.length sections > 0);

           ignore
             (List.fold_left
                (fun x (sec : TextLayout.layout_section) ->
                  let start, end_ =
                    ( min (contents_len - 1)
                        (max 0
                           (max (fst sec.byte_range)
                              row.text_row.start_index)),
                      min (contents_len - 1)
                        (max 0
                           (min (snd sec.byte_range)
                              row.text_row.end_index)) )
                  in

                  let font_name, font_size =
                    match sec.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 metrics = Gv.Text.metrics t in
                  let bounds =
                    Gv.Text.bounds t ~x ~y:0. ~start ~end_ contents
                  in
                  Path.begin_ t;
                  Path.rect t ~x ~y:(Box2.miny row.rect)
                    ~w:bounds.advance ~h:metrics.line_height;
                  set_fill_color t ~color:sec.format.background;
                  fill t;

                  set_fill_color t ~color:sec.format.color;
                  Text.text_w t ~x ~y:(Box2.miny row.rect) ~start
                    ~end_ contents)
                (Box2.minx row.rect) sections);
           Box2.(union br row.rect))
         Box2.empty
    |> Lwt.return

  let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t
      =
    match frame.t with
    | `Box (dir, ll) ->
        Lwt_list.fold_left_s
          (fun (o : box2) f ->
            layout
              (match dir with
              | `H ->
                  Box2.of_pts
                    V2.(v (Box2.minx o) (Box2.miny box))
                    (Box2.br_pt o)
              | `V ->
                  Box2.of_pts
                    V2.(v (Box2.minx box) (Box2.miny o))
                    (Box2.br_pt o)
              | `Z -> box)
              ui f)
          box ll
    | `TextEdit t ->
        let font =
          match Gv.Text.find_font ui.gv ~name:"mono" with
          | Some gv -> Fonts.{ gv; pixels_per_point = 1.0 }
          | None -> failwith "can't find font 'mono'"
        in
        (if t.multiline then
           TextLayout.simple t.text ~format:t.text_format
             (Option.value ~default:(Box2.w box) t.desired_width)
         else TextLayout.singleline t.text t.text_format)
        >>= fun layout_job ->
        Ui.fonts ui.gv (fun f ->
            TextLayout.layout f font
              (TextLayout.with_cursor t.cursor layout_job)
              (Box2.o box))
        >>= fun galley -> paint_galley ui.gv galley
    | _ -> Lwt.return box
end