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

let pp_box2 ppf b =
  F.(
    pf ppf "[%a %a]"
      (pair ~sep:(any " ") float float)
      Gg.(Box2.min b |> V2.to_tuple)
      (pair ~sep:(any " ") float float)
      Gg.(Box2.max b |> V2.to_tuple))

let pair a b = (a, b)

module Lwd = struct
  open Lwt_react

  type 'a var = 'a React.signal * (?step:React.step -> 'a -> unit)
  type 'a t = 'a React.signal

  let eq = Stdlib.( == )
  let var ?(eq = eq) (v : 'a) : 'a var = S.create ~eq v
  let get (s, _) : 'a t = s
  let peek (s, _) = S.value s
  let set ?step (_, f) v = f ?step v
  let pure = S.const
  let return = S.return
  let map ?(eq = eq) ~(f : 'a -> 'b) (a : 'a t) : 'b t = S.l1 ~eq f a

  let map2 ?(eq = eq) ~(f : 'a -> 'b -> 'c) (a : 'a t) (b : 'b t) :
      'c t =
    S.l2 ~eq f a b

  let map_s ?(eq = eq) ~(f : 'a -> 'b Lwt.t) (a : 'a t) : 'b t Lwt.t =
    S.l1_s ~eq f a

  let map2_s ?(eq = eq) ~(f : 'a -> 'b -> 'c Lwt.t) (a : 'a t)
      (b : 'b t) : 'c t Lwt.t =
    S.l2_s ~eq f a b

  let bind ?(eq = eq) (a : 'a t) ~(f : 'a -> 'b t) : 'b t =
    S.bind ~eq a f

  let join ?(eq = eq) : 'a t t -> 'a t = S.switch ~eq

  type 'a root = Root of 'a t

  let observe (t : 'a t) : 'a root = Root t
  let quick_sample = function Root t -> S.value t
end

module Lwd_utils = struct
  (* stolen from Lwd_utils *)
  type 'a monoid = 'a * ('a -> 'a -> 'a)

  let lift_monoid (zero, plus) = (Lwd.return zero, Lwd.map2 ~f:plus)

  let map_reduce inj (zero, plus) items =
    let rec cons_monoid c xs v =
      match xs with
      | (c', v') :: xs when c = c' ->
          cons_monoid (c + 1) xs (plus v' v)
      | xs -> (c, v) :: xs
    in
    let cons_monoid xs v = cons_monoid 0 xs (inj v) in
    match List.fold_left cons_monoid [] items with
    | [] -> zero
    | (_, x) :: xs ->
        List.fold_left (fun acc (_, v) -> plus v acc) x xs

  let reduce monoid items = map_reduce (fun x -> x) monoid items

  let rec cons_lwd_monoid plus c xs v =
    match xs with
    | (c', v') :: xs when c = c' ->
        cons_lwd_monoid plus (c + 1) xs (Lwd.map2 ~f:plus v' v)
    | xs -> (c, v) :: xs

  let pack (zero, plus) items =
    match List.fold_left (cons_lwd_monoid plus 0) [] items with
    | [] -> Lwd.return zero
    | (_, x) :: xs ->
        List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs
end

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

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 =
 fun ppf s -> F.pf ppf "r:%.3f g:%.3f b:%.3f a:%.3f" s.r s.g s.b s.a
(*F.(
  hbox
  @@ record ~sep:sp
       [
         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;
       ]) *)

(* let lwt_lwd (t : 'a Lwt.t Lwd.t) : 'a Lwd.t Lwt.t =
   let root = Lwd.observe t in
   Lwd.quick_sample root >>= fun root' ->
   let var = Lwd.var root' in
   Lwd.set_on_invalidate root (fun _t' ->
       Lwt.async (fun () ->
           Lwd.quick_sample root >>= fun root' ->
           Lwt.return @@ Lwd.set var root'));
    Lwt.return (Lwd.get var) *)

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.(
      of_pts
        (V2.v (minx b +. t.left) (miny b +. t.top))
        (V2.v (maxx b -. t.right) (maxy b -. t.bottom)))

  let outer t b =
    Box2.(
      of_pts
        (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=%.2f@;r=%.2f@;t=%.2f@;b=%.2f" 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 TextBuffer = struct
  let tree_eq (a : Store.S.tree) b =
    F.epr "tree_eq (a=%s) (b=%s) @."
      Store.(S.Tree.hash a |> S.Git.Hash.to_hex)
      Store.(S.Tree.hash b |> S.Git.Hash.to_hex);
    Store.(S.Git.Hash.equal (S.Tree.hash a) (S.Tree.hash b))

  type t = {
    path : string list Lwd.var;
    tree : Store.S.tree Lwd.var;
    repo : Store.Sync.db Lwt.t;
  }

  let of_repo ~(initial_path : string list)
      ~(repo : Store.Sync.db Lwt.t) : t Lwt.t =
    repo >>= Store.S.tree >>= fun tree ->
    Lwt.return
      {
        path = Lwd.var initial_path;
        tree = Lwd.var ~eq:tree_eq tree;
        repo;
      }

  let of_string ~path ?(repo : Store.Sync.db Lwt.t option) str =
    {
      path = Lwd.var path;
      tree = Lwd.var ~eq:tree_eq @@ 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 { path; tree; _ } n uc : unit Lwt.t =
    F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;
    let ucbuf = Bytes.create 8 in
    let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in
    Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function
      | Some src ->
          let sn = String.length src in
          assert (n <= sn);
          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 ->
          F.epr "TextBuffer.insert_uchar Tree.update -> Nonep@.";
          Some (String.sub (Bytes.to_string ucbuf) 0 uclen))
    >>= fun t ->
    F.epr "TextBuffer.insert_uchar Tree.update @.";
    Lwd.set tree t;
    F.epr "TextBuffer.insert_uchar Lwd.set tree @.";
    Lwt.return_unit

  let insert { path; tree; _ } n str =
    Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function
      | Some src ->
          let srcn = String.length src in
          assert (n <= srcn);
          Some
            String.(
              cat (cat (sub src 0 n) str) (sub src n (srcn - n)))
      | None ->
          F.epr "TextBuffer.insert Tree.update -> None@.";
          Some str)
    >>= fun t ->
    Lwd.set tree t;
    Lwt.return_unit

  let remove { path; tree; _ } (a, b) : unit Lwt.t =
    let a, b = (min a b, max a b) in
    (* F.epr "TextBuffer.remove (%d, %d)@." a b; *)
    Store.S.Tree.update (Lwd.peek tree) (Lwd.peek 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 t ->
    Lwd.set tree t;
    Lwt.return_unit

  let remove_uchar { path; tree; _ } n : unit Lwt.t =
    (* F.epr "TextBuffer.remove_subset n=%d @." n; *)
    Store.S.Tree.update (Lwd.peek tree) (Lwd.peek 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)
      | None ->
          F.epr "TextBuffer.remove_uchar None";
          None)
    >>= fun t ->
    Lwd.set tree t;
    Lwt.return_unit

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

  let contents { path; tree; _ } : string Lwt.t =
    (try Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
     with e ->
       F.epr "TextBuffer.contents %s: %s"
         (String.concat "/" (Lwd.peek path))
         (match e with
         | Not_found -> "Not_found"
         | Invalid_argument a -> F.str "Invalid_argument %s" a
         | exc -> F.str "Exception: %s" (Printexc.to_string exc));
       Lwt.return "")
    >>= fun text -> Lwt.return text

  let get { tree; path; _ } =
    Lwd.map2_s (Lwd.get tree) (Lwd.get path) ~f:(fun tree path ->
        Store.S.Tree.get tree path)

  let peek { tree; path; _ } =
    Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)

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

  let save { path; tree; repo } =
    Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
    >>= fun contents ->
    repo >>= fun r ->
    Store.S.set
      ~info:
        Store.S.Info.(
          fun () ->
            v ~author:"me" ~message:"TextBuffer.save"
              (Unix.time () |> Int64.of_float))
      r (Lwd.peek path) contents
    >>= fun r ->
    (match r with
    | Ok () -> ()
    | Error (`Conflict s) ->
        F.epr "TextBuffer.save Error `Conflict %s@." s
    | Error (`Too_many_retries n) ->
        F.epr "TextBuffer.save Error `Too_many_retries %d@." n
    | Error (`Test_was _) ->
        F.epr "TextBuffer.save Error `Test_was %s@."
          "<not implemented>");
    Lwt.return_unit
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 ->
    match e with
    | Key (a, k, m) ->
        F.pf ppf "%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 "/" (Lwd.peek 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 20.;
    }

  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 = { index; last_col }

  let simple (text : TextBuffer.t) ?(start = Lwd.pure 0)
      ?(format = format_default) wrap_width : layout Lwd.t Lwt.t =
    TextBuffer.get text >>= fun str ->
    Lwd.map2 start str ~f:(fun start str ->
        {
          layout_default with
          text;
          sections =
            [ { byte_range = (start, String.length str); format } ];
          wrap =
            { (default_text_wrapping ()) with max_width = wrap_width };
        })
    |> Lwt.return

  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
            l
            @ (if e < cs || ce < s then [ sec ] else [])
            @ (if cs > s && cs <= e then
                 [ { sec with byte_range = (s, cs) } ]
               else [])
            @ (if cs <= e && ce >= s then
                 [
                   {
                     format = format sec.format;
                     byte_range = (max cs s, min ce e);
                   };
                 ]
               else [])
            @
            if ce > s && ce <= e then
              [ { sec with byte_range = (ce, e) } ]
            else [])
          [] layout.sections;
    }

  let with_cursor (cursor : cursor Lwd.t)
      ?(format = default_cursor_formatter) layout : layout Lwd.t =
    Lwd.map2 cursor layout ~f:(fun c l ->
        with_range (c.index, c.index + 1) ~format l)

  let with_mark (mark : int option Lwd.t) (cursor : cursor Lwd.t)
      ?(format = default_mark_formatter) layout : layout Lwd.t =
    Lwd.bind layout ~f:(fun l ->
        Lwd.map2 mark cursor ~f:(fun m c ->
            match m with
            | Some m' ->
                F.epr "TextLayout.with_mark inside Lwd.map@.";

                with_range ~format (min m' c.index, max m' c.index) l
            | None -> l))
end

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

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

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

  type event =
    [ `Key of Event.key_action * Event.key * Event.key_mod list
    | `Char of int ]

  let id = ref 0

  let window gv ?(window : GLFW.window option) rect : t =
    {
      rect = Lwd.var ~eq:Gg.Box2.equal rect;
      enabled = true;
      gv;
      glfw_window = window;
      bindings = Lwd.pure Event.[ pack Fun.id empty ];
    }

  let pp_action : action F.t =
   fun ppf -> function Custom (name, _) -> F.pf ppf "%s" name

  let pp_bindings : action list Event.t F.t =
   fun ppf p ->
    let open Event in
    fold
      (fun events action () ->
        F.pf ppf "%a: %a@."
          F.(list pp_action)
          action
          F.(brackets @@ list ~sep:semi pp_event)
          events
        |> ignore)
      p ()

  let pp_pack : action list Event.pack F.t =
   fun ppf p ->
    let open Event in
    let rec iter (prev : Event.event list)
        (p : action list Event.pack) : unit =
      let module Pack = (val p) in
      match EventMap.bindings Pack.set with
      | (event, node) :: rest ->
          (match node with
          | Set set -> iter (prev @ [ event ]) (pack Pack.map set)
          | Val action ->
              F.pf ppf "%a: %a@."
                F.(list pp_action)
                (Pack.map action)
                F.(brackets @@ list ~sep:semi pp_event)
                (prev @ [ event ]));
          iter prev (pack Pack.map (EventMap.of_list rest))
      | [] -> ()
    in

    iter [] p

  let process_key t (resolver : action list Event.result)
      (state : Event.key_action) (key : Event.key)
      (mods : Event.key_mod list) : action list Event.result Lwt.t =
    let res =
      match resolver with
      | Event.Rejected | Event.Accepted _ ->
          t.bindings |> Lwd.observe |> Lwd.quick_sample
      | Event.Continue r -> r
    in
    let res = Event.resolve (Key (state, key, mods)) res in
    (match res with
    | Event.Accepted actions ->
        let rec exec : action list -> unit Lwt.t = function
          | Custom (_name, f) :: actions ->
              f () >>= fun () -> exec actions
          | [] -> Lwt.return_unit
        in
        exec actions >>= fun () -> Lwt.return_unit
    | Event.Continue _ | Event.Rejected -> Lwt.return_unit)
    >>= fun () -> Lwt.return res

  let append_bindings ui (b : action list Event.resolver Lwd.t) : unit
      =
    ui.bindings <- Lwd.map2 ~f:List.append ui.bindings b

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

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

  let process_events (ui : t) (events : event Lwt_stream.t) : unit =
    Lwt.async (fun () ->
        let rec proc (r : action list Event.result) :
            action list Event.result Lwt.t =
          Lwt_stream.last_new events >>= function
          | `Key (state, key, mods) ->
              process_key ui r state key mods
              >>= fun (res : action list Event.result) ->
              Event.(
                F.epr "Ui.process_events `Key %a %a %a (%s)@."
                  pp_key_action state pp_key key pp_mods mods
                  (match res with
                  | Accepted _ -> "Accepted"
                  | Continue _ -> "Continue"
                  | Rejected -> "Rejected"));

              (* junk the `Char that is sent with a `Key that has no mods *)
              (match res with
              | Accepted _ when mods = [] || mods == [ Shift ] -> (
                  Lwt_stream.peek events >>= function
                  | Some (`Char _) ->
                      F.epr "process_events: junking next event@.";
                      Lwt_stream.junk events
                  | _ -> Lwt.return_unit)
              | Accepted _ | Continue _ | Rejected -> Lwt.return_unit)
              >>= fun () -> proc res
          | `Char char ->
              F.epr "Ui.process_events `Char '%a'@." pp_uchar
                (Uchar.of_int char);
              process_char char >>= fun () -> proc (Event.Accepted [])
        in
        proc Event.Rejected >>= fun _ -> Lwt.return_unit)

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

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

    let pp ppf t =
      F.pf ppf "%a"
        F.(
          hovbox
          @@ record
               [
                 field "stroke"
                   (fun t -> t.stroke)
                   (pair ~sep:comma float pp_color
                   |> option ~none:(any "None")
                   |> hbox);
                 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 = {
    text : TextBuffer.t;
    cursor : TextLayout.cursor Lwd.var;
    mark : int option Lwd.var;
    scroll : int Lwd.var;
    rows : int Lwd.var;
    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 ->
        let c = Lwd.peek t.cursor in
        c.index - Str.search_backward (Str.regexp "^") s c.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 cursor = Lwd.peek cursor in
        let rows = Lwd.peek rows in
        let slen = String.length s in
        if cursor.index < Lwd.peek scroll then
          match
            String.rindex_from_opt s
              (min (slen - 1) (cursor.index - 1))
              '\n'
          with
          | Some i' -> Lwd.set t.scroll (i' + 1)
          | None -> Lwd.set t.scroll 0
        else
          match index_rows_from s (Lwd.peek scroll) rows with
          | None -> ()
          | Some eow -> (
              if cursor.index >= eow then
                match
                  rindex_rows_from s
                    (min (slen - 1) cursor.index)
                    rows
                with
                | None -> ()
                | Some i' -> Lwd.set t.scroll i'))

  let cursor_update (t : t) (f : int -> int) : unit Lwt.t =
    col t >>= fun last_col ->
    TextBuffer.fold_string t.text (fun s ->
        Lwd.set t.cursor
          (TextLayout.cursor ~last_col
             (f (Lwd.peek 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.action list Event.pack =
    let open GLFW in
    let open Event in
    let open Ui in
    (Ui.chrcallback_ref :=
       fun c ->
         TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
         >>= fun _ -> cursor_move t 1);
    empty
    |> adds
         [
           [ Key (Press, F, [ Control ]) ];
           [ Key (Repeat, F, [ Control ]) ];
           [ Key (Press, Right, []) ];
           [ Key (Repeat, Right, []) ];
         ]
         [ Custom ("char_forward", fun () -> cursor_move t 1) ]
    |> adds
         [
           [ Key (Press, B, [ Control ]) ];
           [ Key (Repeat, B, [ Control ]) ];
           [ Key (Press, Left, []) ];
           [ Key (Repeat, Left, []) ];
         ]
         [ Custom ("char_backward", fun () -> cursor_move t (-1)) ]
    |> adds
         [
           [ Key (Press, N, [ Control ]) ];
           [ Key (Repeat, N, [ Control ]) ];
           [ Key (Press, Down, []) ];
           [ Key (Repeat, Down, []) ];
         ]
         [
           Custom
             ( "forward_line",
               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 (Lwd.peek t.cursor).index + 1)
                     in
                     let next_line_len = seol s next_bol - next_bol in
                     next_bol
                     +
                     if (Lwd.peek t.cursor).last_col > next_line_len
                     then next_line_len
                     else
                       min next_line_len (Lwd.peek t.cursor).last_col)
                 >>= cursor_set t );
         ]
    |> adds
         [
           [ Key (Press, P, [ Control ]) ];
           [ Key (Repeat, P, [ Control ]) ];
           [ Key (Press, Up, []) ];
           [ Key (Repeat, Up, []) ];
         ]
         [
           Custom
             ( "line_backward",
               fun () ->
                 TextBuffer.fold_string t.text (fun s ->
                     let sbol =
                       Str.search_backward (Str.regexp "^") s
                     in
                     let bol = sbol (Lwd.peek 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 (Lwd.peek t.cursor).last_col > prev_line_len
                       then prev_line_len
                       else
                         min prev_line_len
                           (Lwd.peek t.cursor).last_col
                     else (Lwd.peek t.cursor).index)
                 >>= cursor_set t );
         ]
    |> adds (* EOL *)
         [ [ Key (Press, E, [ Control ]) ]; [ Key (Press, End, []) ] ]
         [
           Custom
             ( "end_of_line",
               fun () ->
                 TextBuffer.fold_string t.text (fun s ->
                     let bol =
                       Str.search_backward (Str.regexp "^") s
                         (Lwd.peek t.cursor).index
                     in
                     let eol =
                       Str.search_forward (Str.regexp "$") s
                         (Lwd.peek t.cursor).index
                     in
                     Lwd.set t.cursor
                     @@ TextLayout.cursor ~last_col:(eol - bol) eol)
             );
         ]
    |> adds (* BOL *)
         [
           [ Key (Press, A, [ Control ]) ]; [ Key (Press, Home, []) ];
         ]
         [
           Custom
             ( "beginning_of_line",
               fun () ->
                 TextBuffer.fold_string t.text (fun s ->
                     Lwd.set t.cursor
                     @@ TextLayout.cursor ~last_col:0
                          (Str.search_backward (Str.regexp "^") s
                             (Lwd.peek t.cursor).index)) );
         ]
    |> adds
         [
           [ Key (Press, Backspace, []) ];
           [ Key (Repeat, Backspace, []) ];
         ]
         [
           Custom
             ( "delete_char_backward",
               fun () ->
                 match Lwd.peek t.mark with
                 | Some mark ->
                     TextBuffer.remove t.text
                       (mark, (Lwd.peek t.cursor).index)
                     >>= fun _ ->
                     Lwd.set t.mark None;
                     cursor_set t (min mark (Lwd.peek t.cursor).index)
                 | None ->
                     if (Lwd.peek t.cursor).index > 0 then
                       TextBuffer.remove_uchar t.text
                         ((Lwd.peek t.cursor).index - 1)
                       >>= fun _ -> cursor_move t (-1)
                     else Lwt.return_unit );
         ]
    |> adds
         [ [ Key (Press, K, [ Control ]) ] ]
         [
           Custom
             ( "line_kill",
               fun () ->
                 TextBuffer.fold_string t.text (fun s ->
                     TextBuffer.remove t.text
                       ( (Lwd.peek t.cursor).index,
                         let eol =
                           Str.search_forward (Str.regexp "$") s
                             (Lwd.peek t.cursor).index
                         in
                         if
                           eol == (Lwd.peek t.cursor).index
                           && String.length s > eol
                         then eol + 1
                         else eol )
                     >>= fun _ ->
                     Lwd.set t.mark None;
                     cursor_set t (Lwd.peek t.cursor).index)
                 >>= fun u -> u );
         ]
    |> adds
         [ [ Key (Press, Enter, []) ]; [ Key (Repeat, Enter, []) ] ]
         [
           Custom
             ( "new_line",
               fun () ->
                 TextBuffer.insert_uchar t.text
                   (Lwd.peek t.cursor).index (Uchar.of_char '\n')
                 >>= fun _ -> cursor_move t 1 );
         ]
    |> adds
         [ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
         [
           Custom
             ( "mark_toggle",
               fun () ->
                 Lwd.set t.mark
                   (match Lwd.peek t.mark with
                   | Some _ -> None
                   | None -> Some (Lwd.peek t.cursor).index);
                 Lwt.return_unit );
         ]
    |> adds
         [ [ Key (Press, G, [ Control ]) ] ] (* Exit / Clear *)
         [
           Custom
             ( "command_clear",
               fun () ->
                 Lwd.set t.mark None;
                 Lwt.return_unit );
         ]
    |> adds
         [
           [
             Key (Press, X, [ Control ]); Key (Press, S, [ Control ]);
           ];
         ]
         (* Save *)
         [ Custom ("save_buffer", fun () -> TextBuffer.save t.text) ]
    |> Event.pack Fun.id

  let multiline ui ?(text_format = TextLayout.format_default)
      (text : TextBuffer.t) : t =
    let t =
      {
        text;
        cursor = Lwd.var (TextLayout.cursor 0);
        mark = Lwd.var None;
        scroll = Lwd.var 0;
        rows = Lwd.var 0;
        text_format;
        formatter = None;
        password = false;
        frame = true;
        margin = Margin.symmetric 4.0 4.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
    Ui.append_bindings ui (Lwd.pure [ default_bindings t ]);
    t
end

module Layout = struct
  module Style = Ui.Style

  type dir = [ `X | `Y | `Z ]

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

  and t =
    [ `Join of dir * (frame * frame)
    | `String of string * TextLayout.format
    | `Buffer of TextBuffer.t * TextLayout.format
    | `TextEdit of TextEdit.t * TextLayout.layout
    | `None ]

  and dim =
    [ `Ratio of float | `Pixels of float | `Fun of Gg.box2 -> float ]

  and size = dim * dim

  let ratio x y = (`Ratio x, `Ratio y)
  let pixels x y = (`Pixels (Int.of_float x), `Pixels (Int.of_float y))

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

  let none = frame `None
  let join ?size ?style d a b = frame ?size ?style (`Join (d, (a, b)))

  (*  let hbox, vbox, zbox = (box `X, box `Y, box `Z) *)
  let pack ?style d = (none, join d ?style)
  let pack_x ?style () = pack `X ?style
  let pack_y ?style () = pack `Y ?style
  let pack_z ?style () = pack `Z ?style
  let cat ?style d = Lwd_utils.reduce (pack ?style d)
  let hcat ?style = cat ?style `X
  let vcat ?style = Lwd_utils.reduce (pack_y ?style ())
  let zcat ?style = Lwd_utils.reduce (pack_z ?style ())
  let box ?style d = Lwd_utils.pack (pack ?style d)
  let hbox, vbox, zbox = (box `X, box `Y, box `Z)

  let textedit_style =
    Style.
      {
        fill = Gv.Color.rgbaf ~r:0.1 ~g:0.1 ~b:0.1 ~a:0.0;
        stroke = Some (1.2, Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9);
        margin = Margin.symmetric 10. 10.;
      }

  let string ?size ?style s = frame ?size ?style (`String s)

  let textedit_s ?size ?(style = textedit_style)
      (t : TextEdit.t Lwd.t) : frame Lwd.t Lwt.t =
    let open TextLayout in
    F.epr "Layout.textedit@.";
    Lwd.map_s t ~f:(fun (t : TextEdit.t) ->
        simple t.text ~start:(Lwd.get t.scroll) ~format:t.text_format
          (Option.value ~default:80. t.desired_width)
        >>= fun layout ->
        with_cursor (Lwd.get t.cursor) layout
        |> with_mark (Lwd.get t.mark) (Lwd.get t.cursor)
        |> Lwd.map ~f:(fun tl ->
               frame ?size ~style (`TextEdit (t, tl)))
        |> Lwt.return)
    >>= fun v -> Lwd.join v |> Lwt.return

  let textedit ?size ?(style = textedit_style) (t : TextEdit.t) :
      frame Lwd.t Lwt.t =
    let open TextLayout in
    F.epr "Layout.textedit@.";
    simple t.text ~start:(Lwd.get t.scroll) ~format:t.text_format
      (Option.value ~default:80. t.desired_width)
    >>= fun layout ->
    with_cursor (Lwd.get t.cursor) layout
    |> with_mark (Lwd.get t.mark) (Lwd.get t.cursor)
    |> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl)))
    |> Lwt.return

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

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

  let pp_dim ppf = function
    | `Pixels p -> F.pf ppf "%.2fpx" p
    | `Ratio p -> F.pf ppf "%.2f%%" p
    | `Fun _ -> F.pf ppf "`Fun _"

  let pp_size = F.pair ~sep:F.(any " ") pp_dim pp_dim

  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 rec pp_t_rec ppf (t : t) =
    let open Fmt in
    match t with
    | `Join (d, p) ->
        pf ppf "`Join %a (@,%a)" pp_dir d
          (pair ~sep:F.comma pp_frame_rec pp_frame_rec)
          p
    | `Buffer _ -> pf ppf "`Buffer"
    | `TextEdit _ -> pf ppf "`TextEdit"
    | `String (s, _) -> pf ppf "`String @[<h 1>%s@]" s
    | `None -> pf ppf "`None"

  and pp_frame_rec ppf t =
    F.pf ppf "@[<hv 3>[%a] %a@]" pp_size t.size pp_t_rec t.t

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

module WindowManager = struct
  open Layout

  type content = [ `TextEdit of TextEdit.t | `Frame of frame ]
  type bindings = Event.event Event.resolver

  type t = [ `T of dir * tt list | content ]
  and tt = { t : t; dim : dim; bindings : bindings }

  let rec length : t -> int = function
    | `T (_, tl) ->
        List.fold_left (fun a { t; _ } -> a + length t) 0 tl
    | _ -> 1

  let rec nth (n : int) : t -> content option = function
    | `T (_, tl) ->
        let rec nl n' : tt list -> content option = function
          | { t; _ } :: tl' -> (
              match nth n' t with
              | Some t -> Some t
              | None -> nl (n - 1) tl')
          | [] -> None
        in
        nl n tl
    | (`TextEdit _ | `Frame _) as t ->
        F.epr "nth: %d@." n;
        if n == 0 then Some t else None

  let rec fold_left ?(dir = `X)
      ~(f :
         dir ->
         'a ->
         [ `Frame of frame | `TextEdit of TextEdit.t ] ->
         'a) acc = function
    | `T (dir, tl) ->
        List.fold_left (fun a' t' -> fold_left ~f ~dir a' t') acc tl
    | (`Frame _ as tt) | (`TextEdit _ as tt) -> f dir acc tt

  let color_gray c = Gv.Color.rgbf ~r:c ~g:c ~b:c

  let status_style sel : Style.t =
    let open Ui.Style in
    {
      stroke =
        Some (3.0, if sel then color_gray 0.6 else color_gray 0.4);
      fill = (if sel then color_gray 0.8 else color_gray 0.2);
      margin = Margin.symmetric 2. 2.;
    }

  let status_format sel : TextLayout.format =
    {
      TextLayout.format_default with
      font_id = FontId ("mono", 18.0);
      line_height = Some 19.;
      color = (if sel then color_gray 0.1 else color_gray 0.9);
      background = Gv.Color.transparent;
    }

  let frame_of_window (n : int) cursor style (size : dim * dim)
      (content : frame Lwd.t) : frame Lwd.t =
    Lwd.map2 content (Lwd.get cursor) ~f:(fun content cursor ->
        join ~size
          ~style:
            {
              style with
              stroke =
                Option.map
                  (fun (s, c) ->
                    ( s,
                      if n != cursor then Gv.Color.(transf c 0.3)
                      else c ))
                  content.style.stroke;
            }
          `Y content
          (string
             ~style:(status_style (n == cursor))
             ~size:(`Ratio 1.0, `Pixels 30.)
             (F.str "window/%d" n, status_format (n == cursor))))

  let frame_default_bindings _ui _f = Event.empty |> Event.pack Fun.id

  let default_bindings ui = function
    | `TextEdit t -> [ TextEdit.default_bindings t ]
    | `Frame f -> [ frame_default_bindings ui f ]

  let make ui ?(style = textedit_style)
      ?(_mode : [ `Tiling | `FullScreen | `Floating ] = `Tiling)
      (t : t Lwd.var) =
    let cursor = Lwd.var 0 in
    (* add the bindings of the currently selected window *)
    Ui.append_bindings ui
      (Lwd.map2 (Lwd.get cursor) (Lwd.get t) ~f:nth
      |> Lwd.map ~f:(function
           | Some v -> default_bindings ui v
           | None -> []));
    Ui.append_bindings ui
      (Lwd.return
         Event.
           [
             empty
             |> adds
                  [
                    [
                      Key (Press, X, [ Control ]); Key (Press, O, []);
                    ];
                  ]
                  Lwd.
                    [
                      Ui.Custom
                        ( "window_next",
                          fun () ->
                            set cursor
                              (if peek cursor < (peek t |> length) - 1
                               then peek cursor + 1
                               else 0);
                            Lwt.return_unit );
                    ]
             |> adds
                  [
                    [
                      Key (Press, X, [ Control ]); Key (Press, P, []);
                    ];
                  ]
                  Lwd.
                    [
                      Ui.Custom
                        ( "window_previous",
                          fun () ->
                            set cursor
                              (if peek cursor > 0 then peek cursor - 1
                               else (peek t |> length) - 1);
                            Lwt.return_unit );
                    ]
             |> pack Fun.id;
           ]);
    let i = ref 0 in
    Lwd.map_s (Lwd.get t) ~f:(fun (t : t) ->
        let rec fold dir (t : tt) : Layout.frame Lwd.t Lwt.t =
          let size =
            match dir with
            | `X -> (t.dim, `Ratio 1.)
            | `Y -> (`Ratio 1., t.dim)
            | `Z -> (t.dim, t.dim)
          in
          match t.t with
          | `T (dir', t0 :: trest) ->
              fold dir' t0 >>= fun fst ->
              Lwt_list.fold_left_s
                (fun f t ->
                  fold dir' t >>= fun newf ->
                  Lwd.map2 f newf ~f:(join ~size dir') |> Lwt.return)
                fst trest
          | `T (_, []) -> Layout.none |> Lwd.return |> Lwt.return
          | `Frame f' ->
              i := !i + 1;
              frame_of_window !i cursor style size (Lwd.return f')
              |> Lwt.return
          | `TextEdit t' ->
              Layout.textedit
                ~size:(`Ratio 1.0, `Fun (fun b -> Gg.Box2.h b -. 30.))
                t'
              >>= fun tt ->
              i := !i + 1;
              frame_of_window !i cursor style size tt |> Lwt.return
        in
        fold `X { t; dim = `Ratio 1.; bindings = [] })
    >>= fun d -> Lwd.join d |> Lwt.return
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;

    (match style.stroke with
    | None -> ()
    | Some (width, color) ->
        set_stroke_width t ~width;
        set_stroke_color t ~color;
        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);
    set_fill_color t ~color:format.color

  let string ?(style = Style.default) (t : Gv.t) (rect : box2)
      ((contents, format) : string * TextLayout.format) : box2 Lwt.t =
    (*    draw_box t ~box:rect ~style; *)
    (* F.epr "string"; *)
    set_text_format t format;
    let rect' = Margin.inner style.margin rect in
    V2.v
      (Gv.Text.text_w t ~x:(Box2.minx rect') ~y:(Box2.miny rect')
         contents)
      (Gv.Text.metrics t).line_height
    |> Box2.v (Box2.o rect')
    |> Margin.outer style.margin
    |> Lwt.return

  let text_layout (t : Gv.t) (rect : box2)
      ((te, layout) : TextEdit.t * TextLayout.layout) : box2 Lwt.t =
    let g = layout in
    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) |> max 1
    in
    Lwd.set te.rows max_rows;
    let lines = Gv.Text.make_empty_rows max_rows in
    Store.S.Tree.get (Lwd.peek te.text.tree) (Lwd.peek te.text.path)
    >>= fun contents ->
    let row_count =
      Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows
        ~lines ~start:(Lwd.peek te.scroll) contents
    in
    Seq.fold_left
      (fun ((cur, start) : p2 * int) (row : Gv.Text.text_row) ->
        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_ =
              let contents_len = String.length contents in
              ( 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
            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)
              (P2.y cur'))
          P2.(v (Box2.minx rect) (y cur))
          sections
        |> fun cur'' ->
        ( V2.(v (max (x cur) (x cur'')) (y cur'' +. line_height)),
          row.next ))
      (Box2.o rect, Lwd.peek 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)
      ({ t; style; size = sx, sy } : frame) : box2 Lwt.t =
    let box =
      Box2.v (Box2.o box)
        (Size2.v
           (match sx with
           | `Ratio r -> Box2.w box *. r
           | `Pixels p -> p
           | `Fun f -> f box)
           (match sy with
           | `Ratio r -> Box2.h box *. r
           | `Pixels p -> p
           | `Fun f -> f box))
    in
    let box' = Margin.inner style.margin box in
    (* F.epr "@[<hv 3>%a " pp_box2 box; *)
    draw_box ui.gv ~box ~style;
    (match t with
    | `Join (dir, (a, b)) ->
        (* F.epr "`Join %a @,(@[<hv>" pp_dir dir; *)
        layout box' ui a >>= fun ra ->
        (* F.epr ",@ "; *)
        let c' =
          Box2.(
            match dir with
            | `X -> of_pts (V2.v (maxx ra) (miny box')) (max box')
            | `Y -> of_pts (V2.v (minx box') (maxy ra)) (max box')
            | `Z -> box')
        in
        layout c' ui b >>= fun rb ->
        (* F.epr "@])"; *)
        Gg.Box2.union ra rb |> Lwt.return
    | `TextEdit tt ->
        (* F.epr "`TextEdit"; *)
        text_layout ui.gv box' tt >>= fun _ -> Lwt.return box'
    | `None ->
        (* F.epr "`None"; *)
        Lwt.return Gg.Box2.(v (o box') Gg.V2.zero)
    | `String s -> string ui.gv box' s
    | _ ->
        F.epr "_ !!Unimplemented!!";
        Lwt.return Gg.Box2.zero)
    >>= fun r ->
    (* F.epr "@]"; *)
    let r' = Margin.outer style.margin r in

    (*F.epr "layout: box=%a box'=%a r=%a r'=%a@." Gg.Box2.pp box
      Gg.Box2.pp box' Gg.Box2.pp r Gg.Box2.pp r'; *)
    Lwt.return r'

  let layout box ui frame =
    (* F.epr "layout:@ @[%a@]@.as:@.@[<hv>" Layout.pp_frame_rec frame; *)
    let r = layout box ui frame in
    (* F.epr "@]@."; *)
    r
end