Merge pull request #46 from c-cube/simon/fix-45

fix #45, add stretch param to frame

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.24.1
+version = 0.26.2
 profile=conventional
 margin=80
 if-then-else=k-r

Makefile

@@ -6,6 +6,8 @@ build:
 
 test:
 	@dune runtest --no-buffer --force
+test-autopromote:
+	@dune runtest --no-buffer --force --auto-promote
 
 install: build
 	@dune install
@@ -22,7 +24,8 @@ update_next_tag:
 	sed -i "s/NEXT_RELEASE/$(VERSION)/g" $(wildcard src/**/*.ml) $(wildcard src/**/*.mli)
 	sed -i "s/NEXT_RELEASE/$(VERSION)/g" $(wildcard src/*.ml) $(wildcard src/*.mli)
 
+WATCH?="@all"
 watch:
-	@dune build @all -w
+	@dune build $(WATCH) -w
 
 .PHONY: all build test clean doc watch

src/PrintBox.ml

@@ -44,7 +44,10 @@ type view =
       l: string list;
       style: Style.t;
     }
-  | Frame of t
+  | Frame of {
+      sub: t;
+      stretch: bool;
+    }
   | Pad of position * t (* vertical and horizontal padding *)
   | Align of {
       h: [ `Left | `Center | `Right ];
@@ -103,7 +106,7 @@ let bool x = line_ (string_of_bool x)
 let int_ = int
 let float_ = float
 let bool_ = bool
-let[@inline] frame b = Frame b
+let[@inline] frame ?(stretch = false) b = Frame { sub = b; stretch }
 
 let pad' ~col ~lines b =
   assert (col >= 0 || lines >= 0);
@@ -128,9 +131,9 @@ let grid ?(pad = fun b -> b) ?(bars = true) m =
   let m = map_matrix pad m in
   Grid
     ( (if bars then
-        `Bars
-      else
-        `None),
+         `Bars
+       else
+         `None),
       m )
 
 let grid_l ?pad ?bars l =
@@ -199,7 +202,6 @@ let mk_tree ?indent f root =
   make root
 
 let link ~uri inner : t = Link { uri; inner }
-
 let anchor ~id inner : t = Anchor { id; inner }
 
 (** {2 Simple Structural Interface} *)

src/PrintBox.mli

@@ -109,14 +109,18 @@ type t
     @since 0.3 added [Align]
     @since 0.5 added [Link]
     @since 0.11 added [Anchor]
+    @since NEXT_RELEASE added [Stretch]
 *)
 type view = private
   | Empty
   | Text of {
       l: string list;
       style: Style.t;
     }
-  | Frame of t
+  | Frame of {
+      sub: t;
+      stretch: bool;
+    }
   | Pad of position * t (* vertical and horizontal padding *)
   | Align of {
       h: [ `Left | `Center | `Right ];
@@ -175,8 +179,10 @@ val bool : bool -> t
 val float : float -> t
 (** @since 0.2 *)
 
-val frame : t -> t
-(** Put a single frame around the box *)
+val frame : ?stretch:bool -> t -> t
+(** Put a single frame around the box.
+    @param stretch if true (default false), the frame expands to
+    fill the available space. Present since NEXT_RELEASE *)
 
 val pad : t -> t
 (** Pad the given box with some free space *)

src/printbox-html/PrintBox_html.ml

@@ -113,9 +113,9 @@ let sep_spans sep l =
          x
          ::
          (if i < len - 1 then
-           [ sep () ]
-         else
-           []))
+            [ sep () ]
+          else
+            []))
        l
 
 let br_lines ~bold l =
@@ -170,7 +170,7 @@ let to_html_rec ~config (b : B.t) =
     | B.Pad (_, b) ->
       (* FIXME: not implemented yet *)
       to_html_summary b
-    | B.Frame b ->
+    | B.Frame { sub = b; stretch = _ } ->
       H.span ~a:[ H.a_style "border:thin solid" ] [ to_html_summary b ]
     | B.Align { h = `Right; inner = b; v = _ } ->
       H.span ~a:[ H.a_class [ "align-right" ] ] [ to_html_summary b ]
@@ -203,12 +203,12 @@ let to_html_rec ~config (b : B.t) =
       | _ -> raise Summary_not_supported)
     | B.Tree _ | B.Link _ -> raise Summary_not_supported
   in
-  let loop
-        : 'tags.
-          (B.t ->
-          ([< Html_types.flow5 > `Pre `Span `Div `Ul `Table `P ] as 'tags) html) ->
-          B.t ->
-          'tags html =
+  let loop :
+        'tags.
+        (B.t ->
+        ([< Html_types.flow5 > `Pre `Span `Div `Ul `Table `P ] as 'tags) html) ->
+        B.t ->
+        'tags html =
    fun fix b ->
     match B.view b with
     | B.Empty ->
@@ -219,7 +219,8 @@ let to_html_rec ~config (b : B.t) =
     | B.Pad (_, b) ->
       (* FIXME: not implemented yet *)
       fix b
-    | B.Frame b -> H.div ~a:[ H.a_style "border:thin solid" ] [ fix b ]
+    | B.Frame { sub = b; _ } ->
+      H.div ~a:[ H.a_style "border:thin solid" ] [ fix b ]
     | B.Align { h = `Right; inner = b; v = _ } ->
       H.div ~a:[ H.a_class [ "align-right" ] ] [ fix b ]
     | B.Align { h = `Center; inner = b; v = _ } ->

src/printbox-md/PrintBox_md.ml

@@ -241,7 +241,7 @@ let rec multiline_heuristic c b =
   | B.Text { l = [ s ]; _ } -> String.contains s '\n'
   | B.Text _ -> true
   | B.Frame _ when c.Config.frames = `As_table -> true
-  | B.Frame b -> multiline_heuristic c b
+  | B.Frame { sub = b; _ } -> multiline_heuristic c b
   | B.Pad (_, _) -> true
   | B.Align { inner; _ } -> multiline_heuristic c inner
   | B.Grid (_, [| _ |]) when c.Config.hlists = `As_table -> true
@@ -277,7 +277,7 @@ let rec line_of_length_heuristic_exn c b =
       String.length s + from_bold + from_code
   | B.Text _ -> raise Not_found
   | B.Frame _ when c.Config.frames = `As_table -> raise Not_found
-  | B.Frame b ->
+  | B.Frame { sub = b; _ } ->
     (* "> " or "[]" *)
     line_of_length_heuristic_exn c b + 2
   | B.Pad (_, _) -> raise Not_found
@@ -310,7 +310,7 @@ let is_native_table c rows =
   let rec header h =
     match B.view h with
     | B.Text { l = [ _ ]; style = { B.Style.bold = true; _ } } -> true
-    | B.Frame b -> header b
+    | B.Frame { sub = b; _ } -> header b
     | _ -> false
   in
   Array.for_all header rows.(0)
@@ -322,7 +322,7 @@ let rec remove_bold b =
   match B.view b with
   | B.Empty | B.Text { l = []; _ } -> B.empty
   | B.Text { l; style } -> B.lines_with_style (B.Style.set_bold false style) l
-  | B.Frame b -> B.frame @@ remove_bold b
+  | B.Frame { sub = b; stretch } -> B.frame ~stretch @@ remove_bold b
   | B.Pad (pos, b) -> B.pad' ~col:pos.B.x ~lines:pos.B.y @@ remove_bold b
   | B.Align { h; v; inner } -> B.align ~h ~v @@ remove_bold inner
   | B.Grid _ -> assert false
@@ -362,7 +362,7 @@ let pp c out b =
         preformat out l;
       if code_block then fprintf out "@,%s```@,%s" prefix prefix;
       pp_print_string out sty_post
-    | B.Frame fb ->
+    | B.Frame { sub = fb; _ } ->
       (match c.Config.frames, c.Config.tables, no_block with
       | `As_table, `Html, _ ->
         (* Don't indent in case there's an embedded multiline preformatted text. *)

src/printbox-text/PrintBox_text.ml

@@ -28,9 +28,9 @@ end = struct
   let codes_of_style (self : t) : int list =
     let { bold; fg_color; bg_color; preformatted = _ } = self in
     (if bold then
-      [ 1 ]
-    else
-      [])
+       [ 1 ]
+     else
+       [])
     @ (match bg_color with
       | None -> []
       | Some c -> [ 40 + int_of_color_ c ])
@@ -78,6 +78,9 @@ module Pos = struct
 
   let origin = { x = 0; y = 0 }
   let[@inline] move pos x y = { x = pos.x + x; y = pos.y + y }
+
+  (* let[@inline] min p1 p2 = { x = min p1.x p2.x; y = min p1.y p2.y } *)
+  let[@inline] max p1 p2 = { x = max p1.x p2.x; y = max p1.y p2.y }
   let[@inline] ( + ) pos1 pos2 = move pos1 pos2.x pos2.y
   let[@inline] ( - ) pos1 pos2 = move pos1 (-pos2.x) (-pos2.y)
   let[@inline] ( * ) n pos = { x = n * pos.x; y = n * pos.y }
@@ -293,7 +296,10 @@ end = struct
         style: B.Style.t;
         link_with_uri: string option;
       }
-    | Frame of 'a
+    | Frame of {
+        sub: 'a;
+        stretch: bool;
+      }
     | Pad of position * 'a (* vertical and horizontal padding *)
     | Align of {
         h: [ `Left | `Center | `Right ];
@@ -478,7 +484,7 @@ end = struct
           0 l
       in
       { x = width; y = List.length l }
-    | Frame t -> Pos.move (size t) 2 2
+    | Frame { sub = t; _ } -> Pos.move (size t) 2 2
     | Pad (dim, b') -> Pos.(size b' + (2 * dim))
     | Align { inner = b'; _ } -> size b'
     | Grid (style, m) ->
@@ -521,7 +527,7 @@ end = struct
         let acc = ref [] in
         lines_l_ l (fun s i len -> acc := (s, i, len) :: !acc);
         Text { l = List.rev !acc; style; link_with_uri = None }
-      | B.Frame t -> Frame (of_box ~ansi t)
+      | B.Frame { sub = t; stretch } -> Frame { sub = of_box ~ansi t; stretch }
       | B.Pad (dim, t) -> Pad (dim, of_box ~ansi t)
       | B.Align { h; v; inner } -> Align { h; v; inner = of_box ~ansi inner }
       | B.Grid (bars, m) -> Grid (bars, B.map_matrix (of_box ~ansi) m)
@@ -530,7 +536,8 @@ end = struct
         let loop = B.link ~uri in
         (match B.view inner with
         | B.Empty -> Empty
-        | B.Frame t -> Frame (of_box ~ansi (loop t))
+        | B.Frame { sub = t; stretch } ->
+          Frame { stretch; sub = of_box ~ansi (loop t) }
         | B.Pad (dim, t) -> Pad (dim, of_box ~ansi (loop t))
         | B.Align { h; v; inner } ->
           Align { h; v; inner = of_box ~ansi (loop inner) }
@@ -588,7 +595,7 @@ end = struct
     done;
     conn_map.m <- create_or_update ?ct ~left:true (Pos.move_x pos n) conn_map.m
 
-  (* render given box on the output, starting with upper left corner
+  (** render given box on the output, starting with upper left corner
       at the given position. [expected_size] is the size of the
       available surrounding space. [offset] is the offset of the box
       w.r.t the surrounding box *)
@@ -614,8 +621,23 @@ end = struct
               Output.put_sub_string out (Pos.move_y pos line_idx) s s_i len)
           l;
         conn_m.m
-      | Frame b' ->
-        let { x; y } = size b' in
+      | Frame { sub = b'; stretch } ->
+        let p' = size b' in
+
+        (* do we expand? *)
+        let { x; y }, expected_size' =
+          match expected_size with
+          | Some exp_p when stretch ->
+            (* remove space for bars, but otherwise expand to [exp_p] *)
+            let exp_p' = Pos.move exp_p (-2) (-2) in
+            let p' = Pos.max p' exp_p' in
+            p', Some exp_p'
+          | Some _exp_p ->
+            (* ignore surrounding size (#45) *)
+            p', Some p'
+          | None -> p', None
+        in
+
         conn_m.m <- create_or_update ~right:true ~bottom:true pos conn_m.m;
         conn_m.m <-
           create_or_update ~left:true ~top:true
@@ -633,12 +655,7 @@ end = struct
         write_hline_ conn_m (Pos.move pos 1 (y + 1)) x;
         write_vline_ conn_m (Pos.move_y pos 1) y;
         write_vline_ conn_m (Pos.move pos (x + 1) 1) y;
-        let expected_size =
-          match expected_size with
-          | Some p -> Some (Pos.move p (-2) (-2)) (* remove space for bars *)
-          | None -> None
-        in
-        render_rec ~ansi ?expected_size b' (Pos.move pos 1 1)
+        render_rec ~ansi ?expected_size:expected_size' b' (Pos.move pos 1 1)
       | Pad (dim, b') ->
         let expected_size =
           match expected_size with

test/dune

@@ -45,3 +45,9 @@
  (mode promote)
  (action
   (copy %{deps} %{targets})))
+
+(test
+ (name reg_45)
+ (modules reg_45)
+ (package printbox-text)
+ (libraries printbox printbox-text))

test/reg_45.expected

@@ -0,0 +1,36 @@
+┌─────────┐
+│123456789│
+├─────────┤
+│┌─┐      │
+││.│      │
+│├─┤      │
+││.│      │
+│└─┘      │
+└─────────┘
+┌─────────┐
+│123456789│
+├─────────┤
+│┌────┐   │
+││....│   │
+│├────┤   │
+││.   │   │
+│└────┘   │
+└─────────┘
+┌─────────┐
+│123456789│
+├─────────┤
+│┌───────┐│
+││      .││
+│├───────┤│
+││.      ││
+│└───────┘│
+└─────────┘
+┌─────────┐
+│123456789│
+├─────────┤
+│┌───────┐│
+││   ....││
+│├───────┤│
+││.      ││
+│└───────┘│
+└─────────┘