diff --git a/dune b/dune index ad9fa14..dc45616 100644 --- a/dune +++ b/dune @@ -27,6 +27,7 @@ gg irmin-git compiler-libs.toplevel + re ) (link_flags (-linkall)) ; (ocamlopt_flags (:standard -O3 -unboxed-types)) diff --git a/ogui.ml b/ogui.ml index 499ae03..da16114 100644 --- a/ogui.ml +++ b/ogui.ml @@ -1,6 +1,7 @@ open Lwt.Infix module Gv = Graphv_gles2_native module F = Fmt +module Str = Re.Str type stroke = { width : float; color : Gv.Color.t } @@ -52,24 +53,25 @@ module Sense = struct end 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 } + type t = { + mutable path : string list; + mutable tree : Store.S.tree; + repo : Store.Sync.db; + } let of_repo ~path ~(repo : Store.Sync.db) = let tree = Lwt_main.run ((fun () -> Store.S.tree repo) ()) in - Tree { path; tree; repo } + { path; tree; repo } - let buffer ~name ~buf = Buffer { name; buf } + let of_string ~path ?(repo = None) str = + Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' -> + Option.value ~default:Store.S.(empty repo') repo >>= fun repo -> + Lwt.return { path; tree = Store.S.Tree.singleton path str; repo } let insert_uchar t n uc : t Lwt.t = F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc; match t with - | Tree ({ path; tree; _ } as tt) -> + | { path; tree; _ } as tt -> Store.S.Tree.update tree path (function | Some src -> assert (n <= String.length src); @@ -85,36 +87,48 @@ module TextBuffer = struct ~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 + >>= fun tree -> Lwt.return { tt with tree } - 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 remove_uchar t n : t Lwt.t = + F.epr "TextBuffer.remove_subset n=%d @." n; + match t with + | { path; tree; _ } as tt -> + Store.S.Tree.update tree path (function + | Some src -> + let srcn = String.length src in + assert (n < srcn); + let dst = Bytes.create srcn in + let ucn = + Uchar.utf_decode_length (String.get_utf_8_uchar src n) + in + Bytes.blit_string src 0 dst 0 n; + Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn); + Some (Bytes.to_string dst) + | v -> v) + >>= fun tree -> Lwt.return { tt with tree } - 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 + let fold_string t (f : string -> 'a) : 'a Lwt.t = + match t with + | { path; tree; _ } -> + Store.S.Tree.get tree path >>= fun text -> Lwt.return (f text) + + let contents { 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 + + let length { path; tree; _ } = + Store.S.Tree.get tree path >>= fun text -> + Lwt.return (String.length text) end module Event = struct @@ -440,8 +454,8 @@ module TextLayout = struct record [ field "text" - (fun s -> Lwt_main.run (TextBuffer.length s.text)) - int; + (fun s -> str "path=%s" (String.concat "/" s.text.path)) + string; field "sections" (fun s -> s.sections) (brackets @@ array pp_layout_section); @@ -454,11 +468,9 @@ module TextLayout = struct field "justify" (fun s -> s.justify) bool; ]) - let default_layout_job () = + let layout_job_of_text text = { - text = - TextBuffer.buffer ~name:"default_layout_job" - ~buf:(Buffer.create 32); + text; sections = Array.make 0 layout_section_default; wrap = default_text_wrapping (); first_row_min_height = 0.0; @@ -615,45 +627,42 @@ module TextLayout = struct type cursor = { index : int; row : int option; + last_col : int; prefer_next_row : bool; } let cursor_default = - { index = 0; row = None; prefer_next_row = false } + { index = 0; row = None; last_col = 0; prefer_next_row = false } - let cursor loc : cursor = - { index = loc; row = None; prefer_next_row = false } - - let cursor_move amt max c : cursor = - cursor - (if c.index + amt < 0 then 0 - else if c.index + amt > max then max - else c.index + amt) + let cursor ?(row : int option) ?(last_col = 0) index : cursor = + F.epr "cursor row=%a last_col=%d index=%d@." + F.(option int) + row last_col index; + { index; row; last_col; prefer_next_row = false } let simple text ?(format = text_format_default) wrap_width : - layout_job = - { - (default_layout_job ()) with - text; - sections = - Array.make 1 - { - leading_space = 0.0; - byte_range = (0, Lwt_main.run (TextBuffer.length text)); - format; - }; - wrap = - { (default_text_wrapping ()) with max_width = wrap_width }; - break_on_newline = true; - } + layout_job Lwt.t = + TextBuffer.length text >>= fun textlen -> + Lwt.return + { + (layout_job_of_text text) with + sections = + Array.make 1 + { leading_space = 0.0; byte_range = (0, textlen); format }; + wrap = + { (default_text_wrapping ()) with max_width = wrap_width }; + break_on_newline = true; + } let singleline (text : TextBuffer.t) (format : text_format) : - layout_job = - { - (simple text ~format Float.infinity) with - wrap = default_text_wrapping (); - break_on_newline = true; - } + layout_job Lwt.t = + simple text ~format Float.infinity >>= fun simple -> + Lwt.return + { + simple with + wrap = default_text_wrapping (); + break_on_newline = true; + } let cursor_color = ref (Gv.Color.rgbf ~r:0.5 ~g:0.5 ~b:0.) @@ -709,28 +718,29 @@ module TextLayout = struct } let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job) - (pos : v2) : galley = + (pos : v2) : galley Lwt.t = (* F.epr "TextLayout.layout@."; F.epr "job.wrap.max_width=%f@." job.wrap.max_widtha; F.epr "job.wrap.max_rows=%d@." job.wrap.max_rows; *) if job.wrap.max_rows == 0 then - { - job; - rows = Array.make 1 (row_default ()); - rect = Box2.move pos Box2.zero; - mesh_bounds = Box2.zero; - elided = true; - num_vertices = 0; - num_indices = 0; - pixels_per_point = fonts.pixels_per_point; - } + Lwt.return + { + job; + rows = Array.make 1 (row_default ()); + rect = Box2.move pos Box2.zero; + mesh_bounds = Box2.zero; + elided = true; + num_vertices = 0; + num_indices = 0; + pixels_per_point = fonts.pixels_per_point; + } else let metrics = Gv.Text.metrics gv in let lines = Gv.Text.make_empty_rows job.wrap.max_rows in + TextBuffer.contents job.text >>= fun contents -> let row_count = Gv.Text.break_lines gv ~break_width:job.wrap.max_width - ~max_rows:job.wrap.max_rows ~lines - (Lwt_main.run (TextBuffer.contents job.text)) + ~max_rows:job.wrap.max_rows ~lines contents in (* F.epr "row_count=%d@." row_count; *) let height = ref (V2.y pos) in @@ -738,43 +748,44 @@ module TextLayout = struct let line_height = Option.value ~default:metrics.line_height job.line_height in - { - job; - rows = - Array.init row_count (fun n -> - let text_row = Array.get lines n in - height := !height +. line_height; - let rect = - Box2.v - (P2.v (V2.x pos) !height) - (P2.v - (text_row.width +. V2.x pos) - (!height +. line_height)) - in - max_width := Float.max text_row.maxx !max_width; - { - text_row; - section_index_at_start = 0; - glyphs = [ (* TODO *) ]; - rect; - visuals = - { - mesh_bounds = rect; - glyph_vertex_range = - (text_row.start_index, text_row.end_index); - }; - ends_with_newline = false (* TODO *); - }); - rect = - Box2.v Size2.zero - (P2.v job.wrap.max_width - (Float.of_int row_count *. line_height)); - elided = row_count > job.wrap.max_rows (* TODO *); - mesh_bounds = Box2.v Size2.zero (P2.v !max_width !height); - num_indices = 0 (* TODO *); - num_vertices = 0 (* TODO *); - pixels_per_point = fonts.pixels_per_point; - } + Lwt.return + { + job; + rows = + Array.init row_count (fun n -> + let text_row = Array.get lines n in + height := !height +. line_height; + let rect = + Box2.v + (P2.v (V2.x pos) !height) + (P2.v + (text_row.width +. V2.x pos) + (!height +. line_height)) + in + max_width := Float.max text_row.maxx !max_width; + { + text_row; + section_index_at_start = 0; + glyphs = [ (* TODO *) ]; + rect; + visuals = + { + mesh_bounds = rect; + glyph_vertex_range = + (text_row.start_index, text_row.end_index); + }; + ends_with_newline = false (* TODO *); + }); + rect = + Box2.v Size2.zero + (P2.v job.wrap.max_width + (Float.of_int row_count *. line_height)); + elided = row_count > job.wrap.max_rows (* TODO *); + mesh_bounds = Box2.v Size2.zero (P2.v !max_width !height); + num_indices = 0 (* TODO *); + num_vertices = 0 (* TODO *); + pixels_per_point = fonts.pixels_per_point; + } end let rec nth_tl n = function @@ -867,7 +878,7 @@ module Ui = struct ref Option.None let keycallback t (state : Event.key_action) (key : Event.key) - (mods : Event.key_mod list) : unit = + (mods : Event.key_mod list) : bool Lwt.t = let res = match !callback_resolver with | Some res -> res @@ -877,33 +888,28 @@ module Ui = struct Event.( F.epr "Ui.keycallback %a %a %a@." pp_key key pp_key_action state pp_mods mods); - ignore - @@ Lwt_main.run - ((fun () : bool Lwt.t -> - match Event.resolve (Key (state, key, 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) - ()) + match Event.resolve (Key (state, key, 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 let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref = ref (fun c -> F.epr "chrcallback: '%a'@." pp_uchar c; Lwt.return_unit) - let chrcallback _t (chr : int) : unit = - Lwt_main.run @@ !chrcallback_ref @@ Uchar.of_int chr + let chrcallback _t (chr : int) : unit Lwt.t = + !chrcallback_ref @@ Uchar.of_int chr end module TextEdit = struct @@ -931,6 +937,21 @@ module TextEdit = struct char_limit : int; (* return_key : keyboard_shortcut; *) } + let col t = + TextBuffer.fold_string t.text (fun s -> + Str.search_backward (Str.regexp "^") s t.cursor.index) + + let cursor_move (t : t) (amt : int) : unit Lwt.t = + TextBuffer.fold_string t.text (fun s -> + let index' = + t.cursor.index + amt |> max 0 |> min (String.length s) + in + t.cursor <- + TextLayout.cursor + ~last_col: + (index' - Str.search_backward (Str.regexp "^") s index') + index') + let add_bindings (t : t) (ui : Ui.t) : unit Lwt.t = let open GLFW in let open Event in @@ -942,26 +963,13 @@ module TextEdit = struct [ Key (Press, F, [ Control ]) ]; [ Key (Press, Right, []) ]; ] - [ - Custom - (fun () -> - TextBuffer.length t.text >>= fun textlen -> - t.cursor <- TextLayout.cursor_move 1 textlen t.cursor; - Lwt.return_unit); - ] + [ Custom (fun () -> cursor_move t 1) ] |> adds [ [ Key (Press, B, [ Control ]) ]; [ Key (Press, Left, []) ]; ] - [ - Custom - (fun () -> - TextBuffer.length t.text >>= fun textlen -> - t.cursor <- - TextLayout.cursor_move (-1) textlen t.cursor; - Lwt.return_unit); - ] + [ Custom (fun () -> cursor_move t (-1)) ] |> adds [ [ Key (Press, N, [ Control ]) ]; @@ -970,42 +978,73 @@ module TextEdit = struct [ Custom (fun () -> - TextBuffer.length t.text >>= fun textlen -> - t.cursor <- - TextLayout.cursor_move 10 textlen t.cursor; - Lwt.return_unit); + TextBuffer.fold_string t.text (fun s -> + let sn = String.length s in + let last_col = t.cursor.last_col in + let seol = Str.search_forward (Str.regexp "$") in + let bol = + Str.search_backward (Str.regexp "^") s + t.cursor.index + in + let eol = seol s t.cursor.index in + let bol' = min sn eol + 1 in + let eol' = seol s bol' in + let next_line_len = eol' - bol' in + F.epr + "Down: index=%d last_col=%d eol=%d eol'=%d \ + bol=%d @." + t.cursor.index last_col eol eol' bol; + t.cursor <- + { + t.cursor with + index = + (bol' + + + if last_col > next_line_len then + next_line_len + else min next_line_len last_col); + })); ] |> adds [ [ Key (Press, P, [ Control ]) ]; [ Key (Press, Up, []) ]; ] - [ - Custom - (fun () -> - TextBuffer.length t.text >>= fun textlen -> - t.cursor <- - TextLayout.cursor_move (-10) textlen t.cursor; - Lwt.return_unit); - ] + [ Custom (fun () -> cursor_move t (-10)) ] |> adds - [ [ Key (Press, Backspace, []) ]; [ Key (Press, Up, []) ] ] + [ [ Key (Press, Backspace, []) ] ] [ Custom (fun () -> - TextBuffer.length t.text >>= fun textlen -> - t.cursor <- - TextLayout.cursor_move (-10) textlen t.cursor; + 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 (* EOL *) + [ + [ Key (Press, E, [ Control ]) ]; [ Key (Press, End, []) ]; + ] + [ + Custom + (fun () -> + TextBuffer.length t.text >>= fun _textlen -> + TextBuffer.fold_string t.text (fun s -> + Str.search_forward (Str.regexp "$") s + t.cursor.index) + >>= fun index -> + t.cursor <- { t.cursor with 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 -> TextBuffer.insert_uchar t.text t.cursor.index c >>= fun text -> t.text <- text; - TextBuffer.length t.text >>= fun textlen -> - t.cursor <- TextLayout.cursor_move 1 textlen t.cursor; - Lwt.return_unit + cursor_move t 1 (* This creates a giant stack of calls lol >>= fun () -> !Ui.chrcallback_ref c *)); Lwt.return_unit @@ -1148,7 +1187,7 @@ module Painter = struct open Layout open Gg - let paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 = + let paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 Lwt.t = (* F.epr "Painter.galley (String.length g.job.text)=%d (Array.length \ g.rows)=%d @." @@ -1156,70 +1195,69 @@ module Painter = struct (Array.length g.rows); F.epr "g.job=%a@." TextLayout.pp_layout_job g.job; F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows; *) - Array.fold_left - (fun (br : box2) (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); + TextBuffer.contents g.job.text >>= fun contents -> + let contents_len = String.length contents in + g.rows + |> Array.fold_left + (fun (br : box2) (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 - (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 + ignore + (List.fold_left + (fun x (sec : TextLayout.layout_section) -> + let start, end_ = + ( min (contents_len - 1) + (max 0 + (max (fst sec.byte_range) + row.text_row.start_index)), + min (contents_len - 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 - 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; + 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_ contents + 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_ - (Lwt_main.run (TextBuffer.contents g.job.text)) - in - w) - (Box2.minx row.rect) sections); - Box2.(union br row.rect)) - Box2.empty g.rows + set_fill_color t ~color:sec.format.color; + Text.text_w t ~x ~y:(Box2.miny row.rect) ~start + ~end_ contents) + (Box2.minx row.rect) sections); + Box2.(union br row.rect)) + Box2.empty + |> Lwt.return - let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 = + let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t + = match frame.t with | `Box (dir, ll) -> - List.fold_left + Lwt_list.fold_left_s (fun (o : box2) f -> layout (match dir with @@ -1240,18 +1278,15 @@ module Painter = struct | Some gv -> Fonts.{ gv; pixels_per_point = 1.0 } | None -> failwith "can't find font 'mono'" in - let layout_job = - if t.multiline then - TextLayout.simple t.text ~format:t.text_format - (Option.value ~default:(Box2.w box) t.desired_width) - else TextLayout.singleline t.text t.text_format - in - let galley = - Ui.fonts ui.gv (fun f -> - TextLayout.layout f font - (TextLayout.with_cursor t.cursor layout_job) - (Box2.o box)) - in - paint_galley ui.gv galley - | _ -> box + (if t.multiline then + TextLayout.simple t.text ~format:t.text_format + (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) + (Box2.o box)) + >>= fun galley -> paint_galley ui.gv galley + | _ -> Lwt.return box end diff --git a/oplevel.ml b/oplevel.ml index a45ca70..916aee4 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -1,3 +1,4 @@ +open Lwt.Infix module F = Fmt open Tgles2 module Gv = Graphv_gles2_native @@ -84,27 +85,29 @@ let () = GLFW.setKeyCallback ~window ~f: (Some - 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)) + (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; *) + Lwt.async (fun () -> + Ogui.Ui.keycallback ui state key mods >>= fun _ -> + Lwt.return_unit))) |> ignore; 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); + (* let uc = Uchar.of_int ch in - Ogui.Ui.chrcallback ui ch)) + 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); *) + Lwt.async (fun () -> + Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit))) |> ignore; F.pr "oplevel.ml: building initial page@."; @@ -156,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 |> ignore; + Painter.layout box ui page >>= fun _ -> (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *) Gv.end_frame ctx;