From d5c74b2ceba3c269e88ba0893b5de987f0944818 Mon Sep 17 00:00:00 2001 From: cqc Date: Sun, 28 Apr 2024 12:30:57 -0500 Subject: [PATCH] events --- dune | 2 +- ogui.ml | 564 ++++++++++++++++++++++++++++++++++++----------------- oplevel.ml | 218 ++++----------------- 3 files changed, 425 insertions(+), 359 deletions(-) diff --git a/dune b/dune index 0f25300..ad9fa14 100644 --- a/dune +++ b/dune @@ -15,7 +15,7 @@ (executables (names oplevel) - (modules oplevel secrets perfgraph ogui) + (modules oplevel secrets perfgraph ogui glfw_types) (libraries lwt store diff --git a/ogui.ml b/ogui.ml index e1a683f..8401f93 100644 --- a/ogui.ml +++ b/ogui.ml @@ -1,3 +1,4 @@ +open Lwt.Infix module Gv = Graphv_gles2_native module F = Fmt @@ -26,6 +27,15 @@ end type margin = Margin.t +let string_of_utf_8_uchar uc = + Buffer.( + let b = create 4 in + add_utf_8_uchar b uc; + contents b) + +let pp_uchar : Uchar.t F.t = + fun ppf u -> F.pf ppf "%s" (string_of_utf_8_uchar u) + module Sense = struct type t = { click : bool; @@ -41,25 +51,195 @@ module Sense = struct { click = false; drag = false; focusable = true; edit = false } end -module EventFilter = struct - type t = { - tab : bool; - horizontal_arrrows : bool; - vertical_arrows : bool; - escape : bool; - } +module TextBuffer = struct + 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 default = - { - tab = false; - horizontal_arrrows = false; - vertical_arrows = false; - escape = false; - } + let of_repo ~path ~(repo : Store.Sync.db) = + let tree = Lwt_main.run ((fun () -> Store.S.tree repo) ()) in + Tree { path; tree; repo } + + let buffer ~name ~buf = Buffer { name; buf } + + let insert_uchar t n uc : t Lwt.t = + F.epr "TextBuffer.insert_uchar %d %s" n (string_of_utf_8_uchar uc); + match t with + | Tree ({ path; tree; _ } as tt) -> + Store.S.Tree.update tree path (function + | Some src -> + assert (n <= String.length src); + 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 + 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)); + Some (Bytes.to_string dst) + | None -> None) + >>= fun tree -> Lwt.return (Tree { 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 + | Tree { path; tree; _ } -> + (try Store.S.Tree.get tree path with + | Not_found | Invalid_argument _ -> + Lwt.return + @@ F.str + "print_newline \"/%s: Not_found | \ + Invalid_argument\";;" + (String.concat "/" path) + | exc -> + Lwt.return + (F.str "Store.S.Tree.get /%s exception: %s" + (String.concat "/" path) + (Printexc.to_string exc))) + >>= fun text -> Lwt.return text + | Buffer { buf; _ } -> Lwt.return (Buffer.contents buf) + + let length = function + | 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 + type key_action = GLFW.key_action + type key = GLFW.key + type key_mod = GLFW.key_mod + type event = Key of key_action * key * key_mod list + + (* Stolen from zed_input.ml *) + module EventMap = Map.Make (struct + type t = event + + let compare = compare + end) + + type 'a t = 'a node EventMap.t + and 'a node = Set of 'a t | Val of 'a + + let empty = EventMap.empty + + let rec add (events : event list) value set = + match events with + | [] -> invalid_arg "Event.add" + | [ event ] -> EventMap.add event (Val value) set + | event :: events -> ( + match + try Some (EventMap.find event set) with Not_found -> None + with + | None | Some (Val _) -> + EventMap.add event (Set (add events value empty)) set + | Some (Set s) -> + EventMap.add event (Set (add events value s)) set) + + let rec adds (events : event list list) value set = + List.fold_left (fun s e -> add e value s) set events + + let rec remove events set = + match events with + | [] -> invalid_arg "Event.remove" + | [ event ] -> EventMap.remove event set + | event :: events -> ( + match + try Some (EventMap.find event set) with Not_found -> None + with + | None | Some (Val _) -> set + | Some (Set s) -> + let s = remove events s in + if EventMap.is_empty s then EventMap.remove event set + else EventMap.add event (Set s) set) + + let fold f set acc = + let rec loop prefix set acc = + EventMap.fold + (fun event node acc -> + match node with + | Val v -> f (List.rev (event :: prefix)) v acc + | Set s -> loop (event :: prefix) s acc) + set acc + in + loop [] set acc + + let bindings set = + List.rev + (fold (fun events action l -> (events, action) :: l) set []) + + module type Pack = sig + type a + type b + + val set : a t + val map : a -> b + end + + type 'a pack = (module Pack with type b = 'a) + type 'a resolver = 'a pack list + + let pack (type u v) map set = + let module Pack = struct + type a = u + type b = v + + let set = set + let map = map + end in + (module Pack : Pack with type b = v) + + let resolver l = l + + type 'a result = + | Accepted of 'a + | Continue of 'a resolver + | Rejected + + let rec resolve_rec : + 'a. event -> 'a pack list -> 'a pack list -> 'a result = + fun (type u) event acc packs -> + match packs with + | [] -> if acc = [] then Rejected else Continue (List.rev acc) + | p :: packs -> ( + let module Pack = (val p : Pack with type b = u) in + match + try Some (EventMap.find event Pack.set) + with Not_found -> None + with + | Some (Set set) -> + resolve_rec event (pack Pack.map set :: acc) packs + | Some (Val v) -> Accepted (Pack.map v) + | None -> resolve_rec event acc packs) + + let resolve event sets = resolve_rec event [] sets + + include Glfw_types + + let pp_event : event F.t = + fun ppf e -> + let open Glfw_types in + match e with + | Key (a, k, m) -> + F.pf ppf "Key %a, %a, %a" pp_key_action a pp_key k pp_mods m + (* | Char u -> F.pf ppf "Char %a" pp_uchar u + | AnyChar -> F.pf ppf "AnyChar" *) +end + +type event = Event.event type id = int -type event_filter = EventFilter.t module Context = struct type t = { derp : bool } @@ -250,7 +430,7 @@ module TextLayout = struct } type layout_job = { - text : string; + text : TextBuffer.t; sections : layout_section array; wrap : text_wrapping; first_row_min_height : float; @@ -264,7 +444,9 @@ module TextLayout = struct F.( record [ - field "text" (fun s -> String.length s.text) int; + field "text" + (fun s -> Lwt_main.run (TextBuffer.length s.text)) + int; field "sections" (fun s -> s.sections) (array pp_layout_section); @@ -279,7 +461,9 @@ module TextLayout = struct let default_layout_job () = { - 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; @@ -461,6 +645,7 @@ module TextLayout = struct match c with | Some (a, b) -> let a', b' = f a.index b.index in + F.epr "cursor_state_update %d %d@." a' b'; Some (new_cursor_range (max a' 0, max b' 0)) | None -> None @@ -473,7 +658,7 @@ module TextLayout = struct Array.make 1 { leading_space = 0.0; - byte_range = (0, String.length text); + byte_range = (0, Lwt_main.run (TextBuffer.length text)); format; }; wrap = @@ -481,7 +666,8 @@ module TextLayout = struct break_on_newline = true; } - let simple text (format : text_format) wrap_width : layout_job = + let simple (text : TextBuffer.t) (format : text_format) wrap_width : + layout_job = { (default_layout_job ()) with text; @@ -489,7 +675,7 @@ module TextLayout = struct Array.make 1 { leading_space = 0.0; - byte_range = (0, String.length text); + byte_range = (0, Lwt_main.run (TextBuffer.length text)); format; }; wrap = @@ -497,7 +683,8 @@ module TextLayout = struct break_on_newline = true; } - let simple_singleline text (format : text_format) : layout_job = + let simple_singleline (text : TextBuffer.t) (format : text_format) : + layout_job = { (default_layout_job ()) with text; @@ -505,7 +692,7 @@ module TextLayout = struct Array.make 1 { leading_space = 0.0; - byte_range = (0, String.length text); + byte_range = (0, Lwt_main.run (TextBuffer.length text)); format; }; wrap = default_text_wrapping (); @@ -585,7 +772,8 @@ module TextLayout = struct let lines = Gv.Text.make_empty_rows job.wrap.max_rows in let row_count = Gv.Text.break_lines gv ~break_width:job.wrap.max_width - ~max_rows:job.wrap.max_rows ~lines job.text + ~max_rows:job.wrap.max_rows ~lines + (Lwt_main.run (TextBuffer.contents job.text)) in (* F.epr "row_count=%d@." row_count; *) let height = ref (V2.y pos) in @@ -654,62 +842,64 @@ module Painter = struct (* F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows;*) Array.iter - Gv.( - fun (row : TextLayout.row) -> - let sections = - List.filter - (fun (r : TextLayout.layout_section) -> - fst r.byte_range <= row.text_row.end_index - && snd r.byte_range > row.text_row.start_index) - (Array.to_list - @@ Array.sub g.job.sections row.section_index_at_start - (Array.length g.job.sections - - row.section_index_at_start)) - in - assert (List.length sections > 0); + (fun (row : TextLayout.row) -> + let sections = + List.filter + (fun (r : TextLayout.layout_section) -> + fst r.byte_range <= row.text_row.end_index + && snd r.byte_range > row.text_row.start_index) + (Array.to_list + @@ Array.sub g.job.sections row.section_index_at_start + (Array.length g.job.sections + - row.section_index_at_start)) + in + assert (List.length sections > 0); - ignore - Gg.( - List.fold_left - (fun x (sec : TextLayout.layout_section) -> - let start, end_ = - ( min - (String.length g.job.text - 1) - (max 0 - (max (fst sec.byte_range) - row.text_row.start_index)), - min - (String.length g.job.text - 1) - (max 0 - (min (snd sec.byte_range) - row.text_row.end_index)) ) - in + ignore + Gg.( + List.fold_left + (fun x (sec : TextLayout.layout_section) -> + let start, end_ = + ( min + (Lwt_main.run (TextBuffer.length g.job.text) - 1) + (max 0 + (max (fst sec.byte_range) + row.text_row.start_index)), + min + (Lwt_main.run (TextBuffer.length g.job.text) - 1) + (max 0 + (min (snd sec.byte_range) + row.text_row.end_index)) ) + in - let font_name, font_size = - match sec.format.font_id with - | Default -> ("mono", 18.) - | FontId (s, size) -> (s, size) - in - Text.set_font_face t ~name:font_name; - Text.set_size t ~size:font_size; - 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_ g.job.text - in - Path.begin_ t; - Path.rect t ~x ~y:(Box2.miny row.rect) - ~w:bounds.advance ~h:metrics.line_height; - set_fill_color t ~color:sec.format.background; - fill t; + let font_name, font_size = + match sec.format.font_id with + | Default -> ("mono", 18.) + | FontId (s, size) -> (s, size) + in + let open Gv in + Text.set_font_face t ~name:font_name; + Text.set_size t ~size:font_size; + 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_ + (Lwt_main.run (TextBuffer.contents g.job.text)) + in + Path.begin_ t; + Path.rect t ~x ~y:(Box2.miny row.rect) + ~w:bounds.advance ~h:metrics.line_height; + set_fill_color t ~color:sec.format.background; + fill t; - set_fill_color t ~color:sec.format.color; - let w = - Text.text_w t ~x ~y:(Box2.miny row.rect) ~start - ~end_ g.job.text - in - w) - (Box2.minx row.rect) sections)) + set_fill_color t ~color:sec.format.color; + let w = + Text.text_w t ~x ~y:(Box2.miny row.rect) ~start + ~end_ + (Lwt_main.run (TextBuffer.contents g.job.text)) + in + w) + (Box2.minx row.rect) sections)) g.rows end @@ -877,25 +1067,18 @@ module Placer = struct end module Ui = struct - type key_callback = - t -> - GLFW.window -> - GLFW.key -> - int -> - GLFW.key_action -> - GLFW.key_mod list -> - unit - - and t = { + type t = { id : id; style : Style.t; placer : Placer.t; enabled : bool; gv : Gv.t; glfw_window : GLFW.window option; - mutable key : key_callback; + mutable bindings : action list Event.t; } + and action = Custom of (unit -> unit Lwt.t) + let id = ref 0 let spacing ui = ui.style.spacing let available_size ui = Placer.available_size ui.placer @@ -907,7 +1090,6 @@ module Ui = struct (!id, size) let cursor_origin (ui : t) = Gg.Box2.o ui.placer.region.max_rect - let key_callback_default _ _ _ _ _ _ = () let window gv ?(window : GLFW.window option) rect : t = let id, rect = allocate_space gv rect in @@ -920,56 +1102,53 @@ module Ui = struct enabled = true; gv; glfw_window = window; - key = key_callback_default; + bindings = Event.empty; } - let keycallback t window key int state mods : unit = - t.key t window key int state mods + let callback_resolver : action list Event.resolver option ref = + ref Option.None - let add_key_callback (t : t) ~(f : key_callback) : unit = - let g = t.key in - t.key <- - (fun a1 a2 a3 a4 a5 a6 -> - f a1 a2 a3 a4 a5 a6; - g a1 a2 a3 a4 a5 a6) + let keycallback t key state mods : unit = + let res = + match !callback_resolver with + | Some res -> res + | None -> Event.resolver [ Event.pack Fun.id t.bindings ] + in - let interact (_ui : t) rect (id : id option) sense : Response.t = - let id = Option.value id ~default:(-1) in - { - ctx = { derp = false }; - id; - rect; - interact_rect = rect; - sense; - enabled = true; - contains_pointer = (*TODO*) true; - hovered = (*TODO*) true; - highlighted = (*TODO*) true; - clicked = (*TODO*) true; - fake_primary_click = (*TODO*) false; - long_touched = (*TODO*) false; - drag_started = false; - dragged = false; - drag_stopped = false; - is_pointer_button_down_on = false; - interact_pointer_pos = None; - changed = false; - } -end + ignore + @@ Lwt_main.run + ((fun () : bool Lwt.t -> + match Event.resolve (Key (key, state, mods)) res with + | Event.Accepted actions -> + callback_resolver := None; + let rec exec : action list -> bool Lwt.t = function + | Custom f :: actions -> + f () >>= fun () -> exec actions + | [] -> Lwt.return false + in + exec actions + | Event.Continue res -> + callback_resolver := Some res; + Lwt.return true + | Event.Rejected -> + callback_resolver := None; + Lwt.return false) + ()) -module TextBuffer = struct - type t = String of string + let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref = + ref (fun c -> + F.epr "chrcallback: '%a'@." pp_uchar c; + Lwt.return_unit) - let is_mutable = function String _ -> true - let as_string = function String s -> s + let chrcallback _t (chr : int) : unit = + Lwt_main.run @@ !chrcallback_ref @@ Uchar.of_int chr end module TextEdit = struct open Gg type t = { - text : TextBuffer.t; - hint_text : TextLayout.widget_text; + mutable text : TextBuffer.t; id : id option; id_source : id option; text_format : TextLayout.text_format; @@ -982,7 +1161,6 @@ module TextEdit = struct interactive : bool; desired_width : float option; desired_height_rows : int; - event_filter : event_filter; cursor_at_end : bool; min_size : Gg.v2; align : align; @@ -990,7 +1168,7 @@ module TextEdit = struct char_limit : int; (* return_key : keyboard_shortcut; *) } - type state = { + and state = { mutable cursor : TextLayout.cursor_state; (* undoer : undoer; *) singleline_offset : float; @@ -999,27 +1177,80 @@ module TextEdit = struct let state_mem : (int * state) list ref = ref [] - let process_key (state : state) (key : GLFW.key) - (action : GLFW.key_action) (mods : GLFW.key_mod list) : unit = + let add_bindings (t : t) (ui : Ui.t) (state : state) : unit Lwt.t = let open GLFW in - match (action, key, mods) with - | Press, F, [ Control ] | Press, Right, [] -> - state.cursor <- - TextLayout.cursor_state_update - ~f:(fun a b -> - F.epr "cursor_state_update %d %d@." a b; - (a + 1, b + 1)) - state.cursor - | Press, B, [ Control ] | Press, Left, [] -> - state.cursor <- - TextLayout.cursor_state_update - ~f:(fun a b -> - F.epr "cursor_state_update %d %d@." a b; - (a - 1, b - 1)) - state.cursor - | _ -> () + let open Event in + let open Ui in + ui.bindings <- + empty + |> adds + [ + [ Key (Press, F, [ Control ]) ]; + [ Key (Press, Right, []) ]; + ] + [ + Custom + (fun () -> + state.cursor <- + TextLayout.cursor_state_update + ~f:(fun a b -> (a + 1, b + 1)) + state.cursor; + Lwt.return_unit); + ] + |> adds + [ + [ Key (Press, B, [ Control ]) ]; + [ Key (Press, Left, []) ]; + ] + [ + Custom + (fun () -> + state.cursor <- + TextLayout.cursor_state_update + ~f:(fun a b -> (a - 1, b - 1)) + state.cursor; + Lwt.return_unit); + ] + |> adds + [ + [ Key (Press, N, [ Control ]) ]; + [ Key (Press, Down, []) ]; + ] + [ + Custom + (fun () -> + state.cursor <- + TextLayout.cursor_state_update + ~f:(fun a b -> (a - 1, b - 1)) + state.cursor; + Lwt.return_unit); + ] + |> adds + [ + [ Key (Press, P, [ Control ]) ]; [ Key (Press, Up, []) ]; + ] + [ + Custom + (fun () -> + state.cursor <- + TextLayout.cursor_state_update + ~f:(fun a b -> (a - 1, b - 1)) + state.cursor; + 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 -> + (match state.cursor with + | Some (_a, b) -> + TextBuffer.insert_uchar t.text b.index c >>= fun text -> + t.text <- text; + Lwt.return_unit + | None -> Lwt.return_unit) + >>= fun () -> !Ui.chrcallback_ref c); + Lwt.return_unit - let load_state ui id = + let load_state id = match List.assoc_opt id !state_mem with | Some state -> state | None -> @@ -1031,14 +1262,10 @@ module TextEdit = struct } in state_mem := (id, state) :: !state_mem; - (* We use this as the one shot for registering keyboard shortcuts - since they just operate on the state *) - Ui.add_key_callback ui ~f:(fun _ _ key _ action mods -> - process_key state key action mods); state type output = { - response : Response.t; + (* response : Response.t; *) galley : TextLayout.galley; galley_pos : Gg.p2; text_clip_rect : Gg.box2; @@ -1050,7 +1277,6 @@ module TextEdit = struct (text : TextBuffer.t) : t = { text; - hint_text = RichText TextLayout.rich_text_default; id = None; id_source = None; text_format; @@ -1062,13 +1288,6 @@ module TextEdit = struct interactive = true; desired_width = None; desired_height_rows = 4; - event_filter = - { - EventFilter.default with - horizontal_arrrows = true; - vertical_arrows = true; - tab = false; - }; cursor_at_end = true; min_size = Gg.V2.zero; align = Min; @@ -1078,6 +1297,7 @@ module TextEdit = struct } let show_content (t : t) (ui : Ui.t) : output = + let state = load_state (Option.value ~default:(-1) t.id) in 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 *) @@ -1093,23 +1313,17 @@ module TextEdit = struct available_width else Float.min desired_width available_width in - let state = load_state ui (Option.value ~default:(-1) t.id) in let default_layouter (ui : Ui.t) (text : TextBuffer.t) (wrap_width : size1) : TextLayout.galley = let font = match Gv.Text.find_font ui.gv ~name:"mono" with | Some gv -> Fonts.{ gv; pixels_per_point = 1.0 } - | None -> failwith "can't font font 'mono'" + | None -> failwith "can't find font 'mono'" in let layout_job = if t.multiline then - TextLayout.simple - (TextBuffer.as_string text) - t.text_format wrap_width - else - TextLayout.simple_singleline - (TextBuffer.as_string text) - t.text_format + TextLayout.simple text t.text_format wrap_width + else TextLayout.simple_singleline text t.text_format in let layout_job = TextLayout.with_cursor @@ -1145,9 +1359,9 @@ module TextEdit = struct (* 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 _sense = if t.interactive then Sense.click else Sense.hover in - let response = Ui.interact ui outer_rect t.id sense 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 *) @@ -1162,7 +1376,6 @@ module TextEdit = struct let _align_offset = rect in { - response; galley; galley_pos = Box2.o galley_pos; text_clip_rect; @@ -1171,11 +1384,8 @@ module TextEdit = struct } let show (t : t) ui : output = - let _is_mutable = TextBuffer.is_mutable t.text in - let _frame = t.frame in - let _margin = t.margin in let output = show_content t ui in - let _outer_rect = output.response.rect in + (* let _outer_rect = output.response.rect in *) output end diff --git a/oplevel.ml b/oplevel.ml index 3c00358..eda0f02 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -1,4 +1,3 @@ -open Lwt.Infix module F = Fmt open Tgles2 module Gv = Graphv_gles2_native @@ -37,153 +36,6 @@ let load_data vg = Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji"; Gv.Text.set_font_face vg ~name:"mono" -let pp_glfw_key : GLFW.key F.t = - fun ppf k -> - F.pf ppf - GLFW.( - match k with - | Unknown -> "Unknown" - | Space -> "Space" - | Apostrophe -> "Apostrophe" - | Comma -> "Comma" - | Minus -> "Minus" - | Period -> "Period" - | Slash -> "Slash" - | Num0 -> "Num0" - | Num1 -> "Num1" - | Num2 -> "Num2" - | Num3 -> "Num3" - | Num4 -> "Num4" - | Num5 -> "Num5" - | Num6 -> "Num6" - | Num7 -> "Num7" - | Num8 -> "Num8" - | Num9 -> "Num9" - | Semicolon -> "Semicolon" - | Equal -> "Equal" - | A -> "A" - | B -> "B" - | C -> "C" - | D -> "D" - | E -> "E" - | F -> "F" - | G -> "G" - | H -> "H" - | I -> "I" - | J -> "J" - | K -> "K" - | L -> "L" - | M -> "M" - | N -> "N" - | O -> "O" - | P -> "P" - | Q -> "Q" - | R -> "R" - | S -> "S" - | T -> "T" - | U -> "U" - | V -> "V" - | W -> "W" - | X -> "X" - | Y -> "Y" - | Z -> "Z" - | LeftBracket -> "LeftBracket" - | Backslash -> "Backslash" - | RightBracket -> "RightBracket" - | GraveAccent -> "GraveAccent" - | World1 -> "World1" - | World2 -> "World2" - | Escape -> "Escape" - | Enter -> "Enter" - | Tab -> "Tab" - | Backspace -> "Backspace" - | Insert -> "Insert" - | Delete -> "Delete" - | Right -> "Right" - | Left -> "Left" - | Down -> "Down" - | Up -> "Up" - | PageUp -> "PageUp" - | PageDown -> "PageDown" - | Home -> "Home" - | End -> "End" - | CapsLock -> "CapsLock" - | ScrollLock -> "ScrollLock" - | NumLock -> "NumLock" - | PrintScreen -> "PrintScreen" - | Pause -> "Pause" - | F1 -> "F1" - | F2 -> "F2" - | F3 -> "F3" - | F4 -> "F4" - | F5 -> "F5" - | F6 -> "F6" - | F7 -> "F7" - | F8 -> "F8" - | F9 -> "F9" - | F10 -> "F10" - | F11 -> "F11" - | F12 -> "F12" - | F13 -> "F13" - | F14 -> "F14" - | F15 -> "F15" - | F16 -> "F16" - | F17 -> "F17" - | F18 -> "F18" - | F19 -> "F19" - | F20 -> "F20" - | F21 -> "F21" - | F22 -> "F22" - | F23 -> "F23" - | F24 -> "F24" - | F25 -> "F25" - | Kp0 -> "Kp0" - | Kp1 -> "Kp1" - | Kp2 -> "Kp2" - | Kp3 -> "Kp3" - | Kp4 -> "Kp4" - | Kp5 -> "Kp5" - | Kp6 -> "Kp6" - | Kp7 -> "Kp7" - | Kp8 -> "Kp8" - | Kp9 -> "Kp9" - | KpDecimal -> "KpDecimal" - | KpDivide -> "KpDivide" - | KpMultiply -> "KpMultiply" - | KpSubtract -> "KpSubtract" - | KpAdd -> "KpAdd" - | KpEnter -> "KpEnter" - | KpEqual -> "KpEqual" - | LeftShift -> "LeftShift" - | LeftControl -> "LeftControl" - | LeftAlt -> "LeftAlt" - | LeftSuper -> "LeftSuper" - | RightShift -> "RightShift" - | RightControl -> "RightControl" - | RightAlt -> "RightAlt" - | RightSuper -> "RightSuper" - | Menu -> "Menu") - -let pp_glfw_key_action : GLFW.key_action F.t = - fun ppf s -> - F.pf ppf - GLFW.( - match s with - | Release -> "Release" - | Press -> "Press" - | Repeat -> "Repeat") - -let pp_glfw_mods = - F.( - list (fun ppf s -> - pf ppf - GLFW.( - match s with - | Shift -> "Shift" - | Control -> "Control" - | Alt -> "Alt" - | Super -> "Super"))) - let () = GLFW.init (); at_exit GLFW.terminate; @@ -218,24 +70,10 @@ let () = F.pr "oplevel.ml: Toploop.initialize_toplevel_env@."; Toploop.initialize_toplevel_env (); - let text = + let rootrepo = Lwt_main.run - ((fun () -> - Store.init_default - (F.str "%s/console/rootstore.git" Secrets.giturl) - >>= fun t -> - Store.S.tree t >>= fun rootstore -> - (try Store.S.Tree.get rootstore [ ".config"; "init.ml" ] with - | Not_found | Invalid_argument _ -> - Lwt.return - "print_newline \"rootstore://.config/init.ml not \ - found\";;" - | exc -> - Lwt.return - (F.str ".config/init.ml load exception: %s" - (Printexc.to_string exc))) - >>= fun text -> Lwt.return text) - ()) + (Store.init_default + (F.str "%s/console/rootstore.git" Secrets.giturl)) in let ui = @@ -245,17 +83,32 @@ let () = GLFW.setKeyCallback ~window ~f: (Some - (fun window key int state mods -> - F.epr - "GLFW.setKeyCallback ~f: _win key=%a int=%d state=%a \ - mods=%a@." - pp_glfw_key key int pp_glfw_key_action state pp_glfw_mods - mods; - Ogui.Ui.keycallback ui window key int state mods)) + Glfw_types.( + fun _window key int state mods -> + 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; + Ogui.Ui.keycallback ui state key mods)) |> ignore; - let t = GLFW.getTime () |> ref in + GLFW.setCharCallback ~window + ~f: + (Some + (fun _window ch -> + 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); + Ogui.Ui.chrcallback ui ch)) + |> ignore; + + F.pr "oplevel.ml: entering drawing loop@."; + + let t = GLFW.getTime () |> ref in while (not GLFW.(windowShouldClose ~window)) && !continue do Lwt_main.run ((fun () -> @@ -277,24 +130,27 @@ let () = Gl.clear (Gl.color_buffer_bit lor Gl.depth_buffer_bit lor Gl.stencil_buffer_bit); - Gl.enable Gl.blend; Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha; Gl.enable Gl.cull_face_enum; Gl.disable Gl.depth_test; - let win_w, win_h = (float win_w, float win_h) in - Gv.begin_frame ctx ~width:win_w ~height:win_h - ~device_ratio:1.; + let width, height = (float win_w, float win_h) in - Perfgraph.render graph ctx (win_w -. 205.) 5.; - - ignore Ogui.TextEdit.(show (multiline (String text)) ui); + Gv.begin_frame ctx ~width ~height ~device_ratio:1.; + Perfgraph.render graph ctx (width -. 205.) 5.; + ignore + Ogui.TextEdit.( + show + (multiline + (Ogui.TextBuffer.of_repo + ~path:[ ".config"; "init.ml" ] + ~repo:rootrepo)) + ui); (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *) Gv.end_frame ctx; Gc.major_slice 0 |> ignore; - GLFW.swapBuffers ~window; GLFW.pollEvents (); Lwt.return_unit)