basic cursor works but getting text editing is hard, might go in a different direction

dune

@@ -15,7 +15,7 @@
 
 (executables
  (names oplevel)
- (modules oplevel secrets perfgraph ogui)
+ (modules oplevel secrets perfgraph ogui glfw_types)
  (libraries
    lwt
    store

glfw_types.ml

@@ -0,0 +1,149 @@
+open GLFW
+module F = Fmt
+
+let pp_key : GLFW.key F.t =
+ fun ppf k ->
+  F.pf ppf
+    GLFW.(
+      match k with
+      | Unknown -> "Unknown"
+      | Space -> "Space"
+      | Apostrophe -> "Apostrophe"
+      | Comma -> "Comma"
+      | Minus -> "Minus"
+      | Period -> "Period"
+      | Slash -> "Slash"
+      | Num0 -> "Num0"
+      | Num1 -> "Num1"
+      | Num2 -> "Num2"
+      | Num3 -> "Num3"
+      | Num4 -> "Num4"
+      | Num5 -> "Num5"
+      | Num6 -> "Num6"
+      | Num7 -> "Num7"
+      | Num8 -> "Num8"
+      | Num9 -> "Num9"
+      | Semicolon -> "Semicolon"
+      | Equal -> "Equal"
+      | A -> "A"
+      | B -> "B"
+      | C -> "C"
+      | D -> "D"
+      | E -> "E"
+      | F -> "F"
+      | G -> "G"
+      | H -> "H"
+      | I -> "I"
+      | J -> "J"
+      | K -> "K"
+      | L -> "L"
+      | M -> "M"
+      | N -> "N"
+      | O -> "O"
+      | P -> "P"
+      | Q -> "Q"
+      | R -> "R"
+      | S -> "S"
+      | T -> "T"
+      | U -> "U"
+      | V -> "V"
+      | W -> "W"
+      | X -> "X"
+      | Y -> "Y"
+      | Z -> "Z"
+      | LeftBracket -> "LeftBracket"
+      | Backslash -> "Backslash"
+      | RightBracket -> "RightBracket"
+      | GraveAccent -> "GraveAccent"
+      | World1 -> "World1"
+      | World2 -> "World2"
+      | Escape -> "Escape"
+      | Enter -> "Enter"
+      | Tab -> "Tab"
+      | Backspace -> "Backspace"
+      | Insert -> "Insert"
+      | Delete -> "Delete"
+      | Right -> "Right"
+      | Left -> "Left"
+      | Down -> "Down"
+      | Up -> "Up"
+      | PageUp -> "PageUp"
+      | PageDown -> "PageDown"
+      | Home -> "Home"
+      | End -> "End"
+      | CapsLock -> "CapsLock"
+      | ScrollLock -> "ScrollLock"
+      | NumLock -> "NumLock"
+      | PrintScreen -> "PrintScreen"
+      | Pause -> "Pause"
+      | F1 -> "F1"
+      | F2 -> "F2"
+      | F3 -> "F3"
+      | F4 -> "F4"
+      | F5 -> "F5"
+      | F6 -> "F6"
+      | F7 -> "F7"
+      | F8 -> "F8"
+      | F9 -> "F9"
+      | F10 -> "F10"
+      | F11 -> "F11"
+      | F12 -> "F12"
+      | F13 -> "F13"
+      | F14 -> "F14"
+      | F15 -> "F15"
+      | F16 -> "F16"
+      | F17 -> "F17"
+      | F18 -> "F18"
+      | F19 -> "F19"
+      | F20 -> "F20"
+      | F21 -> "F21"
+      | F22 -> "F22"
+      | F23 -> "F23"
+      | F24 -> "F24"
+      | F25 -> "F25"
+      | Kp0 -> "Kp0"
+      | Kp1 -> "Kp1"
+      | Kp2 -> "Kp2"
+      | Kp3 -> "Kp3"
+      | Kp4 -> "Kp4"
+      | Kp5 -> "Kp5"
+      | Kp6 -> "Kp6"
+      | Kp7 -> "Kp7"
+      | Kp8 -> "Kp8"
+      | Kp9 -> "Kp9"
+      | KpDecimal -> "KpDecimal"
+      | KpDivide -> "KpDivide"
+      | KpMultiply -> "KpMultiply"
+      | KpSubtract -> "KpSubtract"
+      | KpAdd -> "KpAdd"
+      | KpEnter -> "KpEnter"
+      | KpEqual -> "KpEqual"
+      | LeftShift -> "LeftShift"
+      | LeftControl -> "LeftControl"
+      | LeftAlt -> "LeftAlt"
+      | LeftSuper -> "LeftSuper"
+      | RightShift -> "RightShift"
+      | RightControl -> "RightControl"
+      | RightAlt -> "RightAlt"
+      | RightSuper -> "RightSuper"
+      | Menu -> "Menu")
+
+let pp_key_action : GLFW.key_action F.t =
+ fun ppf s ->
+  F.pf ppf
+    GLFW.(
+      match s with
+      | Release -> "Release"
+      | Press -> "Press"
+      | Repeat -> "Repeat")
+
+let pp_mods =
+  F.(
+    list (fun ppf s ->
+        pf ppf
+          GLFW.(
+            match s with
+            | Shift -> "Shift"
+            | Control -> "Control"
+            | Alt -> "Alt"
+            | Super -> "Super")))

ogui.ml

@@ -1,3 +1,4 @@
+open Lwt.Infix
 module Gv = Graphv_gles2_native
 module F = Fmt
 
@@ -26,6 +27,15 @@ 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;
@@ -41,25 +51,195 @@ module Sense = struct
     { click = false; drag = false; focusable = true; edit = false }
 end
 
-module EventFilter = struct
-  type t = {
-    tab : bool;
-    horizontal_arrrows : bool;
-    vertical_arrows : bool;
-    escape : bool;
-  }
+module TextBuffer = struct
+  type t =
+    | Tree of {
+        mutable path : string list;
+        mutable tree : Store.S.tree;
+        repo : Store.Sync.db;
+      }
+    | Buffer of { name : string; buf : Buffer.t }
 
-  let default =
-    {
-      tab = false;
-      horizontal_arrrows = false;
-      vertical_arrows = false;
-      escape = false;
-    }
+  let of_repo ~path ~(repo : Store.Sync.db) =
+    let tree = Lwt_main.run ((fun () -> Store.S.tree repo) ()) in
+    Tree { path; tree; repo }
+
+  let buffer ~name ~buf = Buffer { name; buf }
+
+  let insert_uchar t n uc : t Lwt.t =
+    F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;
+    match t with
+    | Tree ({ path; tree; _ } as tt) ->
+        Store.S.Tree.update tree path (function
+          | Some src ->
+              assert (n <= String.length src);
+              let ucbuf = Bytes.create 8 in
+              let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in
+              let dst = Bytes.create (String.length src + uclen) in
+              BytesLabels.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0
+                ~len:n;
+              BytesLabels.blit ~src:ucbuf ~src_pos:0 ~dst ~dst_pos:n
+                ~len:uclen;
+              BytesLabels.blit_string ~src ~src_pos:n ~dst
+                ~dst_pos:(n + uclen)
+                ~len:(String.length src - (n + uclen));
+              Some (Bytes.to_string dst)
+          | None -> None)
+        >>= fun tree -> Lwt.return (Tree { tt with tree })
+    | Buffer { buf; _ } as b ->
+        let textend = Buffer.sub buf n (Buffer.length buf - n) in
+        Buffer.truncate buf n;
+        Buffer.add_utf_8_uchar buf uc;
+        Buffer.add_string buf textend;
+        Lwt.return b
+
+  let contents = function
+    | Tree { path; tree; _ } ->
+        (try Store.S.Tree.get tree path with
+        | Not_found | Invalid_argument _ ->
+            Lwt.return
+            @@ F.str
+                 "print_newline \"/%s: Not_found | \
+                  Invalid_argument\";;"
+                 (String.concat "/" path)
+        | exc ->
+            Lwt.return
+              (F.str "Store.S.Tree.get /%s exception: %s"
+                 (String.concat "/" path)
+                 (Printexc.to_string exc)))
+        >>= fun text -> Lwt.return text
+    | Buffer { buf; _ } -> Lwt.return (Buffer.contents buf)
+
+  let length = function
+    | Tree { path; tree; _ } ->
+        Store.S.Tree.get tree path >>= fun text ->
+        Lwt.return (String.length text)
+    | Buffer { buf; _ } -> Lwt.return @@ Buffer.length buf
 end
 
+module Event = struct
+  type key_action = GLFW.key_action
+  type key = GLFW.key
+  type key_mod = GLFW.key_mod
+  type event = Key of key_action * key * key_mod list
+
+  (* Stolen from zed_input.ml *)
+  module EventMap = Map.Make (struct
+    type t = event
+
+    let compare = compare
+  end)
+
+  type 'a t = 'a node EventMap.t
+  and 'a node = Set of 'a t | Val of 'a
+
+  let empty = EventMap.empty
+
+  let rec add (events : event list) value set =
+    match events with
+    | [] -> invalid_arg "Event.add"
+    | [ event ] -> EventMap.add event (Val value) set
+    | event :: events -> (
+        match
+          try Some (EventMap.find event set) with Not_found -> None
+        with
+        | None | Some (Val _) ->
+            EventMap.add event (Set (add events value empty)) set
+        | Some (Set s) ->
+            EventMap.add event (Set (add events value s)) set)
+
+  let adds (events : event list list) value set =
+    List.fold_left (fun s e -> add e value s) set events
+
+  let rec remove events set =
+    match events with
+    | [] -> invalid_arg "Event.remove"
+    | [ event ] -> EventMap.remove event set
+    | event :: events -> (
+        match
+          try Some (EventMap.find event set) with Not_found -> None
+        with
+        | None | Some (Val _) -> set
+        | Some (Set s) ->
+            let s = remove events s in
+            if EventMap.is_empty s then EventMap.remove event set
+            else EventMap.add event (Set s) set)
+
+  let fold f set acc =
+    let rec loop prefix set acc =
+      EventMap.fold
+        (fun event node acc ->
+          match node with
+          | Val v -> f (List.rev (event :: prefix)) v acc
+          | Set s -> loop (event :: prefix) s acc)
+        set acc
+    in
+    loop [] set acc
+
+  let bindings set =
+    List.rev
+      (fold (fun events action l -> (events, action) :: l) set [])
+
+  module type Pack = sig
+    type a
+    type b
+
+    val set : a t
+    val map : a -> b
+  end
+
+  type 'a pack = (module Pack with type b = 'a)
+  type 'a resolver = 'a pack list
+
+  let pack (type u v) map set =
+    let module Pack = struct
+      type a = u
+      type b = v
+
+      let set = set
+      let map = map
+    end in
+    (module Pack : Pack with type b = v)
+
+  let resolver l = l
+
+  type 'a result =
+    | Accepted of 'a
+    | Continue of 'a resolver
+    | Rejected
+
+  let rec resolve_rec :
+        'a. event -> 'a pack list -> 'a pack list -> 'a result =
+   fun (type u) event acc packs ->
+    match packs with
+    | [] -> if acc = [] then Rejected else Continue (List.rev acc)
+    | p :: packs -> (
+        let module Pack = (val p : Pack with type b = u) in
+        match
+          try Some (EventMap.find event Pack.set)
+          with Not_found -> None
+        with
+        | Some (Set set) ->
+            resolve_rec event (pack Pack.map set :: acc) packs
+        | Some (Val v) -> Accepted (Pack.map v)
+        | None -> resolve_rec event acc packs)
+
+  let resolve event sets = resolve_rec event [] sets
+
+  include Glfw_types
+
+  let pp_event : event F.t =
+   fun ppf e ->
+    let open Glfw_types in
+    match e with
+    | Key (a, k, m) ->
+        F.pf ppf "Key %a, %a, %a" pp_key_action a pp_key k pp_mods m
+  (* | Char u -> F.pf ppf "Char %a" pp_uchar u
+     | AnyChar -> F.pf ppf "AnyChar" *)
+end
+
+type event = Event.event
 type id = int
-type event_filter = EventFilter.t
 
 module Context = struct
   type t = { derp : bool }
@@ -250,7 +430,7 @@ module TextLayout = struct
     }
 
   type layout_job = {
-    text : string;
+    text : TextBuffer.t;
     sections : layout_section array;
     wrap : text_wrapping;
     first_row_min_height : float;
@@ -264,7 +444,9 @@ module TextLayout = struct
     F.(
       record
         [
-          field "text" (fun s -> String.length s.text) int;
+          field "text"
+            (fun s -> Lwt_main.run (TextBuffer.length s.text))
+            int;
           field "sections"
             (fun s -> s.sections)
             (array pp_layout_section);
@@ -279,7 +461,9 @@ module TextLayout = struct
 
   let default_layout_job () =
     {
-      text = "";
+      text =
+        TextBuffer.buffer ~name:"default_layout_job"
+          ~buf:(Buffer.create 32);
       sections = Array.make 0 layout_section_default;
       wrap = default_text_wrapping ();
       first_row_min_height = 0.0;
@@ -461,6 +645,7 @@ module TextLayout = struct
     match c with
     | Some (a, b) ->
         let a', b' = f a.index b.index in
+        F.epr "cursor_state_update %d %d@." a' b';
         Some (new_cursor_range (max a' 0, max b' 0))
     | None -> None
 
@@ -473,7 +658,7 @@ module TextLayout = struct
         Array.make 1
           {
             leading_space = 0.0;
-            byte_range = (0, String.length text);
+            byte_range = (0, Lwt_main.run (TextBuffer.length text));
             format;
           };
       wrap =
@@ -481,7 +666,8 @@ module TextLayout = struct
       break_on_newline = true;
     }
 
-  let simple text (format : text_format) wrap_width : layout_job =
+  let simple (text : TextBuffer.t) (format : text_format) wrap_width :
+      layout_job =
     {
       (default_layout_job ()) with
       text;
@@ -489,7 +675,7 @@ module TextLayout = struct
         Array.make 1
           {
             leading_space = 0.0;
-            byte_range = (0, String.length text);
+            byte_range = (0, Lwt_main.run (TextBuffer.length text));
             format;
           };
       wrap =
@@ -497,7 +683,8 @@ module TextLayout = struct
       break_on_newline = true;
     }
 
-  let simple_singleline text (format : text_format) : layout_job =
+  let simple_singleline (text : TextBuffer.t) (format : text_format) :
+      layout_job =
     {
       (default_layout_job ()) with
       text;
@@ -505,7 +692,7 @@ module TextLayout = struct
         Array.make 1
           {
             leading_space = 0.0;
-            byte_range = (0, String.length text);
+            byte_range = (0, Lwt_main.run (TextBuffer.length text));
             format;
           };
       wrap = default_text_wrapping ();
@@ -585,7 +772,8 @@ module TextLayout = struct
       let lines = Gv.Text.make_empty_rows job.wrap.max_rows in
       let row_count =
         Gv.Text.break_lines gv ~break_width:job.wrap.max_width
-          ~max_rows:job.wrap.max_rows ~lines job.text
+          ~max_rows:job.wrap.max_rows ~lines
+          (Lwt_main.run (TextBuffer.contents job.text))
       in
       (* F.epr "row_count=%d@." row_count; *)
       let height = ref (V2.y pos) in
@@ -654,62 +842,64 @@ module Painter = struct
 
     (* F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows;*)
     Array.iter
-      Gv.(
-        fun (row : TextLayout.row) ->
-          let sections =
-            List.filter
-              (fun (r : TextLayout.layout_section) ->
-                fst r.byte_range <= row.text_row.end_index
-                && snd r.byte_range > row.text_row.start_index)
-              (Array.to_list
-              @@ Array.sub g.job.sections row.section_index_at_start
-                   (Array.length g.job.sections
-                   - row.section_index_at_start))
-          in
-          assert (List.length sections > 0);
+      (fun (row : TextLayout.row) ->
+        let sections =
+          List.filter
+            (fun (r : TextLayout.layout_section) ->
+              fst r.byte_range <= row.text_row.end_index
+              && snd r.byte_range > row.text_row.start_index)
+            (Array.to_list
+            @@ Array.sub g.job.sections row.section_index_at_start
+                 (Array.length g.job.sections
+                 - row.section_index_at_start))
+        in
+        assert (List.length sections > 0);
 
-          ignore
-            Gg.(
-              List.fold_left
-                (fun x (sec : TextLayout.layout_section) ->
-                  let start, end_ =
-                    ( min
-                        (String.length g.job.text - 1)
-                        (max 0
-                           (max (fst sec.byte_range)
-                              row.text_row.start_index)),
-                      min
-                        (String.length g.job.text - 1)
-                        (max 0
-                           (min (snd sec.byte_range)
-                              row.text_row.end_index)) )
-                  in
+        ignore
+          Gg.(
+            List.fold_left
+              (fun x (sec : TextLayout.layout_section) ->
+                let start, end_ =
+                  ( min
+                      (Lwt_main.run (TextBuffer.length g.job.text) - 1)
+                      (max 0
+                         (max (fst sec.byte_range)
+                            row.text_row.start_index)),
+                    min
+                      (Lwt_main.run (TextBuffer.length g.job.text) - 1)
+                      (max 0
+                         (min (snd sec.byte_range)
+                            row.text_row.end_index)) )
+                in
 
-                  let font_name, font_size =
-                    match sec.format.font_id with
-                    | Default -> ("mono", 18.)
-                    | FontId (s, size) -> (s, size)
-                  in
-                  Text.set_font_face t ~name:font_name;
-                  Text.set_size t ~size:font_size;
-                  Text.set_align t ~align:Align.(left lor top);
-                  let metrics = Gv.Text.metrics t in
-                  let bounds =
-                    Gv.Text.bounds t ~x ~y:0. ~start ~end_ g.job.text
-                  in
-                  Path.begin_ t;
-                  Path.rect t ~x ~y:(Box2.miny row.rect)
-                    ~w:bounds.advance ~h:metrics.line_height;
-                  set_fill_color t ~color:sec.format.background;
-                  fill t;
+                let font_name, font_size =
+                  match sec.format.font_id with
+                  | Default -> ("mono", 18.)
+                  | FontId (s, size) -> (s, size)
+                in
+                let open Gv in
+                Text.set_font_face t ~name:font_name;
+                Text.set_size t ~size:font_size;
+                Text.set_align t ~align:Align.(left lor top);
+                let metrics = Gv.Text.metrics t in
+                let bounds =
+                  Gv.Text.bounds t ~x ~y:0. ~start ~end_
+                    (Lwt_main.run (TextBuffer.contents g.job.text))
+                in
+                Path.begin_ t;
+                Path.rect t ~x ~y:(Box2.miny row.rect)
+                  ~w:bounds.advance ~h:metrics.line_height;
+                set_fill_color t ~color:sec.format.background;
+                fill t;
 
-                  set_fill_color t ~color:sec.format.color;
-                  let w =
-                    Text.text_w t ~x ~y:(Box2.miny row.rect) ~start
-                      ~end_ g.job.text
-                  in
-                  w)
-                (Box2.minx row.rect) sections))
+                set_fill_color t ~color:sec.format.color;
+                let w =
+                  Text.text_w t ~x ~y:(Box2.miny row.rect) ~start
+                    ~end_
+                    (Lwt_main.run (TextBuffer.contents g.job.text))
+                in
+                w)
+              (Box2.minx row.rect) sections))
       g.rows
 end
 
@@ -877,25 +1067,18 @@ module Placer = struct
 end
 
 module Ui = struct
-  type key_callback =
-    t ->
-    GLFW.window ->
-    GLFW.key ->
-    int ->
-    GLFW.key_action ->
-    GLFW.key_mod list ->
-    unit
-
-  and t = {
+  type t = {
     id : id;
     style : Style.t;
     placer : Placer.t;
     enabled : bool;
     gv : Gv.t;
     glfw_window : GLFW.window option;
-    mutable key : key_callback;
+    mutable bindings : action list Event.t;
   }
 
+  and action = Custom of (unit -> unit Lwt.t)
+
   let id = ref 0
   let spacing ui = ui.style.spacing
   let available_size ui = Placer.available_size ui.placer
@@ -907,7 +1090,6 @@ module Ui = struct
     (!id, size)
 
   let cursor_origin (ui : t) = Gg.Box2.o ui.placer.region.max_rect
-  let key_callback_default _ _ _ _ _ _ = ()
 
   let window gv ?(window : GLFW.window option) rect : t =
     let id, rect = allocate_space gv rect in
@@ -920,56 +1102,57 @@ module Ui = struct
       enabled = true;
       gv;
       glfw_window = window;
-      key = key_callback_default;
+      bindings = Event.empty;
     }
 
-  let keycallback t window key int state mods : unit =
-    t.key t window key int state mods
+  let callback_resolver : action list Event.resolver option ref =
+    ref Option.None
 
-  let add_key_callback (t : t) ~(f : key_callback) : unit =
-    let g = t.key in
-    t.key <-
-      (fun a1 a2 a3 a4 a5 a6 ->
-        f a1 a2 a3 a4 a5 a6;
-        g a1 a2 a3 a4 a5 a6)
+  let keycallback t (state : Event.key_action) (key : Event.key)
+      (mods : Event.key_mod list) : unit =
+    let res =
+      match !callback_resolver with
+      | Some res -> res
+      | None -> Event.resolver [ Event.pack Fun.id t.bindings ]
+    in
 
-  let interact (_ui : t) rect (id : id option) sense : Response.t =
-    let id = Option.value id ~default:(-1) in
-    {
-      ctx = { derp = false };
-      id;
-      rect;
-      interact_rect = rect;
-      sense;
-      enabled = true;
-      contains_pointer = (*TODO*) true;
-      hovered = (*TODO*) true;
-      highlighted = (*TODO*) true;
-      clicked = (*TODO*) true;
-      fake_primary_click = (*TODO*) false;
-      long_touched = (*TODO*) false;
-      drag_started = false;
-      dragged = false;
-      drag_stopped = false;
-      is_pointer_button_down_on = false;
-      interact_pointer_pos = None;
-      changed = false;
-    }
-end
+    Event.(
+      F.epr "Ui.keycallback %a %a %a@." pp_key key pp_key_action state
+        pp_mods mods);
+    ignore
+    @@ Lwt_main.run
+         ((fun () : bool Lwt.t ->
+            match Event.resolve (Key (state, key, mods)) res with
+            | Event.Accepted actions ->
+                callback_resolver := None;
+                let rec exec : action list -> bool Lwt.t = function
+                  | Custom f :: actions ->
+                      f () >>= fun () -> exec actions
+                  | [] -> Lwt.return false
+                in
+                exec actions
+            | Event.Continue res ->
+                callback_resolver := Some res;
+                Lwt.return true
+            | Event.Rejected ->
+                callback_resolver := None;
+                Lwt.return false)
+            ())
 
-module TextBuffer = struct
-  type t = String of string
+  let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
+    ref (fun c ->
+        F.epr "chrcallback: '%a'@." pp_uchar c;
+        Lwt.return_unit)
 
-  let is_mutable = function String _ -> true
-  let as_string = function String s -> s
+  let chrcallback _t (chr : int) : unit =
+    Lwt_main.run @@ !chrcallback_ref @@ Uchar.of_int chr
 end
 
 module TextEdit = struct
   open Gg
 
   type t = {
-    text : TextBuffer.t;
-    hint_text : TextLayout.widget_text;
+    mutable text : TextBuffer.t;
     id : id option;
     id_source : id option;
     text_format : TextLayout.text_format;
@@ -982,7 +1165,6 @@ module TextEdit = struct
     interactive : bool;
     desired_width : float option;
     desired_height_rows : int;
-    event_filter : event_filter;
     cursor_at_end : bool;
     min_size : Gg.v2;
     align : align;
@@ -990,7 +1172,7 @@ module TextEdit = struct
     char_limit : int; (* return_key : keyboard_shortcut; *)
   }
 
-  type state = {
+  and state = {
     mutable cursor : TextLayout.cursor_state;
     (* undoer : undoer; *)
     singleline_offset : float;
@@ -999,27 +1181,81 @@ module TextEdit = struct
 
   let state_mem : (int * state) list ref = ref []
 
-  let process_key (state : state) (key : GLFW.key)
-      (action : GLFW.key_action) (mods : GLFW.key_mod list) : unit =
+  let add_bindings (t : t) (ui : Ui.t) (state : state) : unit Lwt.t =
     let open GLFW in
-    match (action, key, mods) with
-    | Press, F, [ Control ] | Press, Right, [] ->
-        state.cursor <-
-          TextLayout.cursor_state_update
-            ~f:(fun a b ->
-              F.epr "cursor_state_update %d %d@." a b;
-              (a + 1, b + 1))
-            state.cursor
-    | Press, B, [ Control ] | Press, Left, [] ->
-        state.cursor <-
-          TextLayout.cursor_state_update
-            ~f:(fun a b ->
-              F.epr "cursor_state_update %d %d@." a b;
-              (a - 1, b - 1))
-            state.cursor
-    | _ -> ()
+    let open Event in
+    let open Ui in
+    ui.bindings <-
+      empty
+      |> adds
+           [
+             [ Key (Press, F, [ Control ]) ];
+             [ Key (Press, Right, []) ];
+           ]
+           [
+             Custom
+               (fun () ->
+                 state.cursor <-
+                   TextLayout.cursor_state_update
+                     ~f:(fun a b -> (a + 1, b + 1))
+                     state.cursor;
+                 Lwt.return_unit);
+           ]
+      |> adds
+           [
+             [ Key (Press, B, [ Control ]) ];
+             [ Key (Press, Left, []) ];
+           ]
+           [
+             Custom
+               (fun () ->
+                 state.cursor <-
+                   TextLayout.cursor_state_update
+                     ~f:(fun a b -> (a - 1, b - 1))
+                     state.cursor;
+                 Lwt.return_unit);
+           ]
+      |> adds
+           [
+             [ Key (Press, N, [ Control ]) ];
+             [ Key (Press, Down, []) ];
+           ]
+           [
+             Custom
+               (fun () ->
+                 state.cursor <-
+                   TextLayout.cursor_state_update
+                     ~f:(fun a b -> (a - 1, b - 1))
+                     state.cursor;
+                 Lwt.return_unit);
+           ]
+      |> adds
+           [
+             [ Key (Press, P, [ Control ]) ]; [ Key (Press, Up, []) ];
+           ]
+           [
+             Custom
+               (fun () ->
+                 state.cursor <-
+                   TextLayout.cursor_state_update
+                     ~f:(fun a b -> (a - 1, b - 1))
+                     state.cursor;
+                 Lwt.return_unit);
+           ];
+    (* WARN XXX TKTK TODO this is probably "breaking" the lwt context and being used in other calls to Lwt_main.run *)
+    (Ui.chrcallback_ref :=
+       fun c ->
+         match state.cursor with
+         | Some (_a, b) ->
+             TextBuffer.insert_uchar t.text b.index c >>= fun text ->
+             t.text <- text;
+             Lwt.return_unit
+         | None -> Lwt.return_unit
+       (* This creates a giant stack of calls lol
+          >>= fun () -> !Ui.chrcallback_ref c *));
+    Lwt.return_unit
 
-  let load_state ui id =
+  let load_state id =
     match List.assoc_opt id !state_mem with
     | Some state -> state
     | None ->
@@ -1031,14 +1267,10 @@ module TextEdit = struct
           }
         in
         state_mem := (id, state) :: !state_mem;
-        (* We use this as the one shot for registering keyboard shortcuts
-           since they just operate on the state *)
-        Ui.add_key_callback ui ~f:(fun _ _ key _ action mods ->
-            process_key state key action mods);
         state
 
   type output = {
-    response : Response.t;
+    (*  response : Response.t; *)
     galley : TextLayout.galley;
     galley_pos : Gg.p2;
     text_clip_rect : Gg.box2;
@@ -1050,7 +1282,6 @@ module TextEdit = struct
       (text : TextBuffer.t) : t =
     {
       text;
-      hint_text = RichText TextLayout.rich_text_default;
       id = None;
       id_source = None;
       text_format;
@@ -1062,13 +1293,6 @@ module TextEdit = struct
       interactive = true;
       desired_width = None;
       desired_height_rows = 4;
-      event_filter =
-        {
-          EventFilter.default with
-          horizontal_arrrows = true;
-          vertical_arrows = true;
-          tab = false;
-        };
       cursor_at_end = true;
       min_size = Gg.V2.zero;
       align = Min;
@@ -1078,6 +1302,8 @@ module TextEdit = struct
     }
 
   let show_content (t : t) (ui : Ui.t) : output =
+    let state = load_state (Option.value ~default:(-1) t.id) in
+    Lwt_main.run (add_bindings t ui state);
     let origin = Ui.cursor_origin ui in
     (* TODO .or(ui.visuals().override_text_color) *)
     (* let row_height = (Gv.Text.metrics ui.gv).line_height in *)
@@ -1093,23 +1319,17 @@ module TextEdit = struct
         available_width
       else Float.min desired_width available_width
     in
-    let state = load_state ui (Option.value ~default:(-1) t.id) in
     let default_layouter (ui : Ui.t) (text : TextBuffer.t)
         (wrap_width : size1) : TextLayout.galley =
       let font =
         match Gv.Text.find_font ui.gv ~name:"mono" with
         | Some gv -> Fonts.{ gv; pixels_per_point = 1.0 }
-        | None -> failwith "can't font font 'mono'"
+        | None -> failwith "can't find font 'mono'"
       in
       let layout_job =
         if t.multiline then
-          TextLayout.simple
-            (TextBuffer.as_string text)
-            t.text_format wrap_width
-        else
-          TextLayout.simple_singleline
-            (TextBuffer.as_string text)
-            t.text_format
+          TextLayout.simple text t.text_format wrap_width
+        else TextLayout.simple_singleline text t.text_format
       in
       let layout_job =
         TextLayout.with_cursor
@@ -1145,9 +1365,9 @@ module TextEdit = struct
     (* TODO state = TextEditState::load(ui.ctx(), id)... *)
     (* TODO moved up let state = load_state (Option.value ~default:(-1) t.id) in *)
     (* TODO allow_drag_to_select = ... *)
-    let sense = if t.interactive then Sense.click else Sense.hover in
+    let _sense = if t.interactive then Sense.click else Sense.hover in
 
-    let response = Ui.interact ui outer_rect t.id sense in
+    (* let response = Ui.interact ui outer_rect t.id sense in *)
     (* TODO *)
     let text_clip_rect = rect in
     (*    let painter = Ui.painter_at ui text_clip_rect in *)
@@ -1162,7 +1382,6 @@ module TextEdit = struct
 
     let _align_offset = rect in
     {
-      response;
       galley;
       galley_pos = Box2.o galley_pos;
       text_clip_rect;
@@ -1171,11 +1390,8 @@ module TextEdit = struct
     }
 
   let show (t : t) ui : output =
-    let _is_mutable = TextBuffer.is_mutable t.text in
-    let _frame = t.frame in
-
     let _margin = t.margin in
     let output = show_content t ui in
-    let _outer_rect = output.response.rect in
+    (*    let _outer_rect = output.response.rect in *)
     output
 end

oplevel.ml

@@ -1,4 +1,3 @@
-open Lwt.Infix
 module F = Fmt
 open Tgles2
 module Gv = Graphv_gles2_native
@@ -37,153 +36,6 @@ let load_data vg =
   Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji";
   Gv.Text.set_font_face vg ~name:"mono"
 
-let pp_glfw_key : GLFW.key F.t =
- fun ppf k ->
-  F.pf ppf
-    GLFW.(
-      match k with
-      | Unknown -> "Unknown"
-      | Space -> "Space"
-      | Apostrophe -> "Apostrophe"
-      | Comma -> "Comma"
-      | Minus -> "Minus"
-      | Period -> "Period"
-      | Slash -> "Slash"
-      | Num0 -> "Num0"
-      | Num1 -> "Num1"
-      | Num2 -> "Num2"
-      | Num3 -> "Num3"
-      | Num4 -> "Num4"
-      | Num5 -> "Num5"
-      | Num6 -> "Num6"
-      | Num7 -> "Num7"
-      | Num8 -> "Num8"
-      | Num9 -> "Num9"
-      | Semicolon -> "Semicolon"
-      | Equal -> "Equal"
-      | A -> "A"
-      | B -> "B"
-      | C -> "C"
-      | D -> "D"
-      | E -> "E"
-      | F -> "F"
-      | G -> "G"
-      | H -> "H"
-      | I -> "I"
-      | J -> "J"
-      | K -> "K"
-      | L -> "L"
-      | M -> "M"
-      | N -> "N"
-      | O -> "O"
-      | P -> "P"
-      | Q -> "Q"
-      | R -> "R"
-      | S -> "S"
-      | T -> "T"
-      | U -> "U"
-      | V -> "V"
-      | W -> "W"
-      | X -> "X"
-      | Y -> "Y"
-      | Z -> "Z"
-      | LeftBracket -> "LeftBracket"
-      | Backslash -> "Backslash"
-      | RightBracket -> "RightBracket"
-      | GraveAccent -> "GraveAccent"
-      | World1 -> "World1"
-      | World2 -> "World2"
-      | Escape -> "Escape"
-      | Enter -> "Enter"
-      | Tab -> "Tab"
-      | Backspace -> "Backspace"
-      | Insert -> "Insert"
-      | Delete -> "Delete"
-      | Right -> "Right"
-      | Left -> "Left"
-      | Down -> "Down"
-      | Up -> "Up"
-      | PageUp -> "PageUp"
-      | PageDown -> "PageDown"
-      | Home -> "Home"
-      | End -> "End"
-      | CapsLock -> "CapsLock"
-      | ScrollLock -> "ScrollLock"
-      | NumLock -> "NumLock"
-      | PrintScreen -> "PrintScreen"
-      | Pause -> "Pause"
-      | F1 -> "F1"
-      | F2 -> "F2"
-      | F3 -> "F3"
-      | F4 -> "F4"
-      | F5 -> "F5"
-      | F6 -> "F6"
-      | F7 -> "F7"
-      | F8 -> "F8"
-      | F9 -> "F9"
-      | F10 -> "F10"
-      | F11 -> "F11"
-      | F12 -> "F12"
-      | F13 -> "F13"
-      | F14 -> "F14"
-      | F15 -> "F15"
-      | F16 -> "F16"
-      | F17 -> "F17"
-      | F18 -> "F18"
-      | F19 -> "F19"
-      | F20 -> "F20"
-      | F21 -> "F21"
-      | F22 -> "F22"
-      | F23 -> "F23"
-      | F24 -> "F24"
-      | F25 -> "F25"
-      | Kp0 -> "Kp0"
-      | Kp1 -> "Kp1"
-      | Kp2 -> "Kp2"
-      | Kp3 -> "Kp3"
-      | Kp4 -> "Kp4"
-      | Kp5 -> "Kp5"
-      | Kp6 -> "Kp6"
-      | Kp7 -> "Kp7"
-      | Kp8 -> "Kp8"
-      | Kp9 -> "Kp9"
-      | KpDecimal -> "KpDecimal"
-      | KpDivide -> "KpDivide"
-      | KpMultiply -> "KpMultiply"
-      | KpSubtract -> "KpSubtract"
-      | KpAdd -> "KpAdd"
-      | KpEnter -> "KpEnter"
-      | KpEqual -> "KpEqual"
-      | LeftShift -> "LeftShift"
-      | LeftControl -> "LeftControl"
-      | LeftAlt -> "LeftAlt"
-      | LeftSuper -> "LeftSuper"
-      | RightShift -> "RightShift"
-      | RightControl -> "RightControl"
-      | RightAlt -> "RightAlt"
-      | RightSuper -> "RightSuper"
-      | Menu -> "Menu")
-
-let pp_glfw_key_action : GLFW.key_action F.t =
- fun ppf s ->
-  F.pf ppf
-    GLFW.(
-      match s with
-      | Release -> "Release"
-      | Press -> "Press"
-      | Repeat -> "Repeat")
-
-let pp_glfw_mods =
-  F.(
-    list (fun ppf s ->
-        pf ppf
-          GLFW.(
-            match s with
-            | Shift -> "Shift"
-            | Control -> "Control"
-            | Alt -> "Alt"
-            | Super -> "Super")))
-
 let () =
   GLFW.init ();
   at_exit GLFW.terminate;
@@ -218,24 +70,10 @@ let () =
   F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
   Toploop.initialize_toplevel_env ();
 
-  let text =
+  let rootrepo =
     Lwt_main.run
-      ((fun () ->
-         Store.init_default
-           (F.str "%s/console/rootstore.git" Secrets.giturl)
-         >>= fun t ->
-         Store.S.tree t >>= fun rootstore ->
-         (try Store.S.Tree.get rootstore [ ".config"; "init.ml" ] with
-         | Not_found | Invalid_argument _ ->
-             Lwt.return
-               "print_newline \"rootstore://.config/init.ml not \
-                found\";;"
-         | exc ->
-             Lwt.return
-               (F.str ".config/init.ml load exception: %s"
-                  (Printexc.to_string exc)))
-         >>= fun text -> Lwt.return text)
-         ())
+      (Store.init_default
+         (F.str "%s/console/rootstore.git" Secrets.giturl))
   in
 
   let ui =
@@ -245,17 +83,32 @@ let () =
   GLFW.setKeyCallback ~window
     ~f:
       (Some
-         (fun window key int state mods ->
-           F.epr
-             "GLFW.setKeyCallback ~f: _win key=%a int=%d state=%a \
-              mods=%a@."
-             pp_glfw_key key int pp_glfw_key_action state pp_glfw_mods
-             mods;
-           Ogui.Ui.keycallback ui window key int state mods))
+         Glfw_types.(
+           fun _window key int state mods ->
+             F.epr
+               "GLFW.setKeyCallback ~f: _win key=%a int=%d state=%a \
+                mods=%a@."
+               pp_key key int pp_key_action state pp_mods mods;
+             Ogui.Ui.keycallback ui state key mods))
   |> ignore;
 
-  let t = GLFW.getTime () |> ref in
+  GLFW.setCharCallback ~window
+    ~f:
+      (Some
+         (fun _window ch ->
+           let uc = Uchar.of_int ch in
+           F.epr "GLFW.setCharCallback ~f: _win ch=%d(%a)@." ch
+             F.(option string)
+             (if Uchar.is_char uc then
+                Some (String.make 1 @@ Uchar.to_char uc)
+              else None);
 
+           Ogui.Ui.chrcallback ui ch))
+  |> ignore;
+
+  F.pr "oplevel.ml: entering drawing loop@.";
+
+  let t = GLFW.getTime () |> ref in
   while (not GLFW.(windowShouldClose ~window)) && !continue do
     Lwt_main.run
       ((fun () ->
@@ -277,24 +130,27 @@ let () =
          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;
 
-         let win_w, win_h = (float win_w, float win_h) in
-         Gv.begin_frame ctx ~width:win_w ~height:win_h
-           ~device_ratio:1.;
+         let width, height = (float win_w, float win_h) in
 
-         Perfgraph.render graph ctx (win_w -. 205.) 5.;
-
-         ignore Ogui.TextEdit.(show (multiline (String text)) ui);
+         Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
+         Perfgraph.render graph ctx (width -. 205.) 5.;
+         ignore
+           Ogui.TextEdit.(
+             show
+               (multiline
+                  (Ogui.TextBuffer.of_repo
+                     ~path:[ ".config"; "init.ml" ]
+                     ~repo:rootrepo))
+               ui);
          (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
          Gv.end_frame ctx;
 
          Gc.major_slice 0 |> ignore;
-
          GLFW.swapBuffers ~window;
          GLFW.pollEvents ();
          Lwt.return_unit)