console/oplevel
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

kill etc.

Browse Source
This commit is contained in:
cqc
2024-05-10 12:33:11 -05:00
parent 9641927e8a
commit a2c73ee1ad
2 changed files with 103 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files

105
ogui.ml
View File

@ -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;
if sn > n + uclen then
BytesLabels.blit_string ~src ~src_pos:n ~dst
~dst_pos:(n + uclen)
~len:(String.length src - (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,13 +1127,38 @@ module TextEdit = struct
[
Custom
(fun () ->
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)
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

2
oplevel.ml
View File

@ -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 ();