down might be correct?

dune

@@ -27,6 +27,7 @@
    gg
    irmin-git
    compiler-libs.toplevel
+   re
  )
  (link_flags (-linkall))
  ; (ocamlopt_flags (:standard -O3 -unboxed-types))

ogui.ml

@@ -1,6 +1,7 @@
 open Lwt.Infix
 module Gv = Graphv_gles2_native
 module F = Fmt
+module Str = Re.Str
 
 type stroke = { width : float; color : Gv.Color.t }
 
@@ -52,24 +53,25 @@ module Sense = struct
 end
 
 module TextBuffer = struct
-  type t =
+  type t = {
-    | Tree of {
     mutable path : string list;
     mutable tree : Store.S.tree;
     repo : Store.Sync.db;
   }
-    | Buffer of { name : string; buf : Buffer.t }
 
   let of_repo ~path ~(repo : Store.Sync.db) =
     let tree = Lwt_main.run ((fun () -> Store.S.tree repo) ()) in
-    Tree { path; tree; repo }
+    { path; tree; repo }
 
-  let buffer ~name ~buf = Buffer { name; buf }
+  let of_string ~path ?(repo = None) str =
+    Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' ->
+    Option.value ~default:Store.S.(empty repo') repo >>= fun repo ->
+    Lwt.return { path; tree = Store.S.Tree.singleton path str; repo }
 
   let insert_uchar t n uc : t Lwt.t =
     F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;
     match t with
-    | Tree ({ path; tree; _ } as tt) ->
+    | { path; tree; _ } as tt ->
         Store.S.Tree.update tree path (function
           | Some src ->
               assert (n <= String.length src);
@@ -85,22 +87,37 @@ module TextBuffer = struct
                 ~len:(String.length src - (n + uclen));
               Some (Bytes.to_string dst)
           | None -> None)
-        >>= fun tree -> Lwt.return (Tree { tt with tree })
+        >>= fun tree -> Lwt.return { 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
+  let remove_uchar t n : t Lwt.t =
-    | Tree { path; tree; _ } ->
+    F.epr "TextBuffer.remove_subset n=%d @." n;
+    match t with
+    | { path; tree; _ } as tt ->
+        Store.S.Tree.update tree path (function
+          | Some src ->
+              let srcn = String.length src in
+              assert (n < srcn);
+              let dst = Bytes.create srcn in
+              let ucn =
+                Uchar.utf_decode_length (String.get_utf_8_uchar src n)
+              in
+              Bytes.blit_string src 0 dst 0 n;
+              Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn);
+              Some (Bytes.to_string dst)
+          | v -> v)
+        >>= fun tree -> Lwt.return { tt with tree }
+
+  let fold_string t (f : string -> 'a) : 'a Lwt.t =
+    match t with
+    | { path; tree; _ } ->
+        Store.S.Tree.get tree path >>= fun text -> Lwt.return (f text)
+
+  let contents { path; tree; _ } =
     (try Store.S.Tree.get tree path with
     | Not_found | Invalid_argument _ ->
         Lwt.return
         @@ F.str
-                 "print_newline \"/%s: Not_found | \
+             "print_newline \"/%s: Not_found | Invalid_argument\";;"
-                  Invalid_argument\";;"
              (String.concat "/" path)
     | exc ->
         Lwt.return
@@ -108,13 +125,10 @@ module TextBuffer = struct
              (String.concat "/" path)
              (Printexc.to_string exc)))
     >>= fun text -> Lwt.return text
-    | Buffer { buf; _ } -> Lwt.return (Buffer.contents buf)
 
-  let length = function
+  let length { path; tree; _ } =
-    | 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
@@ -440,8 +454,8 @@ module TextLayout = struct
       record
         [
           field "text"
-            (fun s -> Lwt_main.run (TextBuffer.length s.text))
+            (fun s -> str "path=%s" (String.concat "/" s.text.path))
-            int;
+            string;
           field "sections"
             (fun s -> s.sections)
             (brackets @@ array pp_layout_section);
@@ -454,11 +468,9 @@ module TextLayout = struct
           field "justify" (fun s -> s.justify) bool;
         ])
 
-  let default_layout_job () =
+  let layout_job_of_text text =
     {
-      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;
@@ -615,42 +627,39 @@ module TextLayout = struct
   type cursor = {
     index : int;
     row : int option;
+    last_col : int;
     prefer_next_row : bool;
   }
 
   let cursor_default =
-    { index = 0; row = None; prefer_next_row = false }
+    { index = 0; row = None; last_col = 0; prefer_next_row = false }
 
-  let cursor loc : cursor =
+  let cursor ?(row : int option) ?(last_col = 0) index : cursor =
-    { index = loc; row = None; prefer_next_row = false }
+    F.epr "cursor row=%a last_col=%d index=%d@."
-
+      F.(option int)
-  let cursor_move amt max c : cursor =
+      row last_col index;
-    cursor
+    { index; row; last_col; prefer_next_row = false }
-      (if c.index + amt < 0 then 0
-       else if c.index + amt > max then max
-       else c.index + amt)
 
   let simple text ?(format = text_format_default) wrap_width :
-      layout_job =
+      layout_job Lwt.t =
+    TextBuffer.length text >>= fun textlen ->
+    Lwt.return
       {
-      (default_layout_job ()) with
+        (layout_job_of_text text) with
-      text;
         sections =
           Array.make 1
-          {
+            { leading_space = 0.0; byte_range = (0, textlen); format };
-            leading_space = 0.0;
-            byte_range = (0, Lwt_main.run (TextBuffer.length text));
-            format;
-          };
         wrap =
           { (default_text_wrapping ()) with max_width = wrap_width };
         break_on_newline = true;
       }
 
   let singleline (text : TextBuffer.t) (format : text_format) :
-      layout_job =
+      layout_job Lwt.t =
+    simple text ~format Float.infinity >>= fun simple ->
+    Lwt.return
       {
-      (simple text ~format Float.infinity) with
+        simple with
         wrap = default_text_wrapping ();
         break_on_newline = true;
       }
@@ -709,11 +718,12 @@ module TextLayout = struct
     }
 
   let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job)
-      (pos : v2) : galley =
+      (pos : v2) : galley Lwt.t =
     (* F.epr "TextLayout.layout@.";
        F.epr "job.wrap.max_width=%f@." job.wrap.max_widtha;
        F.epr "job.wrap.max_rows=%d@." job.wrap.max_rows; *)
     if job.wrap.max_rows == 0 then
+      Lwt.return
         {
           job;
           rows = Array.make 1 (row_default ());
@@ -727,10 +737,10 @@ module TextLayout = struct
     else
       let metrics = Gv.Text.metrics gv in
       let lines = Gv.Text.make_empty_rows job.wrap.max_rows in
+      TextBuffer.contents job.text >>= fun contents ->
       let row_count =
         Gv.Text.break_lines gv ~break_width:job.wrap.max_width
-          ~max_rows:job.wrap.max_rows ~lines
+          ~max_rows:job.wrap.max_rows ~lines contents
-          (Lwt_main.run (TextBuffer.contents job.text))
       in
       (* F.epr "row_count=%d@." row_count; *)
       let height = ref (V2.y pos) in
@@ -738,6 +748,7 @@ module TextLayout = struct
       let line_height =
         Option.value ~default:metrics.line_height job.line_height
       in
+      Lwt.return
         {
           job;
           rows =
@@ -867,7 +878,7 @@ module Ui = struct
     ref Option.None
 
   let keycallback t (state : Event.key_action) (key : Event.key)
-      (mods : Event.key_mod list) : unit =
+      (mods : Event.key_mod list) : bool Lwt.t =
     let res =
       match !callback_resolver with
       | Some res -> res
@@ -877,15 +888,11 @@ module Ui = struct
     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 ->
+          | Custom f :: actions -> f () >>= fun () -> exec actions
-                      f () >>= fun () -> exec actions
           | [] -> Lwt.return false
         in
         exec actions
@@ -894,16 +901,15 @@ module Ui = struct
         Lwt.return true
     | Event.Rejected ->
         callback_resolver := None;
-                Lwt.return false)
+        Lwt.return false
-            ())
 
   let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
     ref (fun c ->
         F.epr "chrcallback: '%a'@." pp_uchar c;
         Lwt.return_unit)
 
-  let chrcallback _t (chr : int) : unit =
+  let chrcallback _t (chr : int) : unit Lwt.t =
-    Lwt_main.run @@ !chrcallback_ref @@ Uchar.of_int chr
+    !chrcallback_ref @@ Uchar.of_int chr
 end
 
 module TextEdit = struct
@@ -931,6 +937,21 @@ module TextEdit = struct
     char_limit : int; (* return_key : keyboard_shortcut; *)
   }
 
+  let col t =
+    TextBuffer.fold_string t.text (fun s ->
+        Str.search_backward (Str.regexp "^") s t.cursor.index)
+
+  let cursor_move (t : t) (amt : int) : unit Lwt.t =
+    TextBuffer.fold_string t.text (fun s ->
+        let index' =
+          t.cursor.index + amt |> max 0 |> min (String.length s)
+        in
+        t.cursor <-
+          TextLayout.cursor
+            ~last_col:
+              (index' - Str.search_backward (Str.regexp "^") s index')
+            index')
+
   let add_bindings (t : t) (ui : Ui.t) : unit Lwt.t =
     let open GLFW in
     let open Event in
@@ -942,26 +963,13 @@ module TextEdit = struct
              [ Key (Press, F, [ Control ]) ];
              [ Key (Press, Right, []) ];
            ]
-           [
+           [ Custom (fun () -> cursor_move t 1) ]
-             Custom
-               (fun () ->
-                 TextBuffer.length t.text >>= fun textlen ->
-                 t.cursor <- TextLayout.cursor_move 1 textlen t.cursor;
-                 Lwt.return_unit);
-           ]
       |> adds
            [
              [ Key (Press, B, [ Control ]) ];
              [ Key (Press, Left, []) ];
            ]
-           [
+           [ Custom (fun () -> cursor_move t (-1)) ]
-             Custom
-               (fun () ->
-                 TextBuffer.length t.text >>= fun textlen ->
-                 t.cursor <-
-                   TextLayout.cursor_move (-1) textlen t.cursor;
-                 Lwt.return_unit);
-           ]
       |> adds
            [
              [ Key (Press, N, [ Control ]) ];
@@ -970,42 +978,73 @@ module TextEdit = struct
            [
              Custom
                (fun () ->
-                 TextBuffer.length t.text >>= fun textlen ->
+                 TextBuffer.fold_string t.text (fun s ->
+                     let sn = String.length s in
+                     let last_col = t.cursor.last_col in
+                     let seol = Str.search_forward (Str.regexp "$") in
+                     let bol =
+                       Str.search_backward (Str.regexp "^") s
+                         t.cursor.index
+                     in
+                     let eol = seol s t.cursor.index in
+                     let bol' = min sn eol + 1 in
+                     let eol' = seol s bol' in
+                     let next_line_len = eol' - bol' in
+                     F.epr
+                       "Down: index=%d last_col=%d eol=%d eol'=%d \
+                        bol=%d @."
+                       t.cursor.index last_col eol eol' bol;
                      t.cursor <-
-                   TextLayout.cursor_move 10 textlen t.cursor;
+                       {
-                 Lwt.return_unit);
+                         t.cursor with
+                         index =
+                           (bol'
+                           +
+                           if last_col > next_line_len then
+                             next_line_len
+                           else min next_line_len last_col);
+                       }));
            ]
       |> adds
            [
              [ Key (Press, P, [ Control ]) ]; [ Key (Press, Up, []) ];
            ]
-           [
+           [ Custom (fun () -> cursor_move t (-10)) ]
-             Custom
-               (fun () ->
-                 TextBuffer.length t.text >>= fun textlen ->
-                 t.cursor <-
-                   TextLayout.cursor_move (-10) textlen t.cursor;
-                 Lwt.return_unit);
-           ]
       |> adds
-           [ [ Key (Press, Backspace, []) ]; [ Key (Press, Up, []) ] ]
+           [ [ Key (Press, Backspace, []) ] ]
            [
              Custom
                (fun () ->
-                 TextBuffer.length t.text >>= fun textlen ->
+                 if t.cursor.index > 0 then (
-                 t.cursor <-
+                   TextBuffer.remove_uchar t.text (t.cursor.index - 1)
-                   TextLayout.cursor_move (-10) textlen t.cursor;
+                   >>= fun text ->
+                   t.text <- text;
+                   cursor_move t (-1))
+                 else Lwt.return_unit);
+           ]
+      |> adds (* EOL *)
+           [
+             [ Key (Press, E, [ Control ]) ]; [ Key (Press, End, []) ];
+           ]
+           [
+             Custom
+               (fun () ->
+                 TextBuffer.length t.text >>= fun _textlen ->
+                 TextBuffer.fold_string t.text (fun s ->
+                     Str.search_forward (Str.regexp "$") s
+                       t.cursor.index)
+                 >>= fun index ->
+                 t.cursor <- { t.cursor with index };
                  Lwt.return_unit);
            ];
+
     (* WARN XXX TKTK TODO this is probably "breaking" the lwt context and being used in other calls to Lwt_main.run *)
     (Ui.chrcallback_ref :=
        fun c ->
          TextBuffer.insert_uchar t.text t.cursor.index c
          >>= fun text ->
          t.text <- text;
-         TextBuffer.length t.text >>= fun textlen ->
+         cursor_move t 1
-         t.cursor <- TextLayout.cursor_move 1 textlen t.cursor;
-         Lwt.return_unit
        (* This creates a giant stack of calls lol
           >>= fun () -> !Ui.chrcallback_ref c *));
     Lwt.return_unit
@@ -1148,7 +1187,7 @@ module Painter = struct
   open Layout
   open Gg
 
-  let paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 =
+  let paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 Lwt.t =
     (* F.epr
          "Painter.galley (String.length g.job.text)=%d (Array.length \
           g.rows)=%d @."
@@ -1156,7 +1195,10 @@ module Painter = struct
          (Array.length g.rows);
        F.epr "g.job=%a@." TextLayout.pp_layout_job g.job;
          F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows; *)
-    Array.fold_left
+    TextBuffer.contents g.job.text >>= fun contents ->
+    let contents_len = String.length contents in
+    g.rows
+    |> Array.fold_left
          (fun (br : box2) (row : TextLayout.row) ->
            let sections =
              List.filter
@@ -1174,13 +1216,11 @@ module Painter = struct
              (List.fold_left
                 (fun x (sec : TextLayout.layout_section) ->
                   let start, end_ =
-                 ( min
+                    ( min (contents_len - 1)
-                     (Lwt_main.run (TextBuffer.length g.job.text) - 1)
                         (max 0
                            (max (fst sec.byte_range)
                               row.text_row.start_index)),
-                   min
+                      min (contents_len - 1)
-                     (Lwt_main.run (TextBuffer.length g.job.text) - 1)
                         (max 0
                            (min (snd sec.byte_range)
                               row.text_row.end_index)) )
@@ -1197,8 +1237,7 @@ module Painter = struct
                   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_
+                    Gv.Text.bounds t ~x ~y:0. ~start ~end_ contents
-                   (Lwt_main.run (TextBuffer.contents g.job.text))
                   in
                   Path.begin_ t;
                   Path.rect t ~x ~y:(Box2.miny row.rect)
@@ -1207,19 +1246,18 @@ module Painter = struct
                   fill t;
 
                   set_fill_color t ~color:sec.format.color;
-               let w =
+                  Text.text_w t ~x ~y:(Box2.miny row.rect) ~start
-                 Text.text_w t ~x ~y:(Box2.miny row.rect) ~start ~end_
+                    ~end_ contents)
-                   (Lwt_main.run (TextBuffer.contents g.job.text))
-               in
-               w)
                 (Box2.minx row.rect) sections);
            Box2.(union br row.rect))
-      Box2.empty g.rows
+         Box2.empty
+    |> Lwt.return
 
-  let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 =
+  let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t
+      =
     match frame.t with
     | `Box (dir, ll) ->
-        List.fold_left
+        Lwt_list.fold_left_s
           (fun (o : box2) f ->
             layout
               (match dir with
@@ -1240,18 +1278,15 @@ module Painter = struct
           | Some gv -> Fonts.{ gv; pixels_per_point = 1.0 }
           | None -> failwith "can't find font 'mono'"
         in
-        let layout_job =
+        (if t.multiline then
-          if t.multiline then
            TextLayout.simple t.text ~format:t.text_format
              (Option.value ~default:(Box2.w box) t.desired_width)
-          else TextLayout.singleline t.text t.text_format
+         else TextLayout.singleline t.text t.text_format)
-        in
+        >>= fun layout_job ->
-        let galley =
         Ui.fonts ui.gv (fun f ->
             TextLayout.layout f font
               (TextLayout.with_cursor t.cursor layout_job)
               (Box2.o box))
-        in
+        >>= fun galley -> paint_galley ui.gv galley
-        paint_galley ui.gv galley
+    | _ -> Lwt.return box
-    | _ -> box
 end

oplevel.ml

@@ -1,3 +1,4 @@
+open Lwt.Infix
 module F = Fmt
 open Tgles2
 module Gv = Graphv_gles2_native
@@ -84,27 +85,29 @@ let () =
   GLFW.setKeyCallback ~window
     ~f:
       (Some
-         Glfw_types.(
+         (fun _window key _int state mods ->
-           fun _window key int state mods ->
+           (* F.epr
-             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;
+              pp_key key int pp_key_action state pp_mods mods; *)
-             Ogui.Ui.keycallback ui state key mods))
+           Lwt.async (fun () ->
+               Ogui.Ui.keycallback ui state key mods >>= fun _ ->
+               Lwt.return_unit)))
   |> ignore;
 
   GLFW.setCharCallback ~window
     ~f:
       (Some
          (fun _window ch ->
-           let uc = Uchar.of_int ch in
+           (* 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);
+                  else None); *)
-
+           Lwt.async (fun () ->
-           Ogui.Ui.chrcallback ui ch))
+               Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit)))
   |> ignore;
 
   F.pr "oplevel.ml: building initial page@.";
@@ -156,7 +159,7 @@ let () =
          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 |> ignore;
+         Painter.layout box ui page >>= fun _ ->
          (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
          Gv.end_frame ctx;