kill etc.

ogui.ml

@@ -35,7 +35,7 @@ let string_of_utf_8_uchar uc =
     contents b)
 
 let pp_uchar : Uchar.t F.t =
- fun ppf u -> F.pf ppf "%s" (string_of_utf_8_uchar u)
+ fun ppf u -> F.pf ppf "%S" (string_of_utf_8_uchar u)
 
 module Sense = struct
   type t = {
@@ -70,25 +70,44 @@ module TextBuffer = struct
 
   let insert_uchar t n uc : t Lwt.t =
     F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;
+
     match t with
     | { path; tree; _ } as tt ->
         Store.S.Tree.update tree path (function
           | Some src ->
-              assert (n <= String.length src);
+              let sn = String.length src in
+              assert (n <= sn);
               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
+              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;
-              BytesLabels.blit_string ~src ~src_pos:n ~dst
+              if sn > n + uclen then
-                ~dst_pos:(n + uclen)
+                BytesLabels.blit_string ~src ~src_pos:n ~dst
-                ~len:(String.length src - (n + uclen));
+                  ~dst_pos:(n + uclen)
+                  ~len:(sn - (n + uclen));
               Some (Bytes.to_string dst)
           | None -> None)
         >>= fun tree -> Lwt.return { tt with tree }
 
+  let remove t (a, b) : t Lwt.t =
+    let a, b = (min a b, max a b) in
+    F.epr "TextBuffer.remove (%d, %d)@." a b;
+    match t with
+    | { path; tree; _ } as tt ->
+        Store.S.Tree.update tree 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 tree -> Lwt.return { tt with tree }
+
   let remove_uchar t n : t Lwt.t =
     F.epr "TextBuffer.remove_subset n=%d @." n;
     match t with
@@ -669,11 +688,13 @@ module TextLayout = struct
   let default_cursor_formatter (f : text_format) =
     { f with background = !cursor_color }
 
-  let with_cursor (cur : cursor)
+  let default_mark_formatter (f : text_format) =
+    { f with background = Gv.Color.rgbf ~r:0.3 ~g:0.3 ~b:0.3 }
+
+  let with_range ((cs, ce) : int * int)
       ?(cursor_format = default_cursor_formatter) layout_job :
       layout_job =
     (* this is more like a general range application to layout sections, but i don't need it yet *)
-    let cs, ce = (cur.index, cur.index + 1) in
     {
       layout_job with
       sections =
@@ -717,6 +738,21 @@ module TextLayout = struct
              (Array.to_list layout_job.sections));
     }
 
+  let with_cursor (cur : cursor)
+      ?(cursor_format = default_cursor_formatter) layout_job :
+      layout_job =
+    with_range (cur.index, cur.index + 1) ~cursor_format layout_job
+
+  let with_mark (mark : int option) (cur : int)
+      ?(cursor_format = default_mark_formatter) layout_job :
+      layout_job =
+    match mark with
+    | Some mark' ->
+        with_range ~cursor_format
+          (min mark' cur, max mark' cur)
+          layout_job
+    | None -> layout_job
+
   let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job)
       (pos : v2) : galley Lwt.t =
     (* F.epr "TextLayout.layout@.";
@@ -918,6 +954,7 @@ module TextEdit = struct
   type t = {
     mutable text : TextBuffer.t;
     mutable cursor : TextLayout.cursor;
+    mutable mark : int option;
     id : id option;
     id_source : id option;
     text_format : TextLayout.text_format;
@@ -941,6 +978,15 @@ module TextEdit = struct
     TextBuffer.fold_string t.text (fun s ->
         Str.search_backward (Str.regexp "^") s t.cursor.index)
 
+  let cursor_set (t : t) (index : int) : unit Lwt.t =
+    TextBuffer.fold_string t.text (fun s ->
+        let index' = index |> max 0 |> min (String.length s) in
+        t.cursor <-
+          TextLayout.cursor
+            ~last_col:
+              (index' - Str.search_backward (Str.regexp "^") s index')
+            index')
+
   let cursor_move (t : t) (amt : int) : unit Lwt.t =
     TextBuffer.fold_string t.text (fun s ->
         let index' =
@@ -1081,12 +1127,37 @@ module TextEdit = struct
            [
              Custom
                (fun () ->
-                 if t.cursor.index > 0 then (
+                 match t.mark with
-                   TextBuffer.remove_uchar t.text (t.cursor.index - 1)
+                 | Some mark ->
-                   >>= fun text ->
+                     TextBuffer.remove t.text (mark, t.cursor.index)
-                   t.text <- text;
+                     >>= fun text ->
-                   cursor_move t (-1))
+                     t.text <- text;
-                 else Lwt.return_unit);
+                     t.mark <- None;
+                     cursor_set t (min mark t.cursor.index)
+                 | None ->
+                     if t.cursor.index > 0 then (
+                       TextBuffer.remove_uchar t.text
+                         (t.cursor.index - 1)
+                       >>= fun text ->
+                       t.text <- text;
+                       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
+                       ( t.cursor.index,
+                         Str.search_forward (Str.regexp "$") s
+                           t.cursor.index )
+                     >>= fun text ->
+                     t.text <- text;
+                     t.mark <- None;
+                     cursor_set t t.cursor.index)
+                 >>= fun u -> u);
            ]
       |> adds
            [ [ Key (Press, Enter, []) ]; [ Key (Repeat, Enter, []) ] ]
@@ -1098,6 +1169,17 @@ module TextEdit = struct
                  >>= fun text ->
                  t.text <- text;
                  cursor_move t 1);
+           ]
+      |> adds
+           [ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
+           [
+             Custom
+               (fun () ->
+                 t.mark <-
+                   (match t.mark with
+                   | Some _ -> None
+                   | None -> Some t.cursor.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 *)
@@ -1117,6 +1199,7 @@ module TextEdit = struct
       {
         text;
         cursor = TextLayout.cursor 0;
+        mark = None;
         id = None;
         id_source = None;
         text_format;
@@ -1345,9 +1428,11 @@ module Painter = struct
              (Option.value ~default:(Box2.w box) t.desired_width)
          else TextLayout.singleline t.text t.text_format)
         >>= fun layout_job ->
-        Ui.fonts ui.gv (fun f ->
+        Ui.fonts ui.gv (fun gv ->
-            TextLayout.layout f font
+            TextLayout.layout gv font
-              (TextLayout.with_cursor t.cursor layout_job)
+              (TextLayout.with_cursor t.cursor
+                 (TextLayout.with_mark t.mark t.cursor.index
+                    layout_job))
               (Box2.o box))
         >>= fun galley -> paint_galley ui.gv galley
     | _ -> Lwt.return box

oplevel.ml

@@ -53,7 +53,7 @@ let () =
   GLFW.makeContextCurrent ~window:(Some window);
   GLFW.swapInterval ~interval:0;
 
-  Gl.clear_color 0.3 0.3 0.32 1.;
+  Gl.clear_color 0.1 0.2 0.2 1.;
 
   Memtrace.trace_if_requested ();