From a2c73ee1ad1356e9a679294b49c5b936c808af87 Mon Sep 17 00:00:00 2001 From: cqc Date: Fri, 10 May 2024 12:33:11 -0500 Subject: [PATCH] kill etc. --- ogui.ml | 119 +++++++++++++++++++++++++++++++++++++++++++++-------- oplevel.ml | 2 +- 2 files changed, 103 insertions(+), 18 deletions(-) diff --git a/ogui.ml b/ogui.ml index 015e4fc..822d7d4 100644 --- a/ogui.ml +++ b/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 - ~dst_pos:(n + uclen) - ~len:(String.length src - (n + 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 -> 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 ( - TextBuffer.remove_uchar t.text (t.cursor.index - 1) - >>= fun text -> - t.text <- text; - cursor_move t (-1)) - else Lwt.return_unit); + match t.mark with + | Some mark -> + TextBuffer.remove t.text (mark, t.cursor.index) + >>= fun text -> + t.text <- text; + 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 -> - TextLayout.layout f font - (TextLayout.with_cursor t.cursor layout_job) + Ui.fonts ui.gv (fun gv -> + TextLayout.layout gv font + (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 diff --git a/oplevel.ml b/oplevel.ml index 916aee4..73378fa 100644 --- a/oplevel.ml +++ b/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 ();