.

ogui.ml

@@ -17,6 +17,7 @@ module Margin = struct
     bottom : size1;
   }
 
+  let empty = { left = 0.; right = 0.; top = 0.; bottom = 0. }
   let symmetric h w = { left = w; right = w; top = h; bottom = h }
   let sum t : size2 = Size2.v (t.left +. t.right) (t.top +. t.bottom)
 
@@ -24,6 +25,15 @@ module Margin = struct
     Box2.v
       (V2.v (Box2.minx b +. t.left) (Box2.miny b +. t.top))
       (V2.v (Box2.maxx b -. t.right) (Box2.maxy b -. t.bottom))
+
+  let outer t b =
+    Box2.(
+      v
+        (V2.v (minx b -. t.left) (miny b -. t.top))
+        (V2.v (maxx b +. t.right) (maxy b +. t.bottom)))
+
+  let pp ppf t =
+    F.pf ppf "l=%f@;r=%f@;t=%f@;b=%f" t.left t.right t.top t.bottom
 end
 
 type margin = Margin.t
@@ -1296,7 +1306,38 @@ end
 module Layout = struct
   open Gg
 
-  type frame = { t : t; mutable size : size }
+  module Style = struct
+    type t = {
+      stroke : float option * Gv.Color.t;
+      fill : Gv.Color.t;
+      margin : Margin.t;
+    }
+
+    let default =
+      {
+        stroke = (None, Gv.Color.transparent);
+        fill = Gv.Color.transparent;
+        margin = Margin.empty;
+      }
+
+    let pp ppf t =
+      F.pf ppf "%a"
+        F.(
+          record
+            [
+              field "stroke"
+                (fun t -> t.stroke)
+                (hbox
+                @@ pair ~sep:comma
+                     (option ~none:(any "None") float)
+                     pp_color);
+              field "fill" (fun t -> t.fill) pp_color;
+              field "margin" (fun t -> t.margin) Margin.pp;
+            ])
+        t
+  end
+
+  type frame = { t : t; mutable size : size; style : Style.t }
 
   and t =
     [ `Box of [ `H | `V | `Z ] * frame list
@@ -1305,23 +1346,52 @@ module Layout = struct
     | `TextEdit of TextEdit.t
     | `None ]
 
-  and size =
+  and size = [ `Fixed of size2 | `Max | `Min ]
-    [ `Fixed of p2 | `Percent (* of container *) of p2 | `Auto ]
 
-  let frame ?(size = `Auto) t : frame = { t; size }
+  let frame ?(size = `Max) ?(style = Style.default) t : frame =
-  let box d t = frame (`Box (d, t))
+    { t; size; style }
+
+  let box d ?style t = frame ?style (`Box (d, t))
   let hbox, vbox, zbox = (box `H, box `V, box `Z)
 
-  let pp_t_frame ppf f =
+  let textedit_style =
+    Style.
+      {
+        default with
+        stroke = (Some 1.2, Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9);
+        margin = Margin.symmetric 10. 10.;
+      }
+
+  let textedit ?size ?(style = textedit_style) te =
+    frame ?size ~style (`TextEdit te)
+
+  let pp_dir ppf (t : [ `H | `V | `Z ]) =
     F.pf ppf "%s"
-      (match f with
+      (match t with `H -> "`H" | `V -> "`V" | `Z -> "`Z")
-      | `Hbox -> "`Hbox"
+
-      | `Vbox -> "`Vbox"
+  let pp_t ppf (t : t) =
-      | `Buffer -> "`Buffer"
+    F.pf ppf "%s"
-      | `TextEdit -> "`TextEdit"
+      (match t with
-      | `S s -> F.str "%s" s
+      | `Box (d, _) -> F.str "`Box %a" pp_dir d
+      | `Buffer _ -> "`Buffer"
+      | `TextEdit _ -> "`TextEdit"
+      | `String s -> F.str "`String %s" s
       | `None -> "`None")
 
+  let pp_size ppf = function
+    | `Fixed p -> F.pf ppf "`Fixed %a" Gg.V2.pp p
+    | `Max -> F.pf ppf "`Max"
+    | `Min -> F.pf ppf "`Min"
+
+  let pp_frame =
+    F.(
+      record
+        [
+          field "t" (fun t -> t.t) pp_t;
+          field "size" (fun t -> t.size) pp_size;
+          field "style" (fun t -> t.style) Style.pp;
+        ])
+
   let parse_t_frame s =
     match s with
     | "`Box" -> `Vbox
@@ -1335,105 +1405,104 @@ module Painter = struct
   open Layout
   open Gg
 
-  let paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 Lwt.t =
+  let draw_box (t : Gv.t) ~(box : Gg.box2) ~(style : Layout.Style.t) =
-    TextBuffer.contents g.job.text >>= fun contents ->
+    let open Gv in
-    let contents_len = String.length contents in
+    let open Box2 in
-    (*F.epr
+    Path.begin_ t;
-        "Painter.galley (String.length g.job.text)=%d (Array.length \
+    Path.rect t ~x:(minx box) ~y:(miny box) ~w:(w box) ~h:(h box);
-         g.rows)=%d @."
+    set_fill_color t ~color:style.fill;
-        contents_len (Array.length g.rows);
+    set_stroke_color t ~color:(snd style.stroke);
-      F.epr "g.job=%a@." TextLayout.pp_layout_job g.job;
+    (match style.stroke with
-      F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows; *)
+    | None, _ -> ()
-    g.rows
+    | Some width, _ ->
-    |> Array.fold_left
+        set_stroke_width t ~width;
-         (fun (br : box2) (row : TextLayout.row) ->
+        stroke t);
-           let sections =
+    fill t
-             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);
 
-           (*F.epr "paint_galley sections:%a@."
+  let set_text_format (t : Gv.t) (format : TextLayout.text_format) =
-             F.(list TextLayout.pp_layout_section)
-             sections; *)
-           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
+      match 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);
+    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 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
+               else Gv.Text.bounds t ~x ~y:0. ~start ~end_ contents
-                      Gv.Text.bounds t ~x ~y:0. ~start ~end_ contents
              in
 
-                  Path.begin_ t;
+             let line_height =
-                  Path.rect t ~x ~y:(Box2.miny row.rect)
+               Option.value ~default:metrics.line_height
-                    ~w:bounds.advance ~h:metrics.line_height;
+                 sec.format.line_height
-                  set_fill_color t ~color:sec.format.background;
+             in
-                  set_stroke_color t
-                    ~color:(Gv.Color.rgbf ~r:0.9 ~g:0.2 ~b:0.2);
-                  set_stroke_width t ~width:2.0;
-                  fill t;
 
-                  (* stroke t; *)
+             draw_box t
-                  set_fill_color t ~color:sec.format.color;
+               ~box:
-                  (*F.epr "paint_galley row=%d:%d %d:%d %S@."
+                 Box2.(v (V2.v x y) (V2.v bounds.advance line_height))
-                    row.text_row.start_index row.text_row.end_index
+               ~style:
-                    start end_
+                 Layout.Style.
-                    (String.sub contents start (end_ - start)); *)
+                   { default with fill = sec.format.background };
-                  Text.text_w t ~x ~y:(Box2.miny row.rect) ~start
+
-                    ~end_ contents)
+             set_text_format t sec.format;
-                (Box2.minx row.rect) sections);
+             Gv.set_fill_color t ~color:sec.format.color;
-           Box2.(union br row.rect))
+             Gv.Text.text_w t ~x ~y ~start ~end_ contents)
-         Box2.empty
+           (Box2.minx row.rect) sections
-    |> Lwt.return
+         |> ignore )
+    |> ignore;
+    Lwt.return g.rect
 
   let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t
       =
-    match frame.t with
+    let box' = Margin.inner frame.style.margin box in
+    (match frame.t with
     | `Box (dir, ll) ->
         Lwt_list.fold_left_s
-          (fun (o : box2) f ->
+          (fun (c : box2) f ->
-            layout
+            layout c ui f >>= fun r ->
-              (match dir with
+            let c' =
-              | `H ->
+              let open Box2 in
-                  Box2.of_pts
+              match dir with
-                    V2.(v (Box2.minx o) (Box2.miny box))
+              | `V -> Box2.of_pts (V2.v (minx c) (maxy r)) (max c)
-                    (Box2.br_pt o)
+              | `H -> Box2.of_pts (V2.v (maxx r) (miny c)) (max c)
-              | `V ->
+              | `Z -> box
-                  Box2.of_pts
+            in
-                    V2.(v (Box2.minx box) (Box2.miny o))
+
-                    (Box2.br_pt o)
+            Lwt.return c')
-              | `Z -> box)
+          box' ll
-              ui f)
-          box ll
     | `TextEdit t ->
         let font =
           match Gv.Text.find_font ui.gv ~name:"mono" with
@@ -1442,15 +1511,21 @@ module Painter = struct
         in
         (if t.multiline then
            TextLayout.simple t.text ~format:t.text_format
-             (Option.value ~default:(Box2.w box) t.desired_width)
+             (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 gv ->
+        Ui.fonts ui.gv
-            TextLayout.layout gv font
+          TextLayout.(
-              (TextLayout.with_cursor t.cursor
+            fun gv ->
-                 (TextLayout.with_mark t.mark t.cursor.index
+              (layout gv font
-                    layout_job))
+                 (with_cursor t.cursor
-              (Box2.o box))
+                    (with_mark t.mark t.cursor.index layout_job)))
+                (Box2.o box'))
         >>= fun galley -> paint_galley ui.gv galley
-    | _ -> Lwt.return box
+    | _ -> Lwt.return box)
+    >>= fun r ->
+    F.epr "@[<v>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
 end

oplevel.ml

@@ -115,12 +115,14 @@ let () =
     Layout.(
       vbox
         [
-          frame
+          textedit
-            (`TextEdit
+            (TextEdit.multiline ui
+               (TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo));
+          textedit
             (TextEdit.multiline ui
                (TextBuffer.of_repo
-                    ~path:[ "README" ] (*[ ".config"; "init.ml" ] *)
+                  ~path:[ ".config"; "init.ml" ]
-                    ~repo:rootrepo)));
+                  ~repo:rootrepo));
         ])
   in