oplevel/ogui.ml

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

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 =
    | Tree of {
        mutable path : string list;
        mutable tree : Store.S.tree;
        repo : Store.Sync.db;
      }
    | Buffer of { name : string; buf : Buffer.t }

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

  let buffer ~name ~buf = Buffer { name; buf }

  let insert_uchar t n uc : t Lwt.t =
    F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;
    match t with
    | Tree ({ 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 (Tree { tt with tree })
    | Buffer { buf; _ } as b ->
        let textend = Buffer.sub buf n (Buffer.length buf - n) in
        Buffer.truncate buf n;
        Buffer.add_utf_8_uchar buf uc;
        Buffer.add_string buf textend;
        Lwt.return b

  let contents = function
    | Tree { 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
    | Buffer { buf; _ } -> Lwt.return (Buffer.contents buf)

  let length = function
    | Tree { path; tree; _ } ->
        Store.S.Tree.get tree path >>= fun text ->
        Lwt.return (String.length text)
    | Buffer { buf; _ } -> Lwt.return @@ Buffer.length buf
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 Context = struct
  type t = { derp : bool }
end

module Response = struct
  type t = {
    ctx : Context.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 -> Lwt_main.run (TextBuffer.length s.text))
            int;
          field "sections"
            (fun s -> s.sections)
            (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 default_layout_job () =
    {
      text =
        TextBuffer.buffer ~name:"default_layout_job"
          ~buf:(Buffer.create 32);
      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;
    prefer_next_row : bool;
  }

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

  type cursor_range = cursor * cursor
  type cursor_state = cursor_range option

  let cursor_index = ref 0
  let cursor_range c = ((fst c).index, (snd c).index)

  let new_cursor ?(loc = 0) () : cursor =
    cursor_index := !cursor_index + 1;
    { index = loc; row = None; prefer_next_row = false }

  let new_cursor_range (s, e) : cursor_range =
    ( { cursor_default with index = s },
      { cursor_default with index = e } )

  let cursor_state_update ~(f : int -> int -> int * int)
      (c : cursor_state) : cursor_state =
    match c with
    | Some (a, b) ->
        let a', b' = f a.index b.index in
        F.epr "cursor_state_update %d %d@." a' b';
        Some (new_cursor_range (max a' 0, max b' 0))
    | None -> None

  let layout_job text ?(format = text_format_default) wrap_width :
      layout_job =
    {
      (default_layout_job ()) with
      text;
      sections =
        Array.make 1
          {
            leading_space = 0.0;
            byte_range = (0, Lwt_main.run (TextBuffer.length text));
            format;
          };
      wrap =
        { (default_text_wrapping ()) with max_width = wrap_width };
      break_on_newline = true;
    }

  let simple (text : TextBuffer.t) (format : text_format) wrap_width :
      layout_job =
    {
      (default_layout_job ()) with
      text;
      sections =
        Array.make 1
          {
            leading_space = 0.0;
            byte_range = (0, Lwt_main.run (TextBuffer.length text));
            format;
          };
      wrap =
        { (default_text_wrapping ()) with max_width = wrap_width };
      break_on_newline = true;
    }

  let simple_singleline (text : TextBuffer.t) (format : text_format) :
      layout_job =
    {
      (default_layout_job ()) with
      text;
      sections =
        Array.make 1
          {
            leading_space = 0.0;
            byte_range = (0, Lwt_main.run (TextBuffer.length text));
            format;
          };
      wrap = default_text_wrapping ();
      break_on_newline = true;
    }

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

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

  let with_cursor (cur : cursor_range)
      ?(cursor_format = default_cursor_formatter) layout_job :
      layout_job =
    let cs, ce = ((fst cur).index, (snd cur).index) 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

               if e < cs || ce < s then l @ [ sec ]
               else
                 l
                 @ (if s = cs then
                      [
                        {
                          sec with
                          byte_range = (s, if ce > e then e else ce);
                          format = cursor_format sec.format;
                        };
                      ]
                    else if s < cs && cs <= e then
                      (* cursor start in section *)
                      [
                        { sec with byte_range = (s, cs) };
                        {
                          sec with
                          byte_range = (cs, if ce > e then e else ce);
                          format = cursor_format sec.format;
                        };
                      ]
                    else if cs < s && e < ce then
                      [
                        { sec with format = cursor_format sec.format };
                      ]
                    else [])
                 @
                 if ce > s && ce < e 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 =
    (* 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
      {
        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
      let row_count =
        Gv.Text.break_lines gv ~break_width:job.wrap.max_width
          ~max_rows:job.wrap.max_rows ~lines
          (Lwt_main.run (TextBuffer.contents job.text))
      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
      {
        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 Painter = struct
  type t = Gv.t

  let galley (t : t) (g : TextLayout.galley) : unit =
    (* F.epr
         "Painter.galley (String.length g.job.text)=%d (Array.length \
          g.rows)=%d @."
         (String.length g.job.text)
         (Array.length g.rows);
       F.epr "g.rect=%a@." Gg.Box2.pp g.rect; *)

    (* F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows;*)
    Array.iter
      (fun (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
          Gg.(
            List.fold_left
              (fun x (sec : TextLayout.layout_section) ->
                let start, end_ =
                  ( min
                      (Lwt_main.run (TextBuffer.length g.job.text) - 1)
                      (max 0
                         (max (fst sec.byte_range)
                            row.text_row.start_index)),
                    min
                      (Lwt_main.run (TextBuffer.length g.job.text) - 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_
                    (Lwt_main.run (TextBuffer.contents g.job.text))
                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;
                let w =
                  Text.text_w t ~x ~y:(Box2.miny row.rect) ~start
                    ~end_
                    (Lwt_main.run (TextBuffer.contents g.job.text))
                in
                w)
              (Box2.minx row.rect) sections))
      g.rows
end

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 Layout = struct
  open Gg

  type direction = LeftToRight | RightToLeft | TopDown | BottomUp

  type t = {
    main_dir : direction;
    main_wrap : bool;
    main_align : align;
    main_justify : bool;
    cross_align : align;
    cross_justify : bool;
  }

  let horizontal =
    {
      main_dir = LeftToRight;
      main_wrap = true;
      main_align = Min;
      main_justify = true;
      cross_align = Min;
      cross_justify = true;
    }

  let vertical =
    {
      main_dir = TopDown;
      main_wrap = true;
      main_align = Min;
      main_justify = true;
      cross_align = Min;
      cross_justify = true;
    }

  type region = { min_rect : box2; max_rect : box2; cursor : box2 }

  let rec is_horizontal = function
    | `Direction d -> (
        match d with
        | LeftToRight | RightToLeft -> true
        | TopDown | BottomUp -> false)
    | `Layout t -> is_horizontal (`Direction t.main_dir)

  let available_from_cursor_max_rect t cursor max_rect : box2 =
    (* TODO assert !cursor.any_nan() *)
    (* TODO assert !max_rect.any_nan() *)
    (* TODO assert !max_rect.is_finite() *)
    let avail =
      match t.main_dir with
      | LeftToRight ->
          Box2.of_pts
            (V2.v (Box2.minx cursor) (Box2.miny max_rect))
            (V2.v
               Float.(
                 max
                   (max (Box2.maxx max_rect) (Box2.minx cursor))
                   (Box2.minx max_rect))
               Float.(max (Box2.maxy max_rect) (Box2.miny max_rect)))
      | RightToLeft -> Box2.zero (* TODO *)
      | TopDown | BottomUp -> Box2.zero
    in
    let avail = Box2.inter avail cursor in

    (* todo make sure it isn't negative (won't because Gg.maxx is maxing )*)
    avail

  let available_size t r =
    if t.main_wrap then
      if is_horizontal (`Direction t.main_dir) then
        V2.v (Box2.w r.max_rect) (Box2.h r.cursor)
      else V2.v (Box2.w r.cursor) (Box2.h r.max_rect)
    else
      Box2.size (available_from_cursor_max_rect t r.cursor r.max_rect)

  let horizontal_justify (l : t) =
    if is_horizontal (`Layout l) then l.main_justify
    else l.cross_justify

  module Grid = struct
    type state = {
      col_widths : Gg.size1 list;
      row_heights : Gg.size1 list;
    }

    type t = {
      id : id;
      is_first_frame : bool;
      prev_state : state;
      initial_available : Gg.size1 option;
      spacing : Gg.v2;
      min_cell_size : Gg.v2;
      max_cell_size : Gg.v2;
      col : int;
      row : int;
    }

    let available_rect _t _r = Gg.Box2.zero (*TODO*)
  end
end

module Placer = struct
  type t = {
    grid : Layout.Grid.t option;
    layout : Layout.t;
    region : Layout.region;
  }

  let available_size t =
    match t.grid with
    | Some grid ->
        Gg.Box2.size (Layout.Grid.available_rect grid t.region)
    | None -> Layout.available_size t.layout t.region

  let create layout region = { grid = None; layout; region }
end

module Ui = struct
  type t = {
    id : id;
    style : Style.t;
    placer : Placer.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 available_size ui = Placer.available_size ui.placer
  let available_width ui = Gg.P2.x (available_size ui)
  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 cursor_origin (ui : t) = Gg.Box2.o ui.placer.region.max_rect

  let window gv ?(window : GLFW.window option) rect : t =
    let id, rect = allocate_space gv rect in
    {
      id;
      style = Style.default;
      placer =
        Placer.create Layout.vertical
          Layout.{ min_rect = rect; max_rect = rect; cursor = rect };
      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) : unit =
    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);
    ignore
    @@ Lwt_main.run
         ((fun () : bool Lwt.t ->
            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_main.run @@ !chrcallback_ref @@ Uchar.of_int chr
end

module TextEdit = struct
  open Gg

  type t = {
    mutable text : TextBuffer.t;
    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 : Gg.v2;
    align : align;
    clip_text : bool;
    char_limit : int; (* return_key : keyboard_shortcut; *)
  }

  and state = {
    mutable cursor : TextLayout.cursor_state;
    (* undoer : undoer; *)
    singleline_offset : float;
    last_edit_time : float;
  }

  let state_mem : (int * state) list ref = ref []

  let add_bindings (t : t) (ui : Ui.t) (state : state) : 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 () ->
                 state.cursor <-
                   TextLayout.cursor_state_update
                     ~f:(fun a b -> (a + 1, b + 1))
                     state.cursor;
                 Lwt.return_unit);
           ]
      |> adds
           [
             [ Key (Press, B, [ Control ]) ];
             [ Key (Press, Left, []) ];
           ]
           [
             Custom
               (fun () ->
                 state.cursor <-
                   TextLayout.cursor_state_update
                     ~f:(fun a b -> (a - 1, b - 1))
                     state.cursor;
                 Lwt.return_unit);
           ]
      |> adds
           [
             [ Key (Press, N, [ Control ]) ];
             [ Key (Press, Down, []) ];
           ]
           [
             Custom
               (fun () ->
                 state.cursor <-
                   TextLayout.cursor_state_update
                     ~f:(fun a b -> (a - 1, b - 1))
                     state.cursor;
                 Lwt.return_unit);
           ]
      |> adds
           [
             [ Key (Press, P, [ Control ]) ]; [ Key (Press, Up, []) ];
           ]
           [
             Custom
               (fun () ->
                 state.cursor <-
                   TextLayout.cursor_state_update
                     ~f:(fun a b -> (a - 1, b - 1))
                     state.cursor;
                 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 ->
         match state.cursor with
         | Some (_a, b) ->
             TextBuffer.insert_uchar t.text b.index c >>= fun text ->
             t.text <- text;
             Lwt.return_unit
         | None -> Lwt.return_unit
       (* This creates a giant stack of calls lol
          >>= fun () -> !Ui.chrcallback_ref c *));
    Lwt.return_unit

  let load_state id =
    match List.assoc_opt id !state_mem with
    | Some state -> state
    | None ->
        let state =
          {
            cursor = Some (TextLayout.new_cursor_range (12, 13));
            singleline_offset = 0.0;
            last_edit_time = 0.0;
          }
        in
        state_mem := (id, state) :: !state_mem;
        state

  type output = {
    (*  response : Response.t; *)
    galley : TextLayout.galley;
    galley_pos : Gg.p2;
    text_clip_rect : Gg.box2;
    state : state;
    cursor_range : TextLayout.cursor_range option;
  }

  let multiline ?(text_format = TextLayout.text_format_default)
      (text : TextBuffer.t) : t =
    {
      text;
      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; *)
    }

  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 default_layouter (ui : Ui.t) (text : TextBuffer.t)
        (wrap_width : size1) : TextLayout.galley =
      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
      let layout_job =
        if t.multiline then
          TextLayout.simple text t.text_format wrap_width
        else TextLayout.simple_singleline text t.text_format
      in
      let layout_job =
        TextLayout.with_cursor
          (Option.value
             ~default:(TextLayout.new_cursor_range (0, 0))
             state.cursor)
          layout_job
      in
      Ui.fonts ui.gv (fun f ->
          TextLayout.layout f font layout_job origin)
    in

    let layouter =
      Option.value ~default:default_layouter t.layouter
    in
    let galley = layouter ui t.text wrap_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