diff --git a/dune b/dune index dc45616..89f9adb 100644 --- a/dune +++ b/dune @@ -26,10 +26,10 @@ graphv_gles2_native gg irmin-git - compiler-libs.toplevel + ; compiler-libs.toplevel re ) - (link_flags (-linkall)) +; (link_flags (-linkall)) ; (ocamlopt_flags (:standard -O3 -unboxed-types)) (ocamlc_flags (:standard -verbose)) (modes byte) diff --git a/ogui.ml b/ogui.ml index fcc4b0d..e51f4cc 100644 --- a/ogui.ml +++ b/ogui.ml @@ -66,17 +66,21 @@ module TextBuffer = struct type t = { mutable path : string list; mutable tree : Store.S.tree; - repo : Store.Sync.db; + repo : Store.Sync.db Lwt.t; } - let of_repo ~path ~(repo : Store.Sync.db) = - let tree = Lwt_main.run ((fun () -> Store.S.tree repo) ()) in + let of_repo ~path ~(repo : Store.Sync.db Lwt.t) = + let tree = Lwt_main.run (repo >>= Store.S.tree) in { path; tree; repo } 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 } + { + path; + tree = Store.S.Tree.singleton path str; + repo = + ( Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' -> + Option.value ~default:Store.S.(empty repo') repo ); + } let insert_uchar t n uc : t Lwt.t = F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc; @@ -361,13 +365,14 @@ end let pp_color : Gv.Color.t Fmt.t = F.( - record - [ - field "r" (fun (s : Gv.Color.t) -> s.r) float; - field "g" (fun (s : Gv.Color.t) -> s.g) float; - field "b" (fun (s : Gv.Color.t) -> s.b) float; - field "a" (fun (s : Gv.Color.t) -> s.a) float; - ]) + hbox + @@ record + [ + field "r" (fun (s : Gv.Color.t) -> s.r) float; + field "g" (fun (s : Gv.Color.t) -> s.g) float; + field "b" (fun (s : Gv.Color.t) -> s.b) float; + field "a" (fun (s : Gv.Color.t) -> s.a) float; + ]) module TextLayout = struct open Gg @@ -386,6 +391,26 @@ module TextLayout = struct valign : align; } + type text_wrapping = { + max_width : float; + max_rows : int; + break_anywhere : bool; + overflow_character : string option; + } + + type section = { byte_range : int * int; format : text_format } + + type layout = { + text : TextBuffer.t; + sections : section list; + wrap : text_wrapping; + halign : align; + justify : bool; + line_height : float option; + } + + type cursor = { index : int; last_col : int } + let pp_text_format : text_format F.t = F.( record @@ -394,7 +419,9 @@ module TextLayout = struct field "extra_letter_spacing" (fun s -> s.extra_letter_spacing) float; - field "line_height" (fun s -> s.line_height) (option float); + field "line_height" + (fun (s : text_format) -> s.line_height) + (option float); field "color" (fun s -> s.color) pp_color; field "background" (fun s -> s.background) pp_color; ]) @@ -415,13 +442,6 @@ module TextLayout = struct let text_format_simple font_id color : text_format = { text_format_default with font_id; color } - type text_wrapping = { - max_width : float; - max_rows : int; - break_anywhere : bool; - overflow_character : string option; - } - let pp_text_wrapping = F.( record @@ -443,42 +463,20 @@ module TextLayout = struct overflow_character = Some "…"; } - type layout_section = { - leading_space : float; - byte_range : int * int; - format : text_format; - } - - let pp_layout_section : Format.formatter -> 'a -> unit = + let pp_section : Format.formatter -> 'a -> unit = F.( record [ - field "leading_space" (fun s -> s.leading_space) float; field "byte_range" (fun s -> s.byte_range) (pair ~sep:(any ",") int int); field "format" (fun s -> s.format) pp_text_format; ]) - let layout_section_default = - { - leading_space = 0.0; - byte_range = (0, 0); - format = text_format_default; - } + let section_default = + { byte_range = (0, 0); format = text_format_default } - type layout_job = { - text : TextBuffer.t; - sections : layout_section array; - wrap : text_wrapping; - first_row_min_height : float; - break_on_newline : bool; - halign : align; - justify : bool; - line_height : float option; - } - - let pp_layout_job = + let pp_layout = F.( record [ @@ -487,62 +485,22 @@ module TextLayout = struct string; field "sections" (fun s -> s.sections) - (brackets @@ array pp_layout_section); + (brackets @@ list pp_section); field "wrap" (fun s -> s.wrap) pp_text_wrapping; - field "first_row_min_height" - (fun s -> s.first_row_min_height) - float; - field "break_on_newline" (fun s -> s.break_on_newline) bool; field "halign" (fun s -> s.halign) Align.pp_t; field "justify" (fun s -> s.justify) bool; ]) - let layout_job_of_text text = + let layout_default = { - text; - sections = Array.make 0 layout_section_default; + text = TextBuffer.of_string ~path:[] ""; + sections = [ section_default ]; wrap = default_text_wrapping (); - first_row_min_height = 0.0; - break_on_newline = true; halign = Min; justify = false; line_height = Some 18.; } - type uv_rect = { - offset : Gg.v2; - size : Gg.v2; - min : Gg.p2; (* Top left corner UV in texture *) - max : Gg.p2; (* Bottom right corner (exclusive) *) - } - - type glyph = { - chr : string; - pos : Gg.p2; - ascent : float; - size : Gg.size2; - uv_rect : uv_rect; - section_index : int; - } - - type row_visuals = { - (* mesh : mesh; *) - mesh_bounds : Gg.box2; - glyph_vertex_range : int * int; - } - - let pp_row_visuals = - F.( - record - [ - field "mesh_bounds" - (fun (s : row_visuals) -> s.mesh_bounds) - Gg.Box2.pp; - field "glyph_vertex_range" - (fun (s : row_visuals) -> s.glyph_vertex_range) - (pair ~sep:(any ",") int int); - ]) - let pp_text_row : Format.formatter -> Gv.Text.text_row -> unit = F.( record @@ -558,139 +516,24 @@ module TextLayout = struct field "maxx" (fun (s : Gv.Text.text_row) -> s.maxx) float; ]) - type row = { - text_row : Gv.Text.text_row; - section_index_at_start : int; - glyphs : glyph list; - rect : Gg.box2; - visuals : row_visuals; - ends_with_newline : bool; - } - - let pp_row : Format.formatter -> row -> unit = - F.( - record - [ - field "text_row" (fun s -> s.text_row) pp_text_row; - field "section_index_at_start" - (fun (s : row) -> s.section_index_at_start) - int; - field "format" (fun (s : row) -> List.length s.glyphs) int; - field "rect" (fun (s : row) -> s.rect) Gg.Box2.pp; - field "visuals" (fun (s : row) -> s.visuals) pp_row_visuals; - field "ends_with_newline" - (fun (s : row) -> s.ends_with_newline) - bool; - ]) - - let row_default () = - { - text_row = - { - start_index = 0; - end_index = 0; - width = 0.; - minx = 0.; - maxx = 0.; - next = 0; - }; - section_index_at_start = 0; - glyphs = []; - rect = Box2.zero; - visuals = - { mesh_bounds = Box2.zero; glyph_vertex_range = (0, 0) }; - ends_with_newline = false; - } - - type galley = { - job : layout_job; - rows : row array; - elided : bool; - rect : Gg.box2; - mesh_bounds : Gg.box2; - num_vertices : int; - num_indices : int; - pixels_per_point : float; - } - - type rich_text = { - text : string; - size : float option; - extra_letter_spacing : float; - line_height : float option; - font : string option; - background_color : Gv.Color.t; - text_color : Gv.Color.t; - code : bool; - strong : bool; - weak : bool; - strikethrough : bool; - underline : bool; - italics : bool; - raised : bool; - } - - let rich_text_default = - { - text = ""; - size = None; - extra_letter_spacing = 0.0; - line_height = None; - font = None; - background_color = Gv.Color.transparent; - text_color = Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9; - code = false; - strong = false; - weak = false; - strikethrough = false; - underline = false; - italics = false; - raised = false; - } - - type widget_text = - | RichText of rich_text - | LayoutJob of layout_job - | Galley of galley - - type cursor = { - index : int; - row : int option; - last_col : int; - prefer_next_row : bool; - } - - let cursor_default = - { index = 0; row = None; last_col = 0; prefer_next_row = false } + let cursor_default = { index = 0; last_col = 0 } 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 } + { index; last_col } let simple text ?(format = text_format_default) wrap_width : - layout_job Lwt.t = + layout 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 }; + layout_default with + text; + sections = [ { 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 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.) @@ -702,139 +545,55 @@ module TextLayout = struct { 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 *) + ?(format = default_cursor_formatter) layout : layout = { - layout_job with + layout with sections = - Array.of_list - (* Lol maybe this is inefficient? (or maybe not) *) - (List.fold_left - (fun (l : layout_section list) sec -> - let s, e = sec.byte_range in + List.fold_left + (fun (l : section list) sec -> + let s, e = sec.byte_range in - l - @ (if - e < cs || ce < s - (* cursor start is after this section or cursor end is before this section *) - then [ sec ] - else []) - @ (if - cs > s - && cs - <= e (* if cursor start is in this section *) - then [ { sec with byte_range = (s, cs) } ] - else []) - @ (if - cs <= e && ce >= s - (* if cursor start is at or before the end this section and cursor end is at or after the beginning of this section *) - then - [ - { - sec with - format = cursor_format sec.format; - byte_range = (max cs s, min ce e); - }; - ] - else []) - @ - if - ce > s - && ce <= e (* if cursor end is in this section *) - then [ { sec with byte_range = (ce, e) } ] + l + @ (if + e < cs || ce < s + (* cursor start is after this section or cursor end is before this section *) + then [ sec ] else []) - [] - (Array.to_list layout_job.sections)); + @ (if + cs > s + && cs <= e (* if cursor start is in this section *) + then [ { sec with byte_range = (s, cs) } ] + else []) + @ (if + cs <= e && ce >= s + (* if cursor start is at or before the end this section and cursor end is at or after the beginning of this section *) + then + [ + { + format = format sec.format; + byte_range = (max cs s, min ce e); + }; + ] + else []) + @ + if + ce > s && ce <= e (* if cursor end is in this section *) + then [ { sec with byte_range = (ce, e) } ] + else []) + [] layout.sections; } - let with_cursor (cur : cursor) - ?(cursor_format = default_cursor_formatter) layout_job : - layout_job = - let c = - with_range (cur.index, cur.index + 1) ~cursor_format layout_job - in + let with_cursor (cur : cursor) ?(format = default_cursor_formatter) + layout : layout = + let c = with_range (cur.index, cur.index + 1) ~format layout in c let with_mark (mark : int option) (cur : int) - ?(cursor_format = default_mark_formatter) layout_job : - layout_job = + ?(format = default_mark_formatter) layout : layout = 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@."; - 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 - 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 contents - in - (* F.epr "row_count=%d@." row_count; *) - let height = ref (V2.y pos) in - let max_width = ref 0. in - let line_height = - Option.value ~default:metrics.line_height job.line_height - in - 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; - } + with_range ~format (min mark' cur, max mark' cur) layout + | None -> layout end let rec nth_tl n = function @@ -907,7 +666,6 @@ module Ui = struct let id = ref 0 let spacing ui = ui.style.spacing - let fonts ui (reader : Gv.t -> 'a) : 'a = reader ui let allocate_space (_gv : Gv.t) (size : Gg.box2) : id * Gg.box2 = id := !id + 1; @@ -971,8 +729,8 @@ module TextEdit = struct id : id option; id_source : id option; text_format : TextLayout.text_format; - layouter : - (Ui.t -> TextBuffer.t -> float -> TextLayout.galley) option; + formatter : + (Ui.t -> TextBuffer.t -> float -> TextLayout.layout) option; password : bool; frame : bool; margin : margin; @@ -1216,7 +974,7 @@ module TextEdit = struct id = None; id_source = None; text_format; - layouter = None; + formatter = None; password = false; frame = true; margin = Margin.symmetric 4.0 2.0; @@ -1430,60 +1188,71 @@ module Painter = struct Text.set_size t ~size:font_size; Text.set_align t ~align:Align.(left lor top) - let paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 Lwt.t = - TextBuffer.contents g.job.text >>= fun contents -> + let text_layout (t : Gv.t) (rect : box2) (g : TextLayout.layout) : + box2 Lwt.t = + let line_height = + Option.value ~default:(Gv.Text.metrics t).line_height + g.line_height + in + let max_rows = Int.of_float (Box2.h rect /. line_height) in + let lines = Gv.Text.make_empty_rows max_rows in + TextBuffer.contents g.text >>= fun contents -> let contents_len = String.length contents in - g.rows - |> ( Array.iter @@ 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 - @@ sub g.job.sections row.section_index_at_start - @@ (length g.job.sections - row.section_index_at_start)) - in - assert (List.length sections > 0); - let y = Box2.miny row.rect in - List.fold_left - (fun x (sec : TextLayout.layout_section) -> - let start, end_ = - Stdlib. - ( row.text_row.start_index - |> max (fst sec.byte_range) - |> min contents_len, - row.text_row.end_index |> min contents_len - |> min (snd sec.byte_range) ) - in - let metrics = Gv.Text.metrics t in - let bounds = - if start == row.text_row.end_index then - (* hack to display cursor at end of row *) - Gv.Text.bounds t ~x ~y:0. " " - else Gv.Text.bounds t ~x ~y:0. ~start ~end_ contents - in - - let line_height = - Option.value ~default:metrics.line_height - sec.format.line_height - in - - draw_box t - ~box: - Box2.(v (V2.v x y) (V2.v bounds.advance line_height)) - ~style: - Layout.Style. - { default with fill = sec.format.background }; - - set_text_format t sec.format; - Gv.set_fill_color t ~color:sec.format.color; - Gv.Text.text_w t ~x ~y ~start ~end_ contents) - (Box2.minx row.rect) sections - |> ignore ) - |> ignore; - Lwt.return g.rect + let row_count = + Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows + ~lines contents + in + Seq.fold_left + (fun (cur : p2) (row : Gv.Text.text_row) -> + let sections = + List.filter + (fun (r : TextLayout.section) -> + fst r.byte_range <= row.end_index + && snd r.byte_range > row.start_index) + g.sections + in + List.fold_left + (fun (cur' : p2) (sec : TextLayout.section) -> + let start, end_ = + ( row.start_index + |> max (fst sec.byte_range) + |> min contents_len, + row.end_index |> min contents_len + |> min (snd sec.byte_range) ) + in + let bounds = + if start == row.end_index then + (* hack to display cursor at end of row *) + Gv.Text.bounds t ~x:(P2.x cur') ~y:0. " " + else + Gv.Text.bounds t ~x:(P2.x cur') ~y:0. ~start ~end_ + contents + in + let line_height = + Option.value ~default:(Gv.Text.metrics t).line_height + sec.format.line_height + in + draw_box t + ~box: + (Box2.v + (V2.v (P2.x cur') (P2.y cur)) + (V2.v bounds.advance line_height)) + ~style: + Layout.Style. + { default with fill = sec.format.background }; + set_text_format t sec.format; + Gv.set_fill_color t ~color:sec.format.color; + V2.v + (Gv.Text.text_w t ~x:(P2.x cur') ~y:(P2.y cur) ~start + ~end_ contents) + Float.(max (P2.y cur +. line_height) (P2.y cur'))) + P2.(v (Box2.minx rect) (y cur)) + sections + |> fun cur'' -> V2.(v (max (x cur) (x cur'')) (y cur''))) + (Box2.o rect) + (Seq.take row_count (Array.to_seq lines)) + |> Box2.(of_pts (o rect)) + |> Lwt.return let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t = @@ -1494,38 +1263,25 @@ module Painter = struct (fun (c : box2) f -> layout c ui f >>= fun r -> let c' = - let open Box2 in - match dir with - | `V -> Box2.of_pts (V2.v (minx c) (maxy r)) (max c) - | `H -> Box2.of_pts (V2.v (maxx r) (miny c)) (max c) - | `Z -> box + Box2.( + match dir with + | `V -> of_pts (V2.v (minx c) (maxy r)) (max c) + | `H -> of_pts (V2.v (maxx r) (miny c)) (max c) + | `Z -> box) in - Lwt.return c') box' ll | `TextEdit t -> - 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 find font 'mono'" - in - (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 - TextLayout.( - fun gv -> - (layout gv font - (with_cursor t.cursor - (with_mark t.mark t.cursor.index layout_job))) - (Box2.o box')) - >>= fun galley -> paint_galley ui.gv galley + TextLayout.( + simple t.text ~format:t.text_format + (Option.value ~default:(Box2.w box') t.desired_width) + >>= fun layout -> + with_cursor t.cursor layout + |> with_mark t.mark t.cursor.index + |> text_layout ui.gv box') | _ -> Lwt.return box) >>= fun r -> - F.epr "@[layout@;box=%a@;box'=%a@;r=%a@;%a@]@." Box2.pp box - Box2.pp box' Box2.pp r pp_frame frame; - draw_box ui.gv ~box:r ~style:frame.style; - Lwt.return r + let r' = Margin.outer frame.style.margin r in + draw_box ui.gv ~box:r' ~style:frame.style; + Lwt.return r' end diff --git a/oplevel.ml b/oplevel.ml index 24e04b6..d662145 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -69,13 +69,12 @@ 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 = - Lwt_main.run - (Store.init_default - (F.str "%s/console/rootstore.git" Secrets.giturl)) + Store.init_default + (F.str "%s/console/rootstore.git" Secrets.giturl) in let ui = @@ -86,10 +85,6 @@ let () = ~f: (Some (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))) @@ -99,13 +94,6 @@ let () = ~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); *) Lwt.async (fun () -> Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit))) |> ignore;