feat: add a rich text API

rich text allows to mix styling within lines, across lines, etc.

Author: c-cube

src/PrintBox.ml

@@ -33,10 +33,7 @@ end
 
 type view =
   | Empty
-  | Text of {
-      l: string list;
-      style: Style.t;
-    }
+  | Text of rich_text
   | Frame of t
   | Pad of position * t (* vertical and horizontal padding *)
   | Align of {
@@ -51,21 +48,71 @@ type view =
       inner: t;
     }
 
+and rich_text =
+  | RT_str of string
+  | RT_style of Style.t * rich_text
+  | RT_cat of rich_text list
+
 and t = view
 
+module Rich_text = struct
+  type t = rich_text
+
+  type view = rich_text =
+    | RT_str of string
+    | RT_style of Style.t * rich_text
+    | RT_cat of rich_text list
+
+  let[@inline] view (self:t) : view = self
+
+  let line_ s : t = RT_str s
+  let line s : t =
+    if String.contains s '\n' then invalid_arg "PrintBox.Rich_text.line";
+    line_ s
+
+  let with_style style s : t = RT_style (style, s)
+  let bold s = with_style Style.bold s
+  let newline : t = RT_str "\n"
+  let space : t = RT_str " "
+
+  let cat l : t = match l with
+    | [] -> RT_str ""
+    | [x] -> x
+    | _ -> RT_cat l
+
+  let cat_with ~sep l =
+    let rec loop acc = function
+      | [] -> assert (acc=[]); RT_str ""
+      | [x] -> cat (List.rev (x::acc))
+      | x :: tl -> loop (sep :: x :: acc) tl
+    in
+    loop [] l
+
+  let lines l = cat_with ~sep:newline l
+  let lines_text l = lines @@ List.rev @@ List.rev_map line l
+
+  let text s : t = RT_str s
+
+  let sprintf fmt =
+    let buffer = Buffer.create 64 in
+    Printf.kbprintf (fun _ -> text (Buffer.contents buffer)) buffer fmt
+  let asprintf fmt = Format.kasprintf text fmt
+
+  let s = text
+end
+
 let empty = Empty
 let[@inline] view (t:t) : view = t
 
-let[@inline] line_ s = Text {l=[s]; style=Style.default}
-
-let line_with_style style s =
-  if String.contains s '\n' then invalid_arg "PrintBox.line";
-  Text {l=[s]; style}
+(* no check for \n *)
+let[@inline] line_ s = Text (Rich_text.line_ s)
 
-let line s = line_with_style Style.default s
+let[@inline] line s = Text (Rich_text.line s)
+let[@inline] line_with_style style str = Text (Rich_text.(with_style style @@ line str))
 
-let text s = Text {l=[s]; style=Style.default}
-let text_with_style style s = Text {l=[s]; style}
+let rich_text t : t = Text t
+let text s = Text (Rich_text.text s)
+let text_with_style style str = Text Rich_text.(with_style style @@ text str)
 
 let sprintf_with_style style format =
   let buffer = Buffer.create 64 in
@@ -78,8 +125,9 @@ let sprintf format = sprintf_with_style Style.default format
 let asprintf format = Format.kasprintf text format
 let asprintf_with_style style format = Format.kasprintf (text_with_style style) format
 
-let[@inline] lines l = Text {l; style=Style.default}
-let[@inline] lines_with_style style l = Text {l; style}
+let[@inline] lines l = Text (Rich_text.lines_text l)
+let[@inline] lines_with_style style l =
+  Text Rich_text.(with_style style @@ lines_text l)
 
 let int x = line_ (string_of_int x)
 let float x = line_ (string_of_float x)

src/PrintBox.mli

@@ -102,6 +102,10 @@ type t
 (** Main type for a document composed of nested boxes.
     @since 0.2 the type [t] is opaque *)
 
+type rich_text
+(** Text with formatting and new lines.
+    @since NEXT_RELEASE *)
+
 (** The type [view] can be used to observe the inside of the box,
     now that [t] is opaque.
 
@@ -110,10 +114,7 @@ type t
 *)
 type view = private
   | Empty
-  | Text of {
-      l: string list;
-      style: Style.t;
-    }
+  | Text of rich_text
   | Frame of t
   | Pad of position * t (* vertical and horizontal padding *)
   | Align of {
@@ -157,10 +158,16 @@ val lines : string list -> t
     [lines l] is the same as [text (String.concat "\n" l)]. *)
 
 val int_ : int -> t
+(** @deprecated use {!int} *)
+[@@deprecated "use int"]
 
 val bool_ : bool -> t
+(** @deprecated use {!bool} *)
+[@@deprecated "use bool"]
 
 val float_ : float -> t
+(** @deprecated use {!float} *)
+[@@deprecated "use float"]
 
 val int : int -> t
 (** @since 0.2 *)
@@ -171,6 +178,10 @@ val bool : bool -> t
 val float : float -> t
 (** @since 0.2 *)
 
+val rich_text : rich_text -> t
+(** A box containing rich text. See {!Rich_text} for more.
+    @since NEXT_RELEASE *)
+
 val frame : t -> t
 (** Put a single frame around the box *)
 
@@ -240,14 +251,14 @@ val init_grid : ?bars:bool ->
   line:int -> col:int -> (line:int -> col:int -> t) -> t
 (** Same as {!grid} but takes the matrix as a function *)
 
-val grid_l : 
+val grid_l :
   ?pad:(t -> t) ->
   ?bars:bool ->
   t list list -> t
 (** Same as {!grid} but from lists.
     @since 0.3 *)
 
-val grid_text_l : 
+val grid_text_l :
   ?pad:(t -> t) ->
   ?bars:bool ->
   string list list -> t
@@ -338,11 +349,66 @@ val asprintf_with_style : Style.t -> ('a, Format.formatter, unit, t) format4 ->
 (** Formatting for {!text}, with style.
     @since 0.3 *)
 
+(** Rich text *)
+module Rich_text : sig
+  type t = rich_text
+
+  (** View on the internals of the rich text.
+      {b NOTE} this is unstable for now, no promise of stability is made. *)
+  type view = private
+    | RT_str of string
+    | RT_style of Style.t * t
+    | RT_cat of t list
+
+  val view : t -> view
+
+  val s : string -> t
+  (** Short for {!text} *)
+
+  val line : string -> t
+  (** Make a single-line text object.
+      @raise Invalid_argument if the string contains ['\n'] *)
+
+  val text : string -> t
+  (** Any text, possibly with several lines *)
+
+  val space : t
+
+  val newline : t
+
+  val cat : t list -> t
+  (** [cat txts] is the concatenation of items in [txts]. *)
+
+  val cat_with : sep:t -> t list -> t
+  (** [concat_with ~sep l] concatenates items of [l],
+      inserting [sep] in between each. It doesn't add [sep] after
+      the last element. *)
+
+  val lines : t list -> t
+  (** Concatenate with interspersed new lines *)
+
+  val lines_text : string list -> t
+  (** same as [lines @@ List.map line l] *)
+
+  val sprintf : ('a, Buffer.t, unit, t) format4 -> 'a
+  (** Formatting. *)
+
+  val asprintf : ('a, Format.formatter, unit, t) format4 -> 'a
+  (** Formatting. *)
+
+  val with_style : Style.t -> t -> t
+  (** Add style to the text. *)
+
+  val bold : t -> t
+  (** Short for [with_style Style.bold] *)
+end
+
 (** {2 Simple Structural Interface} *)
 
 type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
 type box = t
 
+(** A simple interface. *)
 module Simple : sig
   type t =
     [ `Empty

src/printbox-html/PrintBox_html.ml

@@ -86,13 +86,20 @@ let rec to_html_rec ~config (b: B.t) : [< Html_types.flow5 > `Div `Ul `Table `P]
   let to_html_rec = to_html_rec ~config in
   match B.view b with
   | B.Empty -> H.div []
-  | B.Text {l; style} ->
-    let a, bold = attrs_of_style style in
-    let l = List.map H.txt l in
-    let l = if bold then List.map (fun x->H.b [x]) l else l in
-    H.div
-      ~a:(H.a_class config.cls_text :: (a @ config.a_text))
-      l
+  | B.Text rt ->
+    let module RT = B.Rich_text in
+    let rec conv_rt style rt =
+      match RT.view rt with
+      | RT.RT_str s ->
+        let a, bold = attrs_of_style style in
+        let s = H.txt s in
+        let s = if bold then H.b [s] else s in
+        H.div [s]
+          ~a:(H.a_class config.cls_text :: (a @ config.a_text))
+      | RT.RT_cat l -> H.div (List.map (conv_rt style) l)
+      | RT.RT_style (style, sub) -> conv_rt style sub
+    in
+    conv_rt B.Style.default rt
   | B.Pad (_, b)
   | B.Frame b -> to_html_rec b
   | B.Align {h=`Right;inner=b;v=_} ->