From 46a08e011f525d0f9b956dcec324091c7c442971 Mon Sep 17 00:00:00 2001 From: cqc Date: Sat, 11 May 2024 23:26:15 -0500 Subject: [PATCH] more cleanup --- dune | 6 +- ogui.ml | 458 +++++++++++++++++++++++------------------------------ oplevel.ml | 40 +++-- 3 files changed, 229 insertions(+), 275 deletions(-) diff --git a/dune b/dune index 89f9adb..ef2aa88 100644 --- a/dune +++ b/dune @@ -26,11 +26,11 @@ graphv_gles2_native gg irmin-git - ; compiler-libs.toplevel + compiler-libs.toplevel re ) -; (link_flags (-linkall)) - ; (ocamlopt_flags (:standard -O3 -unboxed-types)) + (link_flags (-linkall)) + (ocamlopt_flags (:standard -O3 -unboxed-types)) (ocamlc_flags (:standard -verbose)) (modes byte) (preprocess diff --git a/ogui.ml b/ogui.ml index e51f4cc..c3ddbe1 100644 --- a/ogui.ml +++ b/ogui.ml @@ -379,7 +379,7 @@ module TextLayout = struct type font_selection = Default | FontId of (string * float) - type text_format = { + type format = { font_id : font_selection; extra_letter_spacing : float; line_height : float option; @@ -398,7 +398,7 @@ module TextLayout = struct overflow_character : string option; } - type section = { byte_range : int * int; format : text_format } + type section = { byte_range : int * int; format : format } type layout = { text : TextBuffer.t; @@ -411,7 +411,7 @@ module TextLayout = struct type cursor = { index : int; last_col : int } - let pp_text_format : text_format F.t = + let pp_format : format F.t = F.( record [ @@ -420,13 +420,13 @@ module TextLayout = struct (fun s -> s.extra_letter_spacing) float; field "line_height" - (fun (s : text_format) -> s.line_height) + (fun (s : format) -> s.line_height) (option float); field "color" (fun s -> s.color) pp_color; field "background" (fun s -> s.background) pp_color; ]) - let text_format_default = + let format_default = { font_id = FontId ("mono", 18.0); extra_letter_spacing = 0.0; @@ -439,8 +439,8 @@ module TextLayout = struct valign = Max; } - let text_format_simple font_id color : text_format = - { text_format_default with font_id; color } + let format_simple font_id color : format = + { format_default with font_id; color } let pp_text_wrapping = F.( @@ -470,11 +470,11 @@ module TextLayout = struct field "byte_range" (fun s -> s.byte_range) (pair ~sep:(any ",") int int); - field "format" (fun s -> s.format) pp_text_format; + field "format" (fun s -> s.format) pp_format; ]) let section_default = - { byte_range = (0, 0); format = text_format_default } + { byte_range = (0, 0); format = format_default } let pp_layout = F.( @@ -524,8 +524,8 @@ module TextLayout = struct row last_col index; { index; last_col } - let simple text ?(format = text_format_default) wrap_width : - layout Lwt.t = + let simple text ?(format = format_default) wrap_width : layout Lwt.t + = TextBuffer.length text >>= fun textlen -> Lwt.return { @@ -538,10 +538,10 @@ module TextLayout = struct let cursor_color = ref (Gv.Color.rgbf ~r:0.5 ~g:0.5 ~b:0.) - let default_cursor_formatter (f : text_format) = + let default_cursor_formatter (f : format) = { f with background = !cursor_color } - let default_mark_formatter (f : text_format) = + let default_mark_formatter (f : format) = { f with background = Gv.Color.rgbf ~r:0.3 ~g:0.3 ~b:0.3 } let with_range ((cs, ce) : int * int) @@ -710,6 +710,10 @@ module Ui = struct callback_resolver := None; Lwt.return false + let update_bindings ui + (f : action list Event.t -> action list Event.t) = + ui.bindings <- f ui.bindings + let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref = ref (fun c -> F.epr "chrcallback: '%a'@." pp_uchar c; @@ -728,7 +732,7 @@ module TextEdit = struct mutable mark : int option; id : id option; id_source : id option; - text_format : TextLayout.text_format; + text_format : TextLayout.format; formatter : (Ui.t -> TextBuffer.t -> float -> TextLayout.layout) option; password : bool; @@ -769,190 +773,197 @@ module TextEdit = struct (index' - Str.search_backward (Str.regexp "^") s index') index') - let add_bindings (t : t) (ui : Ui.t) : unit Lwt.t = + let default_bindings (t : t) (ui : Ui.t) : unit Lwt.t = let open GLFW in let open Event in let open Ui in - ui.bindings <- - empty - |> adds - [ - [ Key (Press, F, [ Control ]) ]; - [ Key (Repeat, F, [ Control ]) ]; - [ Key (Press, Right, []) ]; - [ Key (Repeat, Right, []) ]; - ] - [ Custom (fun () -> cursor_move t 1) ] - |> adds - [ - [ Key (Press, B, [ Control ]) ]; - [ Key (Repeat, B, [ Control ]) ]; - [ Key (Press, Left, []) ]; - [ Key (Repeat, Left, []) ]; - ] - [ Custom (fun () -> cursor_move t (-1)) ] - |> adds - [ - [ Key (Press, N, [ Control ]) ]; - [ Key (Repeat, N, [ Control ]) ]; - [ Key (Press, Down, []) ]; - [ Key (Repeat, Down, []) ]; - ] - [ - Custom - (fun () -> - TextBuffer.fold_string t.text (fun s -> - let sn = String.length s in - let seol = Str.search_forward (Str.regexp "$") in - let next_bol = - min sn (seol s t.cursor.index + 1) - in - let next_line_len = seol s next_bol - next_bol in - (* F.epr - "Down: index=%d last_col=%d eol=%d eol'=%d \ - bol=%d @." - t.cursor.index last_col eol' bol; *) - t.cursor <- - { - t.cursor with - index = - (next_bol - + - if t.cursor.last_col > next_line_len then - next_line_len - else min next_line_len t.cursor.last_col); - })); - ] - |> adds - [ - [ Key (Press, P, [ Control ]) ]; - [ Key (Repeat, P, [ Control ]) ]; - [ Key (Press, Up, []) ]; - [ Key (Repeat, Up, []) ]; - ] - [ - Custom - (fun () -> - TextBuffer.fold_string t.text (fun s -> - let sbol = - Str.search_backward (Str.regexp "^") s - in - let bol = sbol t.cursor.index in - if bol > 0 then ( - let prev_bol = sbol (max 0 (bol - 1)) in - let prev_line_len = bol - 1 - prev_bol in - F.epr - "up: index=%d bol=%d prev_bol=%d \ - prev_line_len=%d @." - t.cursor.index bol prev_bol prev_line_len; + Ui.update_bindings ui (fun a -> + a + |> adds + [ + [ Key (Press, F, [ Control ]) ]; + [ Key (Repeat, F, [ Control ]) ]; + [ Key (Press, Right, []) ]; + [ Key (Repeat, Right, []) ]; + ] + [ Custom (fun () -> cursor_move t 1) ] + |> adds + [ + [ Key (Press, B, [ Control ]) ]; + [ Key (Repeat, B, [ Control ]) ]; + [ Key (Press, Left, []) ]; + [ Key (Repeat, Left, []) ]; + ] + [ Custom (fun () -> cursor_move t (-1)) ] + |> adds + [ + [ Key (Press, N, [ Control ]) ]; + [ Key (Repeat, N, [ Control ]) ]; + [ Key (Press, Down, []) ]; + [ Key (Repeat, Down, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.fold_string t.text (fun s -> + let sn = String.length s in + let seol = + Str.search_forward (Str.regexp "$") + in + let next_bol = + min sn (seol s t.cursor.index + 1) + in + let next_line_len = + seol s next_bol - next_bol + in + (* F.epr + "Down: index=%d last_col=%d eol=%d eol'=%d \ + bol=%d @." + t.cursor.index last_col eol' bol; *) t.cursor <- { t.cursor with index = - (prev_bol + (next_bol + - if t.cursor.last_col > prev_line_len then - prev_line_len - else min prev_line_len t.cursor.last_col + if t.cursor.last_col > next_line_len then + next_line_len + else min next_line_len t.cursor.last_col ); - }))); - ] - |> adds (* EOL *) - [ - [ Key (Press, E, [ Control ]) ]; [ Key (Press, End, []) ]; - ] - [ - Custom - (fun () -> - TextBuffer.fold_string t.text (fun s -> - let bol = - Str.search_backward (Str.regexp "^") s - t.cursor.index - in - let eol = - Str.search_forward (Str.regexp "$") s - t.cursor.index - in - t.cursor <- - TextLayout.cursor ~last_col:(eol - bol) eol)); - ] - |> adds (* BOL *) - [ - [ Key (Press, A, [ Control ]) ]; - [ Key (Press, Home, []) ]; - ] - [ - Custom - (fun () -> - TextBuffer.fold_string t.text (fun s -> - t.cursor <- - TextLayout.cursor ~last_col:0 - (Str.search_backward (Str.regexp "^") s - t.cursor.index))); - ] - |> adds - [ - [ Key (Press, Backspace, []) ]; - [ Key (Repeat, Backspace, []) ]; - ] - [ - 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) + })); + ] + |> adds + [ + [ Key (Press, P, [ Control ]) ]; + [ Key (Repeat, P, [ Control ]) ]; + [ Key (Press, Up, []) ]; + [ Key (Repeat, Up, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.fold_string t.text (fun s -> + let sbol = + Str.search_backward (Str.regexp "^") s + in + let bol = sbol t.cursor.index in + if bol > 0 then ( + let prev_bol = sbol (max 0 (bol - 1)) in + let prev_line_len = bol - 1 - prev_bol in + F.epr + "up: index=%d bol=%d prev_bol=%d \ + prev_line_len=%d @." + t.cursor.index bol prev_bol prev_line_len; + t.cursor <- + { + t.cursor with + index = + (prev_bol + + + if t.cursor.last_col > prev_line_len + then prev_line_len + else + min prev_line_len t.cursor.last_col); + }))); + ] + |> adds (* EOL *) + [ + [ Key (Press, E, [ Control ]) ]; + [ Key (Press, End, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.fold_string t.text (fun s -> + let bol = + Str.search_backward (Str.regexp "^") s + t.cursor.index + in + let eol = + Str.search_forward (Str.regexp "$") s + t.cursor.index + in + t.cursor <- + TextLayout.cursor ~last_col:(eol - bol) eol)); + ] + |> adds (* BOL *) + [ + [ Key (Press, A, [ Control ]) ]; + [ Key (Press, Home, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.fold_string t.text (fun s -> + t.cursor <- + TextLayout.cursor ~last_col:0 + (Str.search_backward (Str.regexp "^") s + t.cursor.index))); + ] + |> adds + [ + [ Key (Press, Backspace, []) ]; + [ Key (Repeat, Backspace, []) ]; + ] + [ + Custom + (fun () -> + match t.mark with + | Some mark -> + TextBuffer.remove t.text (mark, t.cursor.index) >>= 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, []) ] ] - [ - Custom - (fun () -> - TextBuffer.insert_uchar t.text t.cursor.index - (Uchar.of_char '\n') - >>= 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); - ]; - + 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, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.insert_uchar t.text t.cursor.index + (Uchar.of_char '\n') + >>= 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 *) (Ui.chrcallback_ref := fun c -> @@ -964,7 +975,7 @@ module TextEdit = struct >>= fun () -> !Ui.chrcallback_ref c *)); Lwt.return_unit - let multiline ui ?(text_format = TextLayout.text_format_default) + let multiline ui ?(text_format = TextLayout.format_default) (text : TextBuffer.t) : t = let t = { @@ -990,75 +1001,8 @@ module TextEdit = struct (* return_key = keyboard_shortcut; *) } in - Lwt_main.run (add_bindings t ui); + Lwt_main.run (default_bindings t ui); t - - (* - 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 *) - let available_width = - Ui.available_width ui -. (t.margin.left +. t.margin.right) - in - let desired_width = - Option.fold ~none:(Ui.spacing ui).text_edit_width ~some:Fun.id - t.desired_width - in - let wrap_width = - if Layout.horizontal_justify ui.placer.layout then - available_width - else Float.min desired_width available_width - in - let galley_size = galley.mesh_bounds in - let desired_width = - if t.clip_text then wrap_width - else Float.max (Size2.w (Box2.size galley_size)) wrap_width - in - let desired_inner_size = - V2.v desired_width (Box2.maxy galley_size) - in - let desired_outer_size = - V2.(desired_inner_size + Margin.sum t.margin) - in - let (_auto_id, outer_rect) : id * box2 = - Ui.allocate_space ui.gv (Box2.v origin desired_outer_size) - in - let rect = Margin.inner t.margin outer_rect in - (* TODO id = ui.make_persistent_id(id_source) else auto_id *) - (* 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 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 *) - let cursor_range = None in - (* TODO cursor_range *) - let galley_pos = - Align.size_within_rect (Box2.size galley_size) rect - in - - (* if Ui.is_rect_visible ui rect then *) - (* Painter.galley ui.gv galley; *) - let _align_offset = rect in - { - galley; - galley_pos = Box2.o galley_pos; - text_clip_rect; - state; - cursor_range; - } - let show (t : t) ui : output = - let _margin = t.margin in - let output = show_content t ui in - (* let _outer_rect = output.response.rect in *) - output - *) end module Layout = struct @@ -1177,7 +1121,7 @@ module Painter = struct stroke t); fill t - let set_text_format (t : Gv.t) (format : TextLayout.text_format) = + let set_text_format (t : Gv.t) (format : TextLayout.format) = let font_name, font_size = match format.font_id with | Default -> ("mono", 18.) diff --git a/oplevel.ml b/oplevel.ml index d662145..36a2182 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -70,8 +70,8 @@ let () = (* Thread which is woken up when the main window is closed. *) let _waiter, _wakener = Lwt.wait () in - (* F.pr "oplevel.ml: Toploop.initialize_toplevel_env@."; - Toploop.initialize_toplevel_env (); *) + F.pr "oplevel.ml: Toploop.initialize_toplevel_env@."; + Toploop.initialize_toplevel_env (); let rootrepo = Store.init_default (F.str "%s/console/rootstore.git" Secrets.giturl) @@ -100,20 +100,30 @@ let () = F.pr "oplevel.ml: building initial page@."; let page = - Layout.( - vbox - [ - textedit - (TextEdit.multiline ui - (TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo)); - textedit - (TextEdit.multiline ui - (TextBuffer.of_repo - ~path:[ ".config"; "init.ml" ] - ~repo:rootrepo)); - ]) + ref + Layout.( + vbox + [ + textedit + (TextEdit.multiline ui + (TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo)); + textedit + (TextEdit.multiline ui + (TextBuffer.of_repo + ~path:[ ".config"; "init.ml" ] + ~repo:rootrepo)); + ]) in + (let open GLFW in + let open Event in + let open Ui in + update_bindings ui + (adds + [ + [ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ]; + ] + [ Custom (fun () -> Lwt.return ()) ])); F.pr "oplevel.ml: entering drawing loop@."; let period_min = 1.0 /. 30. in let t = GLFW.getTime () |> ref in @@ -149,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 >>= fun _ -> + Painter.layout box ui !page >>= fun _ -> (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *) Gv.end_frame ctx;