[@@@ocamlformat "disable"]
#use "topfind";;

#require "lwt";;
(* #list;; *)
[@@@ocamlformat "enable"]

module Store = struct
  open Lwt.Infix
  module F = Fmt
  module S = Irmin_git_unix.FS.KV (Irmin.Contents.String)
  module Sync = Irmin.Sync.Make (S)

  type t = S.tree
  type tree = t
  type step = S.step
  type path = step list

  let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
  let info = Irmin_git_unix.info

  let test_populate () : t Lwt.t =
    let add p s t = S.Tree.add t p s in
    add [ "hello" ] "world" (S.Tree.empty ())
    >>= add [ "hello"; "daddy" ] "ily"
    >>= add [ "beep"; "beep" ] "motherfucker"

  let init_default upstream_url : Sync.db Lwt.t =
    S.Repo.v (Irmin_git.Conf.init "../rootstore") >>= fun repo ->
    S.of_branch repo "lablgtk" >>= fun t ->
    S.remote upstream_url >>= fun upstream ->
    (* (try Sync.pull_exn t upstream `Set >>= fun _ -> Lwt.return_unit
        with Invalid_argument a ->
          F.epr "Sync.pull_exn raised Invalid_argument(%s)" a;
          Lwt.return_unit)
       >>= fun () -> *)
    Lwt.return t
end

module Ogui = struct
  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 }

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

  let pp_color : Gv.Color.t Fmt.t =
    F.(
      hbox
      @@ record ~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.v
        (V2.v (Box2.minx b +. t.left) (Box2.miny b +. t.top))
        (V2.v (Box2.maxx b -. t.right) (Box2.maxy b -. t.bottom))

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

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

  type margin = Margin.t

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

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

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

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

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

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

    let of_repo ~initial_path ~(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 tree; repo }

    let of_string ~path ?(repo : Store.Sync.db Lwt.t option) str =
      {
        path = Lwd.var path;
        tree = Lwd.var @@ 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 ->
      Lwd.set tree t;
      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 -> Nonep@.";
            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 (Lwd.get tree) (Lwd.get path) ~f:(fun tree path ->
          Store.S.Tree.get tree path)
      |> lwt_lwd

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

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

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

      let compare = compare
    end)

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

    let empty = EventMap.empty

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

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

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

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

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

    module type Pack = sig
      type a
      type b

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

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

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

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

    let resolver l = l

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

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

    let resolve event sets = resolve_rec event [] sets

    include Glfw_types

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

  type event = Event.event

  module Align = struct
    open Gg

    type range = size1 * size1

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

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

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

  type align = Align.t

  module Fonts = struct
    open Gg

    let pixels_per_point = ref 1.0

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

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

  module TextLayout = struct
    open Gg

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

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

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

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

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

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

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

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

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

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

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

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

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

    let pp_layout =
      F.(
        record
          [
            field "text"
              (fun s ->
                str "path=%s"
                  (String.concat "/" (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;
      bindings : action list Event.t Lwd.var;
    }

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

    let id = ref 0

    let window gv ?(window : GLFW.window option) rect : t =
      {
        rect;
        enabled = true;
        gv;
        glfw_window = window;
        bindings = Lwd.var 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 |> Lwd.get |> Lwd.observe
                 |> Lwd.quick_sample);
              ]
      in

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

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

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

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

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

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

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

  module TextEdit = struct
    open Gg

    type t = {
      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 : Ui.t) : unit =
      let open GLFW in
      let open Event in
      let open Ui in
      Ui.update_bindings ui (fun a ->
          a
          |> adds
               [
                 [ Key (Press, F, [ Control ]) ];
                 [ Key (Repeat, F, [ Control ]) ];
                 [ Key (Press, Right, []) ];
                 [ Key (Repeat, Right, []) ];
               ]
               [ Custom (fun () -> cursor_move t 1) ]
          |> adds
               [
                 [ Key (Press, B, [ Control ]) ];
                 [ Key (Repeat, B, [ Control ]) ];
                 [ Key (Press, Left, []) ];
                 [ Key (Repeat, Left, []) ];
               ]
               [ Custom (fun () -> cursor_move t (-1)) ]
          |> adds
               [
                 [ Key (Press, N, [ Control ]) ];
                 [ Key (Repeat, N, [ Control ]) ];
                 [ Key (Press, Down, []) ];
                 [ Key (Repeat, Down, []) ];
               ]
               [
                 Custom
                   (fun () ->
                     TextBuffer.fold_string t.text (fun s ->
                         let sn = String.length s in
                         let seol =
                           Str.search_forward (Str.regexp "$")
                         in
                         let next_bol =
                           min sn
                             (seol s (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
                   (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
                   (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
                   (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
                   (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
                   (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
                   (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
                   (fun () ->
                     Lwd.set t.mark
                       (match Lwd.peek t.mark with
                       | Some _ -> None
                       | None -> Some (Lwd.peek t.cursor).index);
                     Lwt.return_unit);
               ]);
      Ui.chrcallback_ref :=
        fun c ->
          TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
          >>= fun _ -> cursor_move t 1
    (* This creates a giant stack of calls lol
       >>= fun () -> !Ui.chrcallback_ref c *)

    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
      default_bindings t ui;
      t
  end

  module Layout = struct
    module Style = Ui.Style

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

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

    and dim = [ `Ratio of float | `Pixels of 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 d ?style a b = frame ?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.
        {
          default with
          stroke = (Some 1.2, Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9);
          margin = Margin.symmetric 10. 10.;
        }

    let textedit ?size ?(style = textedit_style) (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 tiling ui ?(style = textedit_style) d
        (telist : TextEdit.t list) =
      let cursor = Lwd.var 0 in
      let len = List.length telist in
      Ui.update_bindings ui (fun a ->
          a
          |> Event.adds
               [
                 (*[ Key (Press, X, [Control])];
                   [ Key (Release, X, [Control])];*)
                 [ Key (Press, O, [ Control ]) ];
               ]
               [
                 Ui.Custom
                   (fun () ->
                     Lwd.set cursor
                       (if Lwd.peek cursor < len - 1 then
                          Lwd.peek cursor + 1
                        else 0);
                     TextEdit.default_bindings
                       (List.nth telist (Lwd.peek cursor))
                       ui;
                     Lwt.return_unit);
               ]);
      let teln = List.length telist in
      let ratio n = `Ratio (1. /. float (teln - (n + 1))) in
      Lwt_list.mapi_s
        (fun n te ->
          textedit
            ~size:
              (match d with
              | `X -> (`Ratio 0.5, `Ratio 1.)
              | `Y -> (`Ratio 1., `Ratio 0.5)
              | `Z -> (`Ratio 1., `Ratio 1.))
            te
          >>= fun tl ->
          Lwd.map2 tl (Lwd.get cursor) ~f:(fun tl cursor ->
              {
                tl with
                style =
                  {
                    tl.style with
                    stroke =
                      ( fst style.stroke,
                        if n == cursor then
                          Gv.Color.(transf (snd style.stroke) 0.5)
                        else snd style.stroke );
                  };
              })
          |> Lwt.return)
        telist
      >>= fun framelist -> box ~style d framelist |> 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_size ppf (x, y) =
      (match x with
      | `Pixels p -> F.pf ppf "`Pixels %f.2, " p
      | `Ratio p -> F.pf ppf "`Ratio %f.2, " p);
      match y with
      | `Pixels p -> F.pf ppf "`Pixels %f.2" p
      | `Ratio p -> F.pf ppf "`Ratio %f.2" p

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

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

  module Painter = struct
    open Layout
    open Gg

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

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

    let text_layout (t : Gv.t) (rect : box2)
        ((te, 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) 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 contents_len = String.length contents in
      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_ =
                ( 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
      |> (fun cur''' -> V2.(cur''' - v 0. line_height))
      |> 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)
          (V2.v
             (match sx with
             | `Ratio r -> Box2.w box *. r
             | `Pixels p -> p)
             (match sy with
             | `Ratio r -> Box2.h box *. r
             | `Pixels p -> p))
      in
      let box' = Margin.inner style.margin box in
      (match t with
      | `Join (dir, (a, b)) ->
          Lwt_list.fold_left_s
            (fun (c : box2) f ->
              layout c ui f >>= fun r ->
              let c' =
                Box2.(
                  match dir with
                  | `X -> of_pts (V2.v (maxx r) (miny c)) (max c)
                  | `Y -> of_pts (V2.v (minx c) (maxy r)) (max c)
                  | `Z -> box)
              in
              Lwt.return c')
            box' [ a; b ]
      | `TextEdit tt -> text_layout ui.gv box' tt
      | _ -> Lwt.return box)
      >>= fun r ->
      let r' =
        Box2.add_pt r
          V2.(Box2.max r + v style.margin.right style.margin.bottom)
        |> Margin.outer style.margin
      in
      draw_box ui.gv ~box:r' ~style;
      Lwt.return r'
  end
end

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

module GLFWExtras = struct
  open Ctypes
  open Foreign

  let glfwSetErrorCallback :
      (int -> string -> unit) -> int -> string -> unit =
    let errorfun = int @-> string @-> returning void in
    foreign "glfwSetErrorCallback"
      (funptr errorfun @-> returning (funptr errorfun))
end

let errorcb error desc =
  Printf.printf "GLFW error %d: %s\n%!" error desc

let load_fonts vg =
  let _ = Gv.Text.create vg ~name:"mono" ~file:"./assets/mono.ttf" in
  let _ =
    Gv.Text.create vg ~name:"icons" ~file:"./assets/entypo.ttf"
  in
  let _ =
    Gv.Text.create vg ~name:"sans" ~file:"./assets/Roboto-Regular.ttf"
  in
  let _ =
    Gv.Text.create vg ~name:"sans-bold"
      ~file:"./assets/Roboto-Bold.ttf"
  in
  let _ =
    Gv.Text.create vg ~name:"emoji"
      ~file:"./assets/NotoEmoji-Regular.ttf"
  in
  Gv.Text.add_fallback vg ~name:"sans" ~fallback:"emoji";
  Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji";
  Gv.Text.set_font_face vg ~name:"mono"

let main =
  GLFW.init ();
  at_exit GLFW.terminate;
  let _res = GLFWExtras.glfwSetErrorCallback errorcb in
  GLFW.windowHint ~hint:GLFW.ClientApi ~value:GLFW.OpenGLESApi;
  GLFW.windowHint ~hint:GLFW.ContextVersionMajor ~value:2;
  GLFW.windowHint ~hint:GLFW.ContextVersionMinor ~value:0;

  let window =
    GLFW.createWindow ~width:1000 ~height:600 ~title:"window" ()
  in
  (* Make the window's context current *)
  GLFW.makeContextCurrent ~window:(Some window);
  GLFW.swapInterval ~interval:0;

  Gl.clear_color 0.1 0.2 0.2 1.;

  (*Memtrace.trace_if_requested (); *)
  let ctx =
    Gv.create ~flags:Gv.CreateFlags.(antialias lor stencil_strokes) ()
  in

  let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in
  let min_fps = ref Float.max_float in
  let max_fps = ref Float.min_float in

  (* Thread which is woken up when the main window is closed. *)
  let _waiter, _wakener = Lwt.wait () in

  (* F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
     Toploop.initialize_toplevel_env (); *)
  let rootrepo =
    Store.init_default
      (F.str "%s/console/rootstore.git" Secrets.giturl)
  in

  let ui =
    Ogui.Ui.window ctx ~window
      (Lwd.var Gg.(Box2.v P2.o (P2.v 500. 500.)))
  in

  load_fonts ui.gv;
  GLFW.setKeyCallback ~window
    ~f:
      (Some
         (fun _window key _int state mods ->
           Lwt.async (fun () ->
               Ogui.Ui.keycallback ui state key mods >>= fun _ ->
               Lwt.return_unit)))
  |> ignore;

  GLFW.setCharCallback ~window
    ~f:
      (Some
         (fun _window ch ->
           Lwt.async (fun () ->
               Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit)))
  |> ignore;

  GLFW.setWindowSizeCallback ~window
    ~f:
      (Some
         Gg.(
           fun _window x y ->
             Lwd.set ui.rect
               (Box2.v V2.zero (V2.v (float x) (float y)))))
  |> ignore;

  F.pr "oplevel.ml: building initial page@.";
  let initial_path = [ ".config"; "init.ml" ] in
  TextBuffer.of_repo ~initial_path ~repo:rootrepo >>= fun tb_init ->
  TextBuffer.of_string ~repo:rootrepo
    ~path:
      (List.fold_right
         (fun a (acc : string list) ->
           match acc with
           | [] -> [ F.str "%s.output" a ]
           | a' -> a :: a')
         [] initial_path)
    (F.str "(* --- output:%s --- *)\n\n"
       (String.concat "/" initial_path))
  |> Lwt.return
  >>= fun to_init ->
  let out_ppf =
    let insert s =
      Lwt.async (fun () ->
          TextBuffer.length to_init >>= fun len ->
          (* TKTK if buffer is modified here during yield from >>= it could be weird *)
          TextBuffer.insert to_init len s)
    in
    Format.formatter_of_out_functions
      Format.
        {
          out_string = (fun s _ _ -> insert s);
          out_flush = (fun () -> ());
          out_indent = (fun n -> insert (String.make (n * 2) ' '));
          out_newline = (fun () -> insert "\n");
          out_spaces = (fun n -> insert (String.make n ' '));
        }
  in

  (* toplevel execution binding *)
  Ui.(
    update_bindings ui
      Event.(
        fun a ->
          a
          |> adds
               [
                 [
                   Key (Press, X, [ Control ]);
                   Key (Release, X, [ Control ]);
                   Key (Press, E, [ Control ]);
                 ];
               ]
               [
                 Custom
                   (fun () ->
                     F.epr "Ctrl-X Ctrl-E@.";
                     TextBuffer.peek tb_init >>= fun str ->
                     Toploop.use_input out_ppf (String str)
                     |> F.epr "Toploop.use_input=%b@.";
                     Lwt.return_unit);
               ]));

  Layout.(
    tiling ui `Y
      ~style:
        Style.{ default with margin = Margin.symmetric 10.0 10.0 }
      [ TextEdit.multiline ui tb_init; TextEdit.multiline ui to_init ])
  >>= fun page ->
  let page_root = Lwd.observe page in

  let open GLFW in
  let open Event in
  Ui.update_bindings ui
    Ui.(
      adds
        [
          [ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ];
        ]
        [ Custom (fun () -> Lwt.return ()) ]);
  F.pr "oplevel.ml: entering drawing loop@.";
  let period_min = 1.0 /. 30. in
  let t = GLFW.getTime () |> ref in

  let render root =
    let page = Lwd.quick_sample root in
    let win_w, win_h = GLFW.getWindowSize ~window in
    let width, height = (float win_w, float win_h) in
    let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in
    Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
    Perfgraph.render graph ctx (width -. 205.) 5.;
    (* F.epr "box=%a@." Gg.Box2.pp box;
       F.epr "Painter.layout=%a@." Gg.Box2.pp *)
    Painter.layout box ui page >>= fun _ ->
    (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
    Gv.end_frame ctx;

    Lwt.return_unit
  in

  while not GLFW.(windowShouldClose ~window) do
    let now = GLFW.getTime () in
    let dt = now -. !t in
    t := now;

    Perfgraph.update graph dt;

    if now > 2. then (
      let avg = 1. /. Perfgraph.average graph in
      min_fps := Float.min avg !min_fps;
      max_fps := Float.max avg !max_fps);

    let win_w, win_h = GLFW.getWindowSize ~window in
    Gl.viewport 0 0 win_w win_h;
    Gl.clear
      (Gl.color_buffer_bit lor Gl.depth_buffer_bit
     lor Gl.stencil_buffer_bit);
    Gl.enable Gl.blend;
    Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha;
    Gl.enable Gl.cull_face_enum;
    Gl.disable Gl.depth_test;
    Lwt.async (fun () -> render page_root);
    Gc.major_slice 0 |> ignore;
    GLFW.swapBuffers ~window;
    GLFW.pollEvents ();
    Unix.sleepf Float.(max 0. (period_min -. GLFW.getTime () +. !t))
  done;

  Printf.printf "MIN %.2f\n" !min_fps;
  Printf.printf "MAX %.2f\n%!" !max_fps;
  Lwt.return_unit

let () = Lwt_main.run main