diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..2124d7d --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,15 @@ +version = 0.24.1 +profile=conventional +margin=80 +if-then-else=k-r +parens-ite=true +parens-tuple=multi-line-only +sequence-style=terminator +type-decl=sparse +break-cases=toplevel +cases-exp-indent=2 +field-space=tight-decl +leading-nested-match-parens=true +module-item-spacing=compact +quiet=true +ocaml-version=4.08.0 diff --git a/dune b/dune index 4b43da6..349e030 100644 --- a/dune +++ b/dune @@ -1,4 +1,3 @@ - (mdx (package printbox-html) (libraries printbox printbox-text printbox-html) diff --git a/examples/lambda.ml b/examples/lambda.ml index 03fd6bf..b7974a8 100644 --- a/examples/lambda.ml +++ b/examples/lambda.ml @@ -1,7 +1,5 @@ - (** Example of printing trees: lambda-term evaluation *) - type term = | Lambda of string * term | App of term * term @@ -14,92 +12,99 @@ let _gensym = incr r; s -module SSet = Set.Make(String) -module SMap = Map.Make(String) +module SSet = Set.Make (String) +module SMap = Map.Make (String) -let rec fvars t = match t with +let rec fvars t = + match t with | Var s -> SSet.singleton s - | Lambda (v,t') -> - let set' = fvars t' in - SSet.remove v set' + | Lambda (v, t') -> + let set' = fvars t' in + SSet.remove v set' | App (t1, t2) -> SSet.union (fvars t1) (fvars t2) (* replace [var] with the term [by] *) -let rec replace t ~var ~by = match t with - | Var s -> if s=var then by else t - | App (t1,t2) -> App (replace t1 ~var ~by, replace t2 ~var ~by) - | Lambda (v, _t') when v=var -> t (* no risk *) +let rec replace t ~var ~by = + match t with + | Var s -> + if s = var then + by + else + t + | App (t1, t2) -> App (replace t1 ~var ~by, replace t2 ~var ~by) + | Lambda (v, _t') when v = var -> t (* no risk *) | Lambda (v, t') -> Lambda (v, replace t' ~var ~by) (* rename [t] so that [var] doesn't occur in it *) let rename ~var t = - if SSet.mem var (fvars t) - then replace t ~var ~by:(Var (_gensym ())) - else t + if SSet.mem var (fvars t) then + replace t ~var ~by:(Var (_gensym ())) + else + t -let (>>=) o f = match o with +let ( >>= ) o f = + match o with | None -> None | Some x -> f x -let rec one_step t = match t with +let rec one_step t = + match t with | App (Lambda (var, t1), t2) -> - let t2' = rename ~var t2 in - Some (replace t1 ~var ~by:t2') + let t2' = rename ~var t2 in + Some (replace t1 ~var ~by:t2') | App (t1, t2) -> - begin match one_step t1 with - | None -> - one_step t2 >>= fun t2' -> - Some (App (t1,t2')) - | Some t1' -> - Some (App (t1',t2)) - end + (match one_step t1 with + | None -> one_step t2 >>= fun t2' -> Some (App (t1, t2')) + | Some t1' -> Some (App (t1', t2))) | Var _ -> None - | Lambda (v,t') -> - one_step t' >>= fun t'' -> - Some (Lambda (v, t'')) + | Lambda (v, t') -> one_step t' >>= fun t'' -> Some (Lambda (v, t'')) let normal_form t = - let rec aux acc t = match one_step t with - | None -> List.rev (t::acc) - | Some t' -> aux (t::acc) t' + let rec aux acc t = + match one_step t with + | None -> List.rev (t :: acc) + | Some t' -> aux (t :: acc) t' in aux [] t let _split_fuel f = - assert (f>=2); - if f=2 then 1,1 - else - let x = 1+Random.int (f-1) in - f-x, x + assert (f >= 2); + if f = 2 then + 1, 1 + else ( + let x = 1 + Random.int (f - 1) in + f - x, x + ) let _random_var () = let v = [| "x"; "y"; "z"; "u"; "w" |] in v.(Random.int (Array.length v)) -let _choose_var ~vars = match vars with +let _choose_var ~vars = + match vars with | [] -> Var (_random_var ()) - | _::_ -> - let i = Random.int (List.length vars) in - List.nth vars i + | _ :: _ -> + let i = Random.int (List.length vars) in + List.nth vars i let rec _random_term fuel vars = match Random.int 2 with | _ when fuel = 1 -> _choose_var ~vars | 0 -> - let f1,f2 = _split_fuel fuel in - App (_random_term f1 vars, _random_term f2 vars) + let f1, f2 = _split_fuel fuel in + App (_random_term f1 vars, _random_term f2 vars) | 1 -> - let v = _random_var () in - Lambda (v, _random_term (fuel-1) (Var v::vars)) + let v = _random_var () in + Lambda (v, _random_term (fuel - 1) (Var v :: vars)) | _ -> assert false let print_term t = PrintBox.mk_tree (function | Var v -> PrintBox.line v, [] - | App (t1,t2) -> PrintBox.line "app", [t1;t2] - | Lambda (v,t') -> PrintBox.line "lambda", [Var v; t'] - ) t + | App (t1, t2) -> PrintBox.line "app", [ t1; t2 ] + | Lambda (v, t') -> PrintBox.line "lambda", [ Var v; t' ]) + t let print_reduction t = let l = normal_form t in diff --git a/src/PrintBox.ml b/src/PrintBox.ml index 770b361..6e90767 100644 --- a/src/PrintBox.ml +++ b/src/PrintBox.ml @@ -2,7 +2,10 @@ (** {1 Pretty-Printing of Boxes} *) -type position = { x:int ; y: int } +type position = { + x: int; + y: int; +} module Style = struct type color = @@ -22,12 +25,13 @@ module Style = struct preformatted: bool; } - let default = {bold=false; bg_color=None; fg_color=None; preformatted=false} - let set_bg_color c self = {self with bg_color=Some c} - let set_fg_color c self = {self with fg_color=Some c} - let set_bold b self = {self with bold=b} - let set_preformatted b self = {self with preformatted=b} + let default = + { bold = false; bg_color = None; fg_color = None; preformatted = false } + let set_bg_color c self = { self with bg_color = Some c } + let set_fg_color c self = { self with fg_color = Some c } + let set_bold b self = { self with bold = b } + let set_preformatted b self = { self with preformatted = b } let bold : t = set_bold true default let preformatted : t = set_preformatted true default let bg_color c : t = set_bg_color c default @@ -43,11 +47,11 @@ type view = | Frame of t | Pad of position * t (* vertical and horizontal padding *) | Align of { - h: [`Left | `Center | `Right]; - v: [`Top | `Center | `Bottom]; + h: [ `Left | `Center | `Right ]; + v: [ `Top | `Center | `Bottom ]; inner: t; } - | Grid of [`Bars | `None] * t array array + | Grid of [ `Bars | `None ] * t array array | Tree of int * t * t array | Link of { uri: string; @@ -57,93 +61,94 @@ type view = and t = view let empty = Empty -let[@inline] view (t:t) : view = t - -let[@inline] line_ s = Text {l=[s]; style=Style.default} +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} + Text { l = [ s ]; style } let line s = line_with_style Style.default s let[@inline] mk_text_ s : string list = - if String.contains s '\n' then String.split_on_char '\n' s else [s] + if String.contains s '\n' then + String.split_on_char '\n' s + else + [ s ] -let[@inline] text s = Text {l=mk_text_ s; style=Style.default} -let[@inline] text_with_style style s = Text {l=mk_text_ s; style} +let[@inline] text s = Text { l = mk_text_ s; style = Style.default } +let[@inline] text_with_style style s = Text { l = mk_text_ s; style } let sprintf_with_style style format = let buffer = Buffer.create 64 in Printf.kbprintf (fun _ -> text_with_style style (Buffer.contents buffer)) - buffer - format + buffer format 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 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 int x = line_ (string_of_int x) let float x = line_ (string_of_float x) let bool x = line_ (string_of_bool x) - let int_ = int let float_ = float let bool_ = bool - let[@inline] frame b = Frame b let pad' ~col ~lines b = - assert (col >=0 || lines >= 0); - if col=0 && lines=0 - then b - else Pad ({x=col;y=lines}, b) + assert (col >= 0 || lines >= 0); + if col = 0 && lines = 0 then + b + else + Pad ({ x = col; y = lines }, b) let pad b = pad' ~col:1 ~lines:1 b - let hpad col b = pad' ~col ~lines:0 b let vpad lines b = pad' ~col:0 ~lines b - -let align ~h ~v b : t = Align {h; v; inner=b} +let align ~h ~v b : t = Align { h; v; inner = b } let align_bottom b = align ~h:`Left ~v:`Bottom b let align_right b = align ~h:`Right ~v:`Top b let align_bottom_right b = align ~h:`Right ~v:`Bottom b let center_h b = align ~h:`Center ~v:`Top b let center_v b = align ~h:`Left ~v:`Center b let center_hv b = align ~h:`Center ~v:`Center b +let map_matrix f m = Array.map (Array.map f) m -let map_matrix f m = - Array.map (Array.map f) m - -let grid ?(pad=fun b->b) ?(bars=true) m = +let grid ?(pad = fun b -> b) ?(bars = true) m = let m = map_matrix pad m in - Grid ((if bars then `Bars else `None), m) + Grid + ( (if bars then + `Bars + else + `None), + m ) let grid_l ?pad ?bars l = grid ?pad ?bars (Array.of_list l |> Array.map Array.of_list) let init_grid ?bars ~line ~col f = - let m = Array.init line (fun j-> Array.init col (fun i -> f ~line:j ~col:i)) in + let m = + Array.init line (fun j -> Array.init col (fun i -> f ~line:j ~col:i)) + in grid ?bars m let vlist ?pad ?bars l = let a = Array.of_list l in grid ?pad ?bars (Array.map (fun line -> [| line |]) a) -let hlist ?pad ?bars l = - grid ?pad ?bars [| Array.of_list l |] - +let hlist ?pad ?bars l = grid ?pad ?bars [| Array.of_list l |] let hlist_map ?bars f l = hlist ?bars (List.map f l) let vlist_map ?bars f l = vlist ?bars (List.map f l) let grid_map ?bars f m = grid ?bars (Array.map (Array.map f) m) - let grid_map_l ?bars f m = grid_l ?bars (List.map (List.map f) m) -let grid_text ?(pad=fun x->x) ?bars m = +let grid_text ?(pad = fun x -> x) ?bars m = grid_map ?bars (fun x -> pad (text x)) m let grid_text_l ?pad ?bars l = @@ -151,21 +156,22 @@ let grid_text_l ?pad ?bars l = let record ?pad ?bars l = let fields, vals = List.split l in - grid_l ?pad ?bars [List.map text fields; vals] + grid_l ?pad ?bars [ List.map text fields; vals ] let v_record ?pad ?bars l = - grid_l ?pad ?bars (List.map (fun (f,v) -> [text f; v]) l) + grid_l ?pad ?bars (List.map (fun (f, v) -> [ text f; v ]) l) let dim_matrix m = - if Array.length m = 0 then {x=0;y=0} - else {y=Array.length m; x=Array.length m.(0); } + if Array.length m = 0 then + { x = 0; y = 0 } + else + { y = Array.length m; x = Array.length m.(0) } let transpose m = let dim = dim_matrix m in - Array.init dim.x - (fun i -> Array.init dim.y (fun j -> m.(j).(i))) + Array.init dim.x (fun i -> Array.init dim.y (fun j -> m.(j).(i))) -let tree ?(indent=0) node children = +let tree ?(indent = 0) node children = if indent < 0 then invalid_arg "tree: need non-negative indent"; let children = List.filter @@ -176,22 +182,23 @@ let tree ?(indent=0) node children = in match children with | [] -> node - | _::_ -> + | _ :: _ -> let children = Array.of_list children in Tree (indent, node, children) let mk_tree ?indent f root = - let rec make x = match f x with + let rec make x = + match f x with | b, [] -> b | b, children -> tree ?indent b (List.map make children) in make root -let link ~uri inner : t = Link {uri; inner} +let link ~uri inner : t = Link { uri; inner } (** {2 Simple Structural Interface} *) -type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] +type 'a ktree = unit -> [ `Nil | `Node of 'a * 'a ktree list ] type box = t module Simple = struct @@ -212,23 +219,21 @@ module Simple = struct | `Vlist l -> vlist (List.map to_box l) | `Hlist l -> hlist (List.map to_box l) | `Table a -> grid (map_matrix to_box a) - | `Tree (b,l) -> tree (to_box b) (List.map to_box l) + | `Tree (b, l) -> tree (to_box b) (List.map to_box l) - let rec of_ktree t = match t () with + let rec of_ktree t = + match t () with | `Nil -> `Empty | `Node (x, l) -> `Tree (x, List.map of_ktree l) - let rec map_ktree f t = match t () with + let rec map_ktree f t = + match t () with | `Nil -> `Empty | `Node (x, l) -> `Tree (f x, List.map (map_ktree f) l) let sprintf format = let buffer = Buffer.create 64 in - Printf.kbprintf - (fun _ -> `Text (Buffer.contents buffer)) - buffer - format + Printf.kbprintf (fun _ -> `Text (Buffer.contents buffer)) buffer format - let asprintf format = - Format.kasprintf (fun s -> `Text s) format + let asprintf format = Format.kasprintf (fun s -> `Text s) format end diff --git a/src/PrintBox.mli b/src/PrintBox.mli index caf8433..fbb8b25 100644 --- a/src/PrintBox.mli +++ b/src/PrintBox.mli @@ -54,7 +54,10 @@ *) -type position = { x:int ; y: int } +type position = { + x: int; + y: int; +} (** Positions are relative to the upper-left corner, that is, when [x] increases we go toward the right, and when [y] increases we go toward the bottom (same order as a printer) *) @@ -75,30 +78,22 @@ module Style : sig type t = { bold: bool; - bg_color: color option; (** backgroud color *) - fg_color: color option; (** foreground color *) + bg_color: color option; (** backgroud color *) + fg_color: color option; (** foreground color *) preformatted: bool; - (** where supported, the text rendering should be monospaced and respect whitespace *) + (** where supported, the text rendering should be monospaced and respect whitespace *) } (** Basic styling (color, bold). @since 0.3 *) val default : t - val set_bg_color : color -> t -> t - val set_fg_color : color -> t -> t - val set_bold : bool -> t -> t - val set_preformatted : bool -> t -> t - val bg_color : color -> t - val fg_color : color -> t - val bold : t - val preformatted : t end @@ -123,11 +118,11 @@ type view = private | Frame of t | Pad of position * t (* vertical and horizontal padding *) | Align of { - h: [`Left | `Center | `Right]; - v: [`Top | `Center | `Bottom]; + h: [ `Left | `Center | `Right ]; + v: [ `Top | `Center | `Bottom ]; inner: t; - } (** Alignment within the surrounding box *) - | Grid of [`Bars | `None] * t array array + } (** Alignment within the surrounding box *) + | Grid of [ `Bars | `None ] * t array array | Tree of int * t * t array (* int: indent *) | Link of { uri: string; @@ -163,9 +158,7 @@ val lines : string list -> t [lines l] is the same as [text (String.concat "\n" l)]. *) val int_ : int -> t - val bool_ : bool -> t - val float_ : float -> t val int : int -> t @@ -192,7 +185,8 @@ val vpad : int -> t -> t val hpad : int -> t -> t (** Pad horizontally by [n] spaces *) -val align : h:[`Left | `Right | `Center] -> v:[`Top | `Bottom | `Center] -> t -> t +val align : + h:[ `Left | `Right | `Center ] -> v:[ `Top | `Bottom | `Center ] -> t -> t (** Control alignment of the given box wrt its surrounding box, if any. @param h horizontal alignment @param v vertical alignment @@ -222,10 +216,7 @@ val center_hv : t -> t (** Try to center within the surrounding box, as in [align ~h:`Center ~v:`Center] @since 0.3 *) -val grid : - ?pad:(t -> t) -> - ?bars:bool -> - t array array -> t +val grid : ?pad:(t -> t) -> ?bars:bool -> t array array -> t (** Grid of boxes (no frame between boxes). The matrix is indexed with lines first, then columns. The array must be a proper matrix, that is, all lines must have the same number of columns! @@ -234,36 +225,25 @@ val grid : @param bars if true, each item of the grid will be framed. default value is [true] *) -val grid_text : - ?pad:(t -> t) -> ?bars:bool -> - string array array -> t +val grid_text : ?pad:(t -> t) -> ?bars:bool -> string array array -> t (** Same as {!grid}, but wraps every cell into a {!text} box *) val transpose : 'a array array -> 'a array array (** Transpose a matrix *) -val init_grid : ?bars:bool -> - line:int -> col:int -> (line:int -> col:int -> t) -> t +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 : - ?pad:(t -> t) -> - ?bars:bool -> - t list list -> t +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 : - ?pad:(t -> t) -> - ?bars:bool -> - string list list -> t +val grid_text_l : ?pad:(t -> t) -> ?bars:bool -> string list list -> t (** Same as {!grid_text} but from lists. @since 0.3 *) -val record : - ?pad:(t -> t) -> - ?bars:bool -> - (string * t) list -> t +val record : ?pad:(t -> t) -> ?bars:bool -> (string * t) list -> t (** A record displayed as a table, each field being a columng [(label,value)]. {[ # frame @@ record ["a", int 1; "b", float 3.14; "c", bool true];; @@ -275,10 +255,7 @@ val record : ]} @since 0.3 *) -val v_record : - ?pad:(t -> t) -> - ?bars:bool -> - (string * t) list -> t +val v_record : ?pad:(t -> t) -> ?bars:bool -> (string * t) list -> t (** Like {!record}, but printed vertically rather than horizontally. {[ # frame @@ v_record ["a", int 1; "b", float 3.14; "c", bool true];; @@ -305,7 +282,6 @@ val grid_map_l : ?bars:bool -> ('a -> t) -> 'a list list -> t @since 0.4 *) val vlist_map : ?bars:bool -> ('a -> t) -> 'a list -> t - val hlist_map : ?bars:bool -> ('a -> t) -> 'a list -> t val tree : ?indent:int -> t -> t list -> t @@ -340,13 +316,14 @@ val sprintf_with_style : Style.t -> ('a, Buffer.t, unit, t) format4 -> 'a (** Formatting for {!text}, with style @since 0.3 *) -val asprintf_with_style : Style.t -> ('a, Format.formatter, unit, t) format4 -> 'a +val asprintf_with_style : + Style.t -> ('a, Format.formatter, unit, t) format4 -> 'a (** Formatting for {!text}, with style. @since 0.3 *) (** {2 Simple Structural Interface} *) -type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] +type 'a ktree = unit -> [ `Nil | `Node of 'a * 'a ktree list ] type box = t module Simple : sig diff --git a/src/printbox-html/PrintBox_html.ml b/src/printbox-html/PrintBox_html.ml index ef4754d..743419c 100644 --- a/src/printbox-html/PrintBox_html.ml +++ b/src/printbox-html/PrintBox_html.ml @@ -3,7 +3,6 @@ (** {1 Output HTML} *) open Tyxml - module B = PrintBox module H = Html @@ -11,24 +10,24 @@ type 'a html = 'a Html.elt let prelude = let l = - [ "table, th, td { border-collapse: collapse; }" - ; "table.framed { border: 2px solid black; }" - ; "table.framed th, table.framed td { border: 1px solid black; }" - ; "th, td { padding: 3px; }" - ; "tr:nth-child(even) { background-color: #eee; }" - ; "tr:nth-child(odd) { background-color: #fff; }" - ; ".align-right { text-align: right; }" - ; ".center { text-align: center; }" + [ + "table, th, td { border-collapse: collapse; }"; + "table.framed { border: 2px solid black; }"; + "table.framed th, table.framed td { border: 1px solid black; }"; + "th, td { padding: 3px; }"; + "tr:nth-child(even) { background-color: #eee; }"; + "tr:nth-child(odd) { background-color: #fff; }"; + ".align-right { text-align: right; }"; + ".center { text-align: center; }"; ] in H.style (List.map H.pcdata l) -let prelude_str = - Format.asprintf "%a@." (H.pp_elt ()) prelude +let prelude_str = Format.asprintf "%a@." (H.pp_elt ()) prelude -let attrs_of_style (s:B.Style.t) : _ list * _ = +let attrs_of_style (s : B.Style.t) : _ list * _ = let open B.Style in - let {bold;bg_color;fg_color;preformatted} = s in + let { bold; bg_color; fg_color; preformatted } = s in let encode_color = function | Red -> "red" | Blue -> "blue" @@ -40,13 +39,27 @@ let attrs_of_style (s:B.Style.t) : _ list * _ = | White -> "white" in let s = - (match bg_color with None -> [] | Some c -> ["background-color", encode_color c]) @ - (match fg_color with None -> [] | Some c -> ["color", encode_color c]) @ - (if preformatted then ["font-family", "monospace"] else []) + (match bg_color with + | None -> [] + | Some c -> [ "background-color", encode_color c ]) + @ (match fg_color with + | None -> [] + | Some c -> [ "color", encode_color c ]) + @ + if preformatted then + [ "font-family", "monospace" ] + else + [] in - let a = match s with + let a = + match s with | [] -> [] - | s -> [H.a_style @@ String.concat ";" @@ List.map (fun (k,v) -> k ^ ": " ^ v) s] in + | s -> + [ + H.a_style @@ String.concat ";" + @@ List.map (fun (k, v) -> k ^ ": " ^ v) s; + ] + in a, bold module Config = struct @@ -62,125 +75,159 @@ module Config = struct tree_summary: bool; } - let default : t = { - cls_table=[]; - a_table=[]; - cls_text=[]; - a_text=[]; - cls_row=[]; - a_row=[]; - cls_col=[]; - a_col=[]; - tree_summary=false; - } + let default : t = + { + cls_table = []; + a_table = []; + cls_text = []; + a_text = []; + cls_row = []; + a_row = []; + cls_col = []; + a_col = []; + tree_summary = false; + } - let cls_table x c = {c with cls_table=x} - let a_table x c = {c with a_table=x} - let cls_text x c = {c with cls_text=x} - let a_text x c = {c with a_text=x} - let cls_row x c = {c with cls_row=x} - let a_row x c = {c with a_row=x} - let cls_col x c = {c with cls_col=x} - let a_col x c = {c with a_col=x} - let tree_summary x c = {c with tree_summary=x} + let cls_table x c = { c with cls_table = x } + let a_table x c = { c with a_table = x } + let cls_text x c = { c with cls_text = x } + let a_text x c = { c with a_text = x } + let cls_row x c = { c with cls_row = x } + let a_row x c = { c with a_row = x } + let cls_col x c = { c with cls_col = x } + let a_col x c = { c with a_col = x } + let tree_summary x c = { c with tree_summary = x } end -let to_html_rec ~config (b: B.t) = +let to_html_rec ~config (b : B.t) = let open Config in - let h_text_to_html ?(border=false) ~l ~style () = + let h_text_to_html ?(border = false) ~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 - let a_border = if border then [H.a_style "border:thin solid"] else [] in - H.span ~a:(H.a_class config.cls_text :: a_border @ (a @ config.a_text)) l in - let v_text_to_html ?(border=false) ~l ~style () = + let l = + if bold then + List.map (fun x -> H.b [ x ]) l + else + l + in + let a_border = + if border then + [ H.a_style "border:thin solid" ] + else + [] + in + H.span ~a:((H.a_class config.cls_text :: a_border) @ a @ config.a_text) l + in + let v_text_to_html ?(border = false) ~l ~style () = let a, bold = attrs_of_style style in - let a_border = if border then [H.a_style "border:thin solid"] else [] in + let a_border = + if border then + [ H.a_style "border:thin solid" ] + else + [] + in if style.B.Style.preformatted then - H.pre ~a:(H.a_class config.cls_text :: a_border @ (a @ config.a_text)) - [H.txt @@ String.concat "\n" l] - else + H.pre + ~a:((H.a_class config.cls_text :: a_border) @ a @ config.a_text) + [ H.txt @@ String.concat "\n" l ] + else ( (* TODO: remove possible trailing '\r' *) - let l = List.map H.txt @@ List.concat @@ List.map (String.split_on_char '\n') l in + let l = + List.map H.txt @@ List.concat @@ List.map (String.split_on_char '\n') l + in let len = List.length l in let l = - List.concat @@ List.mapi - (fun i x-> (if bold then H.b [x] else x) :: if i < len - 1 then [H.br ()] else []) l in - H.div ~a:(H.a_class config.cls_text :: a_border @ (a @ config.a_text)) l in - 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 -> (H.div [] :> [< Html_types.flow5 > `Pre `Span `Div `P `Table `Ul ] html) - (* | B.Text {l; style} when style.B.Style.preformatted -> H.pre [h_text_to_html ~l ~style ()] *) - | B.Text {l; style} -> v_text_to_html ~l ~style () - | B.Pad (_, b) -> fix b - | B.Frame 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=_} -> - H.div ~a:[H.a_class ["center"]] [ fix b ] - | B.Align {inner=b;_} -> fix b - | B.Grid (bars, a) -> - let class_ = match bars with - | `Bars -> "framed" - | `None -> "non-framed" - in - let to_row a = - Array.to_list a - |> List.map - (fun b -> H.td ~a:(H.a_class config.cls_col :: config.a_col) [fix b]) - |> (fun x -> H.tr ~a:(H.a_class config.cls_row :: config.a_row) x) - in - let rows = - Array.to_list a |> List.map to_row - in - H.table ~a:(H.a_class (class_ :: config.cls_table)::config.a_table) rows - | B.Tree (_, b, l) -> - let l = Array.to_list l in - H.div - [ fix b - ; H.ul (List.map (fun x -> H.li [fix x]) l) - ] - | B.Link _ -> assert false + List.concat + @@ List.mapi + (fun i x -> + (if bold then + H.b [ x ] + else + x) + :: + (if i < len - 1 then + [ H.br () ] + else + [])) + l + in + H.div ~a:((H.a_class config.cls_text :: a_border) @ a @ config.a_text) l + ) + in + 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 -> + (H.div [] :> [< Html_types.flow5 > `Pre `Span `Div `P `Table `Ul ] html) + (* | B.Text {l; style} when style.B.Style.preformatted -> H.pre [h_text_to_html ~l ~style ()] *) + | B.Text { l; style } -> v_text_to_html ~l ~style () + | B.Pad (_, b) -> fix b + | B.Frame 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 = _ } -> + H.div ~a:[ H.a_class [ "center" ] ] [ fix b ] + | B.Align { inner = b; _ } -> fix b + | B.Grid (bars, a) -> + let class_ = + match bars with + | `Bars -> "framed" + | `None -> "non-framed" + in + let to_row a = + Array.to_list a + |> List.map (fun b -> + H.td ~a:(H.a_class config.cls_col :: config.a_col) [ fix b ]) + |> fun x -> H.tr ~a:(H.a_class config.cls_row :: config.a_row) x + in + let rows = Array.to_list a |> List.map to_row in + H.table ~a:(H.a_class (class_ :: config.cls_table) :: config.a_table) rows + | B.Tree (_, b, l) -> + let l = Array.to_list l in + H.div [ fix b; H.ul (List.map (fun x -> H.li [ fix x ]) l) ] + | B.Link _ -> assert false in let rec to_html_rec b = match B.view b with | B.Tree (_, b, l) when config.tree_summary -> let l = Array.to_list l in (match B.view b with - | B.Text {l=tl; style} -> - H.details (H.summary [h_text_to_html ~l:tl ~style ()]) - [ H.ul (List.map (fun x -> H.li [to_html_rec x]) l) ] + | B.Text { l = tl; style } -> + H.details + (H.summary [ h_text_to_html ~l:tl ~style () ]) + [ H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l) ] | B.Frame b -> (match B.view b with - | (B.Text {l=tl; style}) -> - H.details (H.summary [h_text_to_html ~border:true ~l:tl ~style ()]) - [ H.ul (List.map (fun x -> H.li [to_html_rec x]) l) ] + | B.Text { l = tl; style } -> + H.details + (H.summary [ h_text_to_html ~border:true ~l:tl ~style () ]) + [ H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l) ] | _ -> H.div - [ to_html_rec b - ; H.ul (List.map (fun x -> H.li [to_html_rec x]) l) + [ + to_html_rec b; H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l); ]) | _ -> H.div - [ to_html_rec b - ; H.ul (List.map (fun x -> H.li [to_html_rec x]) l) - ]) - | B.Link {uri; inner} -> - H.div [H.a ~a:[H.a_href uri] [to_html_nondet_rec inner]] + [ to_html_rec b; H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l) ]) + | B.Link { uri; inner } -> + H.div [ H.a ~a:[ H.a_href uri ] [ to_html_nondet_rec inner ] ] | _ -> loop to_html_rec b and to_html_nondet_rec b = match B.view b with - | B.Text {l; style} -> v_text_to_html ~l ~style () - | B.Link {uri; inner} -> - H.div [H.a ~a:[H.a_href uri] [to_html_nondet_rec inner]] + | B.Text { l; style } -> v_text_to_html ~l ~style () + | B.Link { uri; inner } -> + H.div [ H.a ~a:[ H.a_href uri ] [ to_html_nondet_rec inner ] ] | _ -> loop to_html_nondet_rec b in to_html_rec b -let to_html ?(config=Config.default) b = H.div [to_html_rec ~config b] +let to_html ?(config = Config.default) b = H.div [ to_html_rec ~config b ] let to_string ?config b = Format.asprintf "@[%a@]@." (H.pp_elt ()) (to_html ?config b) @@ -188,22 +235,22 @@ let to_string ?config b = let to_string_indent ?config b = Format.asprintf "@[%a@]@." (H.pp_elt ~indent:true ()) (to_html ?config b) -let pp ?(flush=true) ?config ?indent () pp b = +let pp ?(flush = true) ?config ?indent () pp b = if flush then Format.fprintf pp "@[%a@]@." (H.pp_elt ?indent ()) (to_html ?config b) else Format.fprintf pp "@[%a@]" (H.pp_elt ?indent ()) (to_html ?config b) - + let to_string_doc ?config b = - let meta_str = "" in + let meta_str = + "" + in let footer_str = - "" + "" in - Format.asprintf "
%s%s@[%a@]%s@." - meta_str prelude_str (H.pp_elt ()) (to_html ?config b) footer_str + Format.asprintf "%s%s@[%a@]%s@." meta_str + prelude_str (H.pp_elt ()) (to_html ?config b) footer_str diff --git a/src/printbox-html/PrintBox_html.mli b/src/printbox-html/PrintBox_html.mli index 5ce8b77..8972141 100644 --- a/src/printbox-html/PrintBox_html.mli +++ b/src/printbox-html/PrintBox_html.mli @@ -1,4 +1,3 @@ - (* This file is free software. See file "license" for more details. *) (** {1 Output HTML} *) @@ -7,7 +6,7 @@ open Tyxml type 'a html = 'a Html.elt -val prelude : [> Html_types.style] html +val prelude : [> Html_types.style ] html (** HTML text to embed in the "", defining the style for tables *) val prelude_str : string @@ -29,19 +28,25 @@ module Config : sig val a_row : Html_types.div_attrib Html.attrib list -> t -> t val cls_col : string list -> t -> t val a_col : Html_types.div_attrib Html.attrib list -> t -> t + val tree_summary : bool -> t -> t (** When set to true, the trees are rendered collapsed using the [", "
" in
+ if code_block || code_quote || not preformatted then
+ "", ""
+ else
+ "", "
"
+ in
bold_pre ^ code_pre, code_post ^ bold_post, code_block, code_quote
let break_lines l =
let lines = List.concat @@ List.map (String.split_on_char '\n') l in
- List.filter_map (fun s ->
+ List.filter_map
+ (fun s ->
let len = String.length s in
- if len = 0 then None
- else if s.[len - 1] = '\r' then Some (String.sub s 0 (len - 1))
- else Some s)
+ if len = 0 then
+ None
+ else if s.[len - 1] = '\r' then
+ Some (String.sub s 0 (len - 1))
+ else
+ Some s)
lines
let pp_string_escaped ~tab_width ~code_block ~code_quote ~html out s =
let open Format in
- if code_block then pp_print_string out s
- else
+ if code_block then
+ pp_print_string out s
+ else (
let len = String.length s in
- let opt_char i = if i < len then Some s.[i] else None in
+ let opt_char i =
+ if i < len then
+ Some s.[i]
+ else
+ None
+ in
let print_spaces nbsp n_spaces =
- if n_spaces > 0 then
+ if n_spaces > 0 then (
let halfsp = Array.to_list @@ Array.make ((n_spaces + 1) / 2) " " in
- let trailing = if n_spaces mod 2 = 0 then nbsp else "" in
- fprintf out "%s%s" (String.concat nbsp halfsp) trailing in
+ let trailing =
+ if n_spaces mod 2 = 0 then
+ nbsp
+ else
+ ""
+ in
+ fprintf out "%s%s" (String.concat nbsp halfsp) trailing
+ )
+ in
let print_next_spaces i =
- match opt_char i, opt_char (i+1), opt_char (i+2) with
- | Some ' ', Some ' ', Some ' ' when i = 0 -> pp_print_string out "·"; 1
- | Some ' ', Some ' ', Some ' ' -> pp_print_string out " ·"; 2
- | Some ' ', Some ' ', _ -> pp_print_string out "· "; 2
+ match opt_char i, opt_char (i + 1), opt_char (i + 2) with
+ | Some ' ', Some ' ', Some ' ' when i = 0 ->
+ pp_print_string out "·";
+ 1
+ | Some ' ', Some ' ', Some ' ' ->
+ pp_print_string out " ·";
+ 2
+ | Some ' ', Some ' ', _ ->
+ pp_print_string out "· ";
+ 2
| Some '\t', Some ' ', _ when i = 0 && tab_width mod 2 = 0 ->
- pp_print_string out "·"; print_spaces "·" tab_width; 2
+ pp_print_string out "·";
+ print_spaces "·" tab_width;
+ 2
| Some '\t', Some '\t', Some ' ' when i = 0 && tab_width mod 2 = 0 ->
- pp_print_string out "·"; print_spaces "·" (tab_width - 1);
- pp_print_string out "·"; print_spaces "·" tab_width; 2
+ pp_print_string out "·";
+ print_spaces "·" (tab_width - 1);
+ pp_print_string out "·";
+ print_spaces "·" tab_width;
+ 2
| Some '\t', _, _ when i = 0 ->
- pp_print_string out "·"; print_spaces "·" (tab_width - 1); 1
+ pp_print_string out "·";
+ print_spaces "·" (tab_width - 1);
+ 1
| Some '\t', Some ' ', _ when tab_width mod 2 = 1 ->
- print_spaces "·" (tab_width + 1); 2
+ print_spaces "·" (tab_width + 1);
+ 2
| Some '\t', Some '\t', _ when tab_width mod 2 = 1 ->
- print_spaces "·" (2 * tab_width); 2
- | Some '\t', _, _ -> print_spaces "·" tab_width; 1
- | Some ' ', _, _ -> pp_print_string out " "; 1
- | _ -> assert false in
+ print_spaces "·" (2 * tab_width);
+ 2
+ | Some '\t', _, _ ->
+ print_spaces "·" tab_width;
+ 1
+ | Some ' ', _, _ ->
+ pp_print_string out " ";
+ 1
+ | _ -> assert false
+ in
let print_next_chars =
if html then
fun i ->
- match opt_char i with
- | Some '<' -> pp_print_string out "<"; 1
- | Some '>' -> pp_print_string out ">"; 1
- | Some '&' -> pp_print_string out "&"; 1
- | Some '\t' | Some ' ' -> print_next_spaces i
- | Some c -> pp_print_char out c; 1
- | None -> len
+ match opt_char i with
+ | Some '<' ->
+ pp_print_string out "<";
+ 1
+ | Some '>' ->
+ pp_print_string out ">";
+ 1
+ | Some '&' ->
+ pp_print_string out "&";
+ 1
+ | Some '\t' | Some ' ' -> print_next_spaces i
+ | Some c ->
+ pp_print_char out c;
+ 1
+ | None -> len
else if code_quote then
fun i ->
- match opt_char i with
- | Some '\t' | Some ' ' -> print_next_spaces i
- | Some c -> pp_print_char out c; 1
- | None -> len
+ match opt_char i with
+ | Some '\t' | Some ' ' -> print_next_spaces i
+ | Some c ->
+ pp_print_char out c;
+ 1
+ | None -> len
else
fun i ->
- match opt_char i, opt_char (i+1), opt_char (i+2) with
- | Some '<', _, _ -> pp_print_string out "\\<"; 1
- | Some '>', _, _ -> pp_print_string out "\\>"; 1
- | Some '`', _, _ -> pp_print_string out "\\`"; 1
- | Some ' ', Some '*', Some ' ' -> pp_print_string out " * "; 3
- | Some '*', _, _ -> pp_print_string out "\\*"; 1
- | Some ' ', Some '_', Some ' ' -> pp_print_string out " _ "; 3
- | Some c1, Some '_', Some c2 when c1 <> ' ' && c2 <> ' ' -> fprintf out "%c_%c" c1 c2; 3
- | Some '_', _, _ -> pp_print_string out "\\_"; 1
- | Some '\t', _, _ | Some ' ', _, _ -> print_next_spaces i
- | Some c, _, _ -> pp_print_char out c; 1
- | _ -> len
+ match opt_char i, opt_char (i + 1), opt_char (i + 2) with
+ | Some '<', _, _ ->
+ pp_print_string out "\\<";
+ 1
+ | Some '>', _, _ ->
+ pp_print_string out "\\>";
+ 1
+ | Some '`', _, _ ->
+ pp_print_string out "\\`";
+ 1
+ | Some ' ', Some '*', Some ' ' ->
+ pp_print_string out " * ";
+ 3
+ | Some '*', _, _ ->
+ pp_print_string out "\\*";
+ 1
+ | Some ' ', Some '_', Some ' ' ->
+ pp_print_string out " _ ";
+ 3
+ | Some c1, Some '_', Some c2 when c1 <> ' ' && c2 <> ' ' ->
+ fprintf out "%c_%c" c1 c2;
+ 3
+ | Some '_', _, _ ->
+ pp_print_string out "\\_";
+ 1
+ | Some '\t', _, _ | Some ' ', _, _ -> print_next_spaces i
+ | Some c, _, _ ->
+ pp_print_char out c;
+ 1
+ | _ -> len
in
let i = ref 0 in
let quote_pre, quote_post =
- if code_quote && String.contains s '`' then "`` ", " ``" else "`", "`" in
+ if code_quote && String.contains s '`' then
+ "`` ", " ``"
+ else
+ "`", "`"
+ in
if code_quote then pp_print_string out quote_pre;
- while !i < len do i := !i + print_next_chars !i done;
+ while !i < len do
+ i := !i + print_next_chars !i
+ done;
if code_quote then pp_print_string out quote_post
+ )
let rec multiline_heuristic c b =
match B.view b with
| B.Empty -> false
- | B.Text {l=[]; _} -> false
- | B.Text {l=[s]; _} -> String.contains s '\n'
+ | B.Text { l = []; _ } -> false
+ | 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.Pad (_, _) -> true
- | B.Align {inner; _} -> multiline_heuristic c inner
- | B.Grid (_, [|_|]) when c.Config.hlists = `As_table -> true
+ | B.Align { inner; _ } -> multiline_heuristic c inner
+ | B.Grid (_, [| _ |]) when c.Config.hlists = `As_table -> true
| B.Grid (_, rows) ->
- Array.length rows > 1 || Array.exists (Array.exists @@ multiline_heuristic c) rows
+ Array.length rows > 1
+ || Array.exists (Array.exists @@ multiline_heuristic c) rows
| B.Tree (_, header, children) ->
Array.length children > 0 || multiline_heuristic c header
- | B.Link {inner; _} -> multiline_heuristic c inner
+ | B.Link { inner; _ } -> multiline_heuristic c inner
let rec line_of_length_heuristic_exn c b =
match B.view b with
- | B.Empty | B.Text {l=[]; _} -> 0
- | B.Text {l=[s]; style} ->
- let from_bold = if style.B.Style.bold then 4 else 0 in
+ | B.Empty | B.Text { l = []; _ } -> 0
+ | B.Text { l = [ s ]; style } ->
+ let from_bold =
+ if style.B.Style.bold then
+ 4
+ else
+ 0
+ in
let from_code =
- if style.B.Style.preformatted then if String.contains s '`' then 6 else 2 else 0 in
- if String.contains s '\n' then raise Not_found else String.length s + from_bold + from_code
+ if style.B.Style.preformatted then
+ if String.contains s '`' then
+ 6
+ else
+ 2
+ else
+ 0
+ in
+ if String.contains s '\n' then
+ raise Not_found
+ else
+ 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 ->
(* "> " or "[]" *)
line_of_length_heuristic_exn c b + 2
| B.Pad (_, _) -> raise Not_found
- | B.Align {inner; _} -> line_of_length_heuristic_exn c inner
- | B.Grid (_, [||]) | B.Grid (_, [|[||]|]) -> 0
- | B.Grid (`None, [|row|]) when c.Config.hlists = `Minimal ->
+ | B.Align { inner; _ } -> line_of_length_heuristic_exn c inner
+ | B.Grid (_, [||]) | B.Grid (_, [| [||] |]) -> 0
+ | B.Grid (`None, [| row |]) when c.Config.hlists = `Minimal ->
(* " " *)
- (Array.length row - 1) * 8 +
- Array.fold_left (+) 0 (Array.map (line_of_length_heuristic_exn c) row)
- | B.Grid (`Bars, [|row|]) when c.Config.hlists = `Minimal ->
+ ((Array.length row - 1) * 8)
+ + Array.fold_left ( + ) 0 (Array.map (line_of_length_heuristic_exn c) row)
+ | B.Grid (`Bars, [| row |]) when c.Config.hlists = `Minimal ->
(* " | " *)
- (Array.length row - 1) * 3 +
- Array.fold_left (+) 0 (Array.map (line_of_length_heuristic_exn c) row)
+ ((Array.length row - 1) * 3)
+ + Array.fold_left ( + ) 0 (Array.map (line_of_length_heuristic_exn c) row)
| B.Grid _ -> raise Not_found
| B.Tree (_, header, [||]) -> line_of_length_heuristic_exn c header
| B.Tree _ -> raise Not_found
- | B.Link {inner; uri} -> line_of_length_heuristic_exn c inner + String.length uri + 4
+ | B.Link { inner; uri } ->
+ line_of_length_heuristic_exn c inner + String.length uri + 4
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.Text { l = [ _ ]; style = { B.Style.bold = true; _ } } -> true
| B.Frame b -> header b
- | _ -> false in
- Array.for_all header rows.(0) &&
- Array.for_all (fun row -> Array.for_all (Fun.negate @@ multiline_heuristic c) row) rows
+ | _ -> false
+ in
+ Array.for_all header rows.(0)
+ && Array.for_all
+ (fun row -> Array.for_all (Fun.negate @@ multiline_heuristic c) row)
+ rows
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.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.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.Align { h; v; inner } -> B.align ~h ~v @@ remove_bold inner
| B.Grid _ -> assert false
| B.Tree (_, header, [||]) -> remove_bold header
| B.Tree _ -> assert false
- | B.Link {inner; uri} -> B.link ~uri @@ remove_bold inner
-
+ | B.Link { inner; uri } -> B.link ~uri @@ remove_bold inner
+
let pp c out b =
let open Format in
(* We cannot use Format for indentation, because we need to insert ">" at the right places. *)
let rec loop ~no_block ~no_md ~prefix b =
- let br = if no_md then "]. Downside: Markdown's style classes make it extra prominent. - [Code_quote]: use Markdown's inline code style: single quote [`]. @@ -21,11 +23,11 @@ module Config : sig val html_tables : t -> t (** Output tables via {!PrintBox_html}. Already the case for the {!uniform} config. *) - + val text_tables : t -> t (** Output tables via {!PrintBox_text}. Already the case for the {!default} config. *) - - val vlists : [`Line_break | `List | `As_table] -> t -> t + + val vlists : [ `Line_break | `List | `As_table ] -> t -> t (** How to output {!PrintBox.vlist} boxes, i.e. single-column grids. - [`Line_break]: when the {!PrintBox.vlist} has bars, it puts a quoted horizontal rule ["> ---"] at the bottom of a row, otherwise puts an extra empty line. @@ -35,13 +37,13 @@ module Config : sig It is set in the {!default} config. - [`As_table] falls back to the general table printing mechanism. *) - val hlists : [`Minimal | `As_table] -> t -> t + val hlists : [ `Minimal | `As_table ] -> t -> t (** How to output {!PrintBox.hlist} boxes, i.e. single-row grids, curently only if they fit in one line. - [`Minimal] uses spaces and a horizontal bar [" | "] to separate columns. It is set in the {!default} config. - [`As_table] falls back to the general table printing mechanism. *) - + val foldable_trees : t -> t (** Output trees so every node with children is foldable. Already the case for the {!uniform} config. *) @@ -52,18 +54,18 @@ module Config : sig val multiline_preformatted : preformatted -> t -> t (* How to output multiline preformatted text, including tables when output as text. *) - + val one_line_preformatted : preformatted -> t -> t (* How to output single-line preformatted text. *) - + val tab_width : int -> t -> t (* One tab is this many spaces. *) - - val quotation_frames : t -> t + + val quotation_frames : t -> t (** Output frames using Markdown's quotation syntax [> ], or surrouding by [[]] if inline. Already the case for the {!default} config. *) - val table_frames : t -> t + val table_frames : t -> t (** Output frames by falling back to the mechanism used to output tables. Already the case for the {!uniform} config. *) end diff --git a/src/printbox-md/dune b/src/printbox-md/dune index a1f0e01..a56abd8 100644 --- a/src/printbox-md/dune +++ b/src/printbox-md/dune @@ -16,5 +16,6 @@ (target README.md) (mode (promote)) (action - (with-outputs-to %{target} + (with-outputs-to + %{target} (run %{dep:readme.exe})))) diff --git a/src/printbox-md/readme.ml b/src/printbox-md/readme.ml index 37322bd..22c168f 100644 --- a/src/printbox-md/readme.ml +++ b/src/printbox-md/readme.ml @@ -6,174 +6,318 @@ module MD = PrintBox_md let () = print_endline {|# PrintBox-md: a Markdown backend for PrintBox |} -let () = print_endline MD.(to_string Config.default - @@ B.link ~uri:"readme.ml" - @@ B.line "This file was generated by the readme executable.") +let () = + print_endline + MD.( + to_string Config.default @@ B.link ~uri:"readme.ml" + @@ B.line "This file was generated by the readme executable.") -let () = print_endline {|## Coverage of Markdown and `PrintBox` constructions +let () = + print_endline + {|## Coverage of Markdown and `PrintBox` constructions ### Single-line and multiline text |} -let () = print_endline MD.(to_string Config.default @@ B.lines [ - "Multiline text is printed using Markdown's syntax for forced line breaks:"; - " a pair of trailing whitespace."; - " Line wrapping is not prevented unless the text is styled as preformatted."; - " However, we pay attention to whitespace in the text -- "; - "we don't allow HTML to ignore the spaces." - ]) - -let () = print_endline MD.(to_string Config.default @@ B.lines_with_style B.Style.preformatted [ - "Preformatted text like this one can be output in two different styles:"; - " Code_block and Code_quote."; - " The style can be changed for both multiline and single-line text." - ]) - -let () = print_endline MD.(to_string Config.(multiline_preformatted Code_quote default) - @@ B.lines_with_style B.Style.preformatted [ - "So it is possible to use [Code_quote] even with multiline text,"; - " which leads to a contrasting visual effect."; - " Since Markdown's code quotes would otherwise ignore whitespace,"; - " we use our trick to preserve --> these spaces." - ]) +let () = + print_endline + MD.( + to_string Config.default + @@ B.lines + [ + "Multiline text is printed using Markdown's syntax for forced \ + line breaks:"; + " a pair of trailing whitespace."; + " Line wrapping is not prevented unless the text is styled as \ + preformatted."; + " However, we pay attention to whitespace in the text -- "; + "we don't allow HTML to ignore the spaces."; + ]) + +let () = + print_endline + MD.( + to_string Config.default + @@ B.lines_with_style B.Style.preformatted + [ + "Preformatted text like this one can be output in two different \ + styles:"; + " Code_block and Code_quote."; + " The style can be changed for both multiline and single-line \ + text."; + ]) + +let () = + print_endline + MD.( + to_string Config.(multiline_preformatted Code_quote default) + @@ B.lines_with_style B.Style.preformatted + [ + "So it is possible to use [Code_quote] even with multiline text,"; + " which leads to a contrasting visual effect."; + " Since Markdown's code quotes would otherwise ignore \ + whitespace,"; + " we use our trick to preserve --> these \ + spaces."; + ]) let () = print_endline {|### Horizontal boxes i.e. `PrintBox.hlist` |} - -let () = print_endline MD.(to_string Config.default @@ B.(hlist ~bars:false [ - line "The"; - line_with_style Style.preformatted "`Minimal"; - line "style for horizontal boxes simply puts all entries on a line, "; - line "separated by extra spaces," - ])) - -let () = print_endline MD.(to_string Config.default @@ B.(hlist ~bars:true [ - line "or if `Bars are set,"; - line " by the"; line "vertical dash." - ])) - -let () = print_endline MD.(to_string Config.(html_tables default) @@ B.(hlist ~bars:true [ - lines ["It only works when"; "all the elements fit"]; - line "logically speaking,"; line_with_style Style.bold "on a single line." - ])) - -let () = print_endline MD.(to_string Config.(html_tables @@ hlists `As_table default) - @@ B.(hlist ~bars:false [ - line "Otherwise, the fallback behavior is as if"; - line_with_style Style.preformatted "`As_table"; - line "was used to configure horizontal boxes." - ])) + +let () = + print_endline + MD.( + to_string Config.default + @@ B.( + hlist ~bars:false + [ + line "The"; + line_with_style Style.preformatted "`Minimal"; + line + "style for horizontal boxes simply puts all entries on a \ + line, "; + line "separated by extra spaces,"; + ])) + +let () = + print_endline + MD.( + to_string Config.default + @@ B.( + hlist ~bars:true + [ + line "or if `Bars are set,"; + line " by the"; + line "vertical dash."; + ])) + +let () = + print_endline + MD.( + to_string Config.(html_tables default) + @@ B.( + hlist ~bars:true + [ + lines [ "It only works when"; "all the elements fit" ]; + line "logically speaking,"; + line_with_style Style.bold "on a single line."; + ])) + +let () = + print_endline + MD.( + to_string Config.(html_tables @@ hlists `As_table default) + @@ B.( + hlist ~bars:false + [ + line "Otherwise, the fallback behavior is as if"; + line_with_style Style.preformatted "`As_table"; + line "was used to configure horizontal boxes."; + ])) let () = print_endline {|### Vertical boxes i.e. `PrintBox.vlist` |} -let () = print_endline MD.(to_string Config.(vlists `List default) - @@ B.(vlist ~bars:false [ - line "Vertical boxes can be configured in three ways:"; - hlist ~bars:false [ - line_with_style Style.preformatted "`Line_break"; - line "which simply adds an empty line after each entry"]; - hlist ~bars:false [ - line_with_style Style.preformatted "`List"; - line "which lists the entries"]; - hlist ~bars:false [ - line "and the fallback we saw already,"; - line_with_style Style.preformatted "`As_table"]; - ])) - -let () = print_endline MD.(to_string Config.(vlists `Line_break default) - @@ B.(vlist ~bars:true [ - line "Vertical boxes with bars"; - hlist ~bars:false [ - line_with_style Style.preformatted "(vlist ~bars:true)"; - line "use a quoted horizontal ruler"]; - line "to separate the entries (here with style `Line_break)." - ])) +let () = + print_endline + MD.( + to_string Config.(vlists `List default) + @@ B.( + vlist ~bars:false + [ + line "Vertical boxes can be configured in three ways:"; + hlist ~bars:false + [ + line_with_style Style.preformatted "`Line_break"; + line "which simply adds an empty line after each entry"; + ]; + hlist ~bars:false + [ + line_with_style Style.preformatted "`List"; + line "which lists the entries"; + ]; + hlist ~bars:false + [ + line "and the fallback we saw already,"; + line_with_style Style.preformatted "`As_table"; + ]; + ])) + +let () = + print_endline + MD.( + to_string Config.(vlists `Line_break default) + @@ B.( + vlist ~bars:true + [ + line "Vertical boxes with bars"; + hlist ~bars:false + [ + line_with_style Style.preformatted "(vlist ~bars:true)"; + line "use a quoted horizontal ruler"; + ]; + line "to separate the entries (here with style `Line_break)."; + ])) let () = print_endline {|### Frames |} -let () = print_endline MD.(to_string Config.(vlists `Line_break default) - @@ B.( - frame @@ vlist ~bars:true [ - line "Frames use quotation to make their content prominent"; - hlist ~bars:false [ - line "except when in a non-block position"; - frame @@ line "then they use"; line "square brackets"]; - line "(which also helps with conciseness)." - ])) - -let () = print_endline MD.(to_string Config.(table_frames @@ vlists `Line_break default) - @@ B.( - frame @@ vlist ~bars:true [ - line "There is also a fallback"; - hlist ~bars:false [ - line "which generates all"; - frame @@ line "frames, using"; line "the same approach as for tables"] - ])) - -let () = print_endline MD.(to_string Config.(table_frames @@ vlists `List default) - @@ B.( - vlist ~bars:false [ - line "This even works OK-ish"; - line "when the frame"; - frame @@ line "is nested"; - line "inside Markdown." - ])) - -let () = - print_endline MD.(to_string Config.(html_tables @@ table_frames @@ vlists `List default) - @@ B.( - vlist ~bars:false [ - line "And suprisingly it works even better"; - vlist ~bars:false [ - line "when tables are configured"; - frame @@ line "to fallback on"; - line "HTML -- but it doesn't work on GitHub Preview."]; - line "(GitHub ignores styles onand tags.)" - ])) +let () = + print_endline + MD.( + to_string Config.(vlists `Line_break default) + @@ B.( + frame + @@ vlist ~bars:true + [ + line "Frames use quotation to make their content prominent"; + hlist ~bars:false + [ + line "except when in a non-block position"; + frame @@ line "then they use"; + line "square brackets"; + ]; + line "(which also helps with conciseness)."; + ])) + +let () = + print_endline + MD.( + to_string Config.(table_frames @@ vlists `Line_break default) + @@ B.( + frame + @@ vlist ~bars:true + [ + line "There is also a fallback"; + hlist ~bars:false + [ + line "which generates all"; + frame @@ line "frames, using"; + line "the same approach as for tables"; + ]; + ])) + +let () = + print_endline + MD.( + to_string Config.(table_frames @@ vlists `List default) + @@ B.( + vlist ~bars:false + [ + line "This even works OK-ish"; + line "when the frame"; + frame @@ line "is nested"; + line "inside Markdown."; + ])) + +let () = + print_endline + MD.( + to_string Config.(html_tables @@ table_frames @@ vlists `List default) + @@ B.( + vlist ~bars:false + [ + line "And suprisingly it works even better"; + vlist ~bars:false + [ + line "when tables are configured"; + frame @@ line "to fallback on"; + line "HTML -- but it doesn't work on GitHub Preview."; + ]; + line "(GitHub ignores styles onand tags.)"; + ])) let () = print_endline {|### Trees |} -let () = print_endline MD.(to_string Config.default - @@ B.( - tree (line "Trees are rendered as:") [ - line "The head element"; - frame @@ line "followed by"; - line "a list of the child elements." - ])) +let () = + print_endline + MD.( + to_string Config.default + @@ B.( + tree + (line "Trees are rendered as:") + [ + line "The head element"; + frame @@ line "followed by"; + line "a list of the child elements."; + ])) -let () = print_endline MD.(to_string Config.(foldable_trees default) - @@ B.( - tree (line "Trees can be made foldable:") [ - line "The head element"; - frame @@ line "is the summary"; - tree (line "and the children...") [line_with_style Style.bold "are the details."] - ])) +let () = + print_endline + MD.( + to_string Config.(foldable_trees default) + @@ B.( + tree + (line "Trees can be made foldable:") + [ + line "The head element"; + frame @@ line "is the summary"; + tree + (line "and the children...") + [ line_with_style Style.bold "are the details." ]; + ])) -let () = print_endline {|### Tables +let () = + print_endline + {|### Tables There is a special case carved out for Markdown syntax tables. |} -let () = print_endline MD.(to_string Config.default - @@ B.( - let bold = text_with_style Style.bold in - grid_l [ - [ bold "Header"; bold "cells"; frame @@ bold "must be"; bold "bold." ]; - [ line "Rows"; frame @@ line "must be"; line "single"; line "line." ]; - [ frame @@ line "Only"; line "then"; bold "we get"; line "a Markdown table." ]; - ])) - -let () = print_endline MD.(to_string Config.(html_tables default) - @@ B.( - let bold = text_with_style Style.bold in - let code = text_with_style Style.preformatted in - grid_l [ - [ bold "Tables"; bold "that meet"; frame @@ bold "neither"; bold "of:" ]; - [ frame @@ bold "Markdown's native"; line "restrictions,"; - line "special cases:"; code "hlist\nvlist" ]; - [ line "End up"; line "as either"; - line "of the fallbacks:"; code "printbox-text\nprintbox-html" ]; - ])) +let () = + print_endline + MD.( + to_string Config.default + @@ B.( + let bold = text_with_style Style.bold in + grid_l + [ + [ + bold "Header"; + bold "cells"; + frame @@ bold "must be"; + bold "bold."; + ]; + [ + line "Rows"; + frame @@ line "must be"; + line "single"; + line "line."; + ]; + [ + frame @@ line "Only"; + line "then"; + bold "we get"; + line "a Markdown table."; + ]; + ])) + +let () = + print_endline + MD.( + to_string Config.(html_tables default) + @@ B.( + let bold = text_with_style Style.bold in + let code = text_with_style Style.preformatted in + grid_l + [ + [ + bold "Tables"; + bold "that meet"; + frame @@ bold "neither"; + bold "of:"; + ]; + [ + frame @@ bold "Markdown's native"; + line "restrictions,"; + line "special cases:"; + code "hlist\nvlist"; + ]; + [ + line "End up"; + line "as either"; + line "of the fallbacks:"; + code "printbox-text\nprintbox-html"; + ]; + ])) diff --git a/src/printbox-text/PrintBox_text.ml b/src/printbox-text/PrintBox_text.ml index 80324ac..75ee517 100644 --- a/src/printbox-text/PrintBox_text.ml +++ b/src/printbox-text/PrintBox_text.ml @@ -5,8 +5,8 @@ module B = PrintBox type position = PrintBox.position = { - x:int; - y:int; + x: int; + y: int; } module Style_ansi : sig @@ -24,24 +24,32 @@ end = struct | Cyan -> 6 | White -> 7 - let codes_of_style (self:t) : int list = - let {bold;fg_color;bg_color;preformatted=_} = self in - (if bold then [1] else []) @ - (match bg_color with None -> [] | Some c -> [40 + int_of_color_ c]) @ - (match fg_color with None -> [] | Some c -> [30 + int_of_color_ c]) + let codes_of_style (self : t) : int list = + let { bold; fg_color; bg_color; preformatted = _ } = self in + (if bold then + [ 1 ] + else + []) + @ (match bg_color with + | None -> [] + | Some c -> [ 40 + int_of_color_ c ]) + @ + match fg_color with + | None -> [] + | Some c -> [ 30 + int_of_color_ c ] let ansi_l_to_str_ = function | [] -> "", "" - | [a] -> Printf.sprintf "\x1b[%dm" a, "\x1b[0m" - | [a;b] -> Printf.sprintf "\x1b[%d;%dm" a b, "\x1b[0m" + | [ a ] -> Printf.sprintf "\x1b[%dm" a, "\x1b[0m" + | [ a; b ] -> Printf.sprintf "\x1b[%d;%dm" a b, "\x1b[0m" | l -> let buf = Buffer.create 16 in let pp_num c = Buffer.add_string buf (string_of_int c) in Buffer.add_string buf "\x1b["; List.iteri (fun i c -> - if i>0 then Buffer.add_char buf ';'; - pp_num c) + if i > 0 then Buffer.add_char buf ';'; + pp_num c) l; Buffer.add_string buf "m"; Buffer.contents buf, "\x1b[0m" @@ -57,26 +65,27 @@ module Pos = struct | 0 -> compare pos1.x pos2.x | x -> x - let origin = {x=0; y=0;} - - let[@inline] move pos x y = {x=pos.x + x; y=pos.y + 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} + let origin = { x = 0; y = 0 } + let[@inline] move pos x y = { x = pos.x + x; y = pos.y + 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 } let[@inline] move_x pos x = move pos x 0 let[@inline] move_y pos y = move pos 0 y end -module M = Map.Make(Pos) +module M = Map.Make (Pos) (* String length *) -let str_display_len_ = ref (fun s i len -> - Uutf.String.fold_utf_8 ~pos:i ~len:len - (fun n _ c -> match c with - | `Malformed _ -> 0 - | `Uchar c -> n + max 0 (Uucp.Break.tty_width_hint c)) - 0 s) +let str_display_len_ = + ref (fun s i len -> + Uutf.String.fold_utf_8 ~pos:i ~len + (fun n _ c -> + match c with + | `Malformed _ -> 0 + | `Uchar c -> n + max 0 (Uucp.Break.tty_width_hint c)) + 0 s) let[@inline] set_string_len f = str_display_len_ := f let[@inline] str_display_width_ s i len : int = !str_display_len_ s i len @@ -85,12 +94,16 @@ let[@inline] str_display_width_ s i len : int = !str_display_len_ s i len module Output : sig type t + val create : unit -> t + (* val put_char : t -> position -> char -> unit *) val put_string : t -> position -> string -> unit val put_sub_string : t -> position -> string -> int -> int -> unit + val put_sub_string_brack : t -> position -> pre:string -> string -> int -> int -> post:string -> unit + val to_string : ?indent:int -> t -> string val to_chan : ?indent:int -> out_channel -> t -> unit val pp : Format.formatter -> t -> unit @@ -101,7 +114,11 @@ end = struct type printable = (* | Char of char *) | String of string - | Str_slice of {s: string;i: int;len: int} + | Str_slice of { + s: string; + i: int; + len: int; + } | Str_slice_bracket of { pre: string; (* prefix *) s: string; @@ -110,51 +127,55 @@ end = struct post: string; (* suffix *) } - type t = { - mutable m: printable M.t; - } + type t = { mutable m: printable M.t } (* Note: we trust the user not to mess things up relating to strings overlapping because of bad positions *) (* let[@inline] put_char (self:t) pos c = self.m <- M.add pos (Char c) self.m *) - let[@inline] put_string (self:t) pos s = + let[@inline] put_string (self : t) pos s = self.m <- M.add pos (String s) self.m - let[@inline] put_sub_string (self:t) pos s i len = - self.m <- M.add pos (Str_slice {s;i;len}) self.m + let[@inline] put_sub_string (self : t) pos s i len = + self.m <- M.add pos (Str_slice { s; i; len }) self.m - let[@inline] put_sub_string_brack (self:t) pos ~pre s i len ~post = - self.m <- M.add pos (Str_slice_bracket {pre;s;i;len;post}) self.m + let[@inline] put_sub_string_brack (self : t) pos ~pre s i len ~post = + self.m <- M.add pos (Str_slice_bracket { pre; s; i; len; post }) self.m - let create () : t = {m=M.empty} + let create () : t = { m = M.empty } module type OUT = sig type t + val output_char : t -> char -> unit val output_string : t -> string -> unit val output_substring : t -> string -> int -> int -> unit val newline : t -> unit end - module Make_out(O : OUT) : sig + module Make_out (O : OUT) : sig val render : ?indent:int -> O.t -> t -> unit end = struct - let goto ?(indent=0) (out:O.t) start dest = + let goto ?(indent = 0) (out : O.t) start dest = (* Go to the line before the one we want *) for _i = start.y to dest.y - 2 do - O.newline out; + O.newline out done; (* Emit the last line and indent it *) if start.y < dest.y then ( O.newline out; for _i = 1 to indent do - O.output_char out ' '; + O.output_char out ' ' done ); (* Now that we are on the correct line, go the right column. *) - let x_start = if start.y < dest.y then 0 else start.x in + let x_start = + if start.y < dest.y then + 0 + else + start.x + in for _i = x_start to dest.x - 1 do O.output_char out ' ' done @@ -166,7 +187,7 @@ end = struct | Str_slice (s,i,len) -> Printf.sprintf "%S[%d,%d]" s i len *) - let to_buf_aux_ ?(indent=0) (out:O.t) start_pos p curr_pos = + let to_buf_aux_ ?(indent = 0) (out : O.t) start_pos p curr_pos = assert (Pos.compare curr_pos start_pos <= 0); (* Go up to the expected location *) goto ~indent out curr_pos start_pos; @@ -179,11 +200,11 @@ end = struct O.output_string out s; let l = !str_display_len_ s 0 (String.length s) in Pos.move_x start_pos l - | Str_slice {s; i; len} -> + | Str_slice { s; i; len } -> O.output_substring out s i len; let l = str_display_width_ s i len in Pos.move_x start_pos l - | Str_slice_bracket {pre; s; i; len; post} -> + | Str_slice_bracket { pre; s; i; len; post } -> O.output_string out pre; O.output_substring out s i len; (* We could use Bytes.unsafe_of_string as long as !string_len @@ -193,52 +214,64 @@ end = struct let l = str_display_width_ s i len in Pos.move_x start_pos l - let render ?(indent=0) (out:O.t) (self:t) : unit = - for _i = 1 to indent do O.output_char out ' ' done; + let render ?(indent = 0) (out : O.t) (self : t) : unit = + for _i = 1 to indent do + O.output_char out ' ' + done; ignore (M.fold (to_buf_aux_ ~indent out) self.m Pos.origin : position); () end - module Out_buf = Make_out(struct - type t = Buffer.t - let output_char = Buffer.add_char - let output_string = Buffer.add_string - let output_substring = Buffer.add_substring - let newline b = Buffer.add_char b '\n' - end) + module Out_buf = Make_out (struct + type t = Buffer.t + + let output_char = Buffer.add_char + let output_string = Buffer.add_string + let output_substring = Buffer.add_substring + let newline b = Buffer.add_char b '\n' + end) let to_string ?indent self : string = let buf = Buffer.create 42 in Out_buf.render ?indent buf self; Buffer.contents buf - module Out_chan = Make_out(struct - type t = out_channel - let output_char = output_char - let output_string = output_string - let output_substring = output_substring - let newline oc = output_char oc '\n' - end) - - let to_chan ?indent oc self : unit = - Out_chan.render ?indent oc self - - module Out_format = Make_out(struct - type t = Format.formatter - let output_char = Format.pp_print_char - let output_string = Format.pp_print_string - let output_substring out s i len = - let s = if i=0 && len=String.length s then s else String.sub s i len in - Format.pp_print_string out s - let newline out = Format.pp_print_cut out () - end) - - let pp out (self:t) : unit = + module Out_chan = Make_out (struct + type t = out_channel + + let output_char = output_char + let output_string = output_string + let output_substring = output_substring + let newline oc = output_char oc '\n' + end) + + let to_chan ?indent oc self : unit = Out_chan.render ?indent oc self + + module Out_format = Make_out (struct + type t = Format.formatter + + let output_char = Format.pp_print_char + let output_string = Format.pp_print_string + + let output_substring out s i len = + let s = + if i = 0 && len = String.length s then + s + else + String.sub s i len + in + Format.pp_print_string out s + + let newline out = Format.pp_print_cut out () + end) + + let pp out (self : t) : unit = Format.fprintf out "@[%a@]" (Out_format.render ~indent:0) self end module Box_inner : sig type t + val of_box : B.box -> t val render : ansi:bool -> Output.t -> t -> unit end = struct @@ -251,16 +284,16 @@ end = struct | Frame of 'a | Pad of position * 'a (* vertical and horizontal padding *) | Align of { - h: [`Left | `Center | `Right]; - v: [`Top | `Center | `Bottom]; - inner: 'a (* dynamic centering/alignment *) + h: [ `Left | `Center | `Right ]; + v: [ `Top | `Center | `Bottom ]; + inner: 'a; (* dynamic centering/alignment *) } - | Grid of [`Bars | `None] * 'a array array + | Grid of [ `Bars | `None ] * 'a array array | Tree of int * 'a * 'a array type t = { - shape : t shape; - size : position lazy_t; + shape: t shape; + size: position lazy_t; } type display_conn_basic = { @@ -275,34 +308,25 @@ end = struct mutable tree: display_conn_basic; } - let init_connection () = { - nontree = { - left = false; - right = false; - top = false; - bottom = false - }; - tree = { - left = false; - right = false; - top = false; - bottom = false + let init_connection () = + { + nontree = { left = false; right = false; top = false; bottom = false }; + tree = { left = false; right = false; top = false; bottom = false }; } - } let update_conn ?left ?right ?top ?bottom con_type = (match left with - | None -> () - | Some _ -> con_type.left <- true); + | None -> () + | Some _ -> con_type.left <- true); (match right with - | None -> (); - | Some _ -> con_type.right <- true); + | None -> () + | Some _ -> con_type.right <- true); (match top with - | None -> (); - | Some _ -> con_type.top <- true); - (match bottom with - | None -> (); - | Some _ -> con_type.bottom <- true) + | None -> () + | Some _ -> con_type.top <- true); + match bottom with + | None -> () + | Some _ -> con_type.bottom <- true let disp_conn ct conn = let conn_basic = @@ -310,7 +334,9 @@ end = struct | `Nontree -> conn.nontree | `Tree -> conn.tree in - match conn_basic.left, conn_basic.right, conn_basic.top, conn_basic.bottom with + match + conn_basic.left, conn_basic.right, conn_basic.top, conn_basic.bottom + with | false, false, false, false -> false | true, false, false, false -> false | false, true, false, false -> false @@ -337,32 +363,37 @@ end = struct | false, true, true, true -> "├" | true, true, true, true -> "┼" - type display_connection_map = { - mutable m: display_connections M.t - } - let has_border ?(ct=`Nontree) pos disp_map = - let c b = if b then 1 else 0 in + type display_connection_map = { mutable m: display_connections M.t } + + let has_border ?(ct = `Nontree) pos disp_map = + let c b = + if b then + 1 + else + 0 + in try - let conn = match ct with + let conn = + match ct with | `Nontree -> (M.find pos disp_map).nontree - | `Tree -> (M.find pos disp_map).tree in + | `Tree -> (M.find pos disp_map).tree + in c conn.left + c conn.right + c conn.top + c conn.bottom > 1 with Not_found -> false - let create_or_update ?(ct=`Nontree) ?left ?right ?top ?bottom pos disp_map = - let (new_el, tmp_disp_map) = + let create_or_update ?(ct = `Nontree) ?left ?right ?top ?bottom pos disp_map = + let new_el, tmp_disp_map = try let el = M.find pos disp_map in - (el, M.remove pos disp_map) - with Not_found -> (init_connection (), disp_map) + el, M.remove pos disp_map + with Not_found -> init_connection (), disp_map in (match ct with - | `Nontree -> update_conn ?left ?right ?top ?bottom new_el.nontree - | `Tree -> update_conn ?left ?right ?top ?bottom new_el.tree); + | `Nontree -> update_conn ?left ?right ?top ?bottom new_el.nontree + | `Tree -> update_conn ?left ?right ?top ?bottom new_el.tree); M.add pos new_el tmp_disp_map let size box = Lazy.force box.size - let shape b = b.shape let _array_foldi f acc a = @@ -374,9 +405,9 @@ end = struct let _height_line a = _array_foldi (fun h _ box -> - let s = size box in - max h s.y - ) 0 a + let s = size box in + max h s.y) + 0 a (* how large is the [i]-th column of [m]? *) let _width_column m i = @@ -391,11 +422,11 @@ end = struct let w = ref 0 and h = ref 0 in Array.iter (fun b -> - let s = size b in - w := max !w s.x; - h := !h + s.y - ) a; - {x= !w; y= !h;} + let s = size b in + w := max !w s.x; + h := !h + s.y) + a; + { x = !w; y = !h } (* from a matrix [m] (line,column), return two arrays [lines] and [columns], with [col.(i)] being the start offset of column [i] and @@ -405,16 +436,21 @@ end = struct let _size_matrix ~bars m = let dim = PrintBox.dim_matrix m in (* +1 is for keeping room for the vertical/horizontal line/column *) - let additional_space = if bars then 1 else 0 in + let additional_space = + if bars then + 1 + else + 0 + in (* columns *) let columns = Array.make (dim.x + 1) 0 in for i = 0 to dim.x - 1 do - columns.(i+1) <- columns.(i) + (_width_column m i) + additional_space + columns.(i + 1) <- columns.(i) + _width_column m i + additional_space done; (* lines *) let lines = Array.make (dim.y + 1) 0 in - for j = 0 to dim.y-1 do - lines.(j+1) <- lines.(j) + (_height_line m.(j)) + additional_space + for j = 0 to dim.y - 1 do + lines.(j + 1) <- lines.(j) + _height_line m.(j) + additional_space done; (* no trailing bars, adjust *) columns.(dim.x) <- columns.(dim.x) - additional_space; @@ -423,70 +459,64 @@ end = struct let size_of_shape = function | Empty -> Pos.origin - | Text {l;style=_} -> + | Text { l; style = _ } -> let width = List.fold_left - (fun acc (s,i,len) -> max acc (str_display_width_ s i len)) + (fun acc (s, i, len) -> max acc (str_display_width_ s i len)) 0 l in - { x=width; y=List.length l; } + { x = width; y = List.length l } | Frame t -> Pos.move (size t) 2 2 - | Pad (dim, b') -> - Pos.(size b' + (2 * dim)) - | Align {inner=b';_} -> size b' - | Grid (style,m) -> - let bars = match style with + | Pad (dim, b') -> Pos.(size b' + (2 * dim)) + | Align { inner = b'; _ } -> size b' + | Grid (style, m) -> + let bars = + match style with | `Bars -> true | `None -> false in let dim = B.dim_matrix m in let lines, columns, _space_for_bars = _size_matrix ~bars m in - { y=lines.(dim.y); x=columns.(dim.x)} + { y = lines.(dim.y); x = columns.(dim.x) } | Tree (indent, node, children) -> let dim_children = _dim_vertical_array children in let s = size node in - { x=max s.x (dim_children.x+3+indent) - ; y=s.y + dim_children.y - } + { x = max s.x (dim_children.x + 3 + indent); y = s.y + dim_children.y } - let[@unroll 2] rec lines_ s i (k: string -> int -> int -> unit) : unit = + let[@unroll 2] rec lines_ s i (k : string -> int -> int -> unit) : unit = match String.index_from s i '\n' with | j -> k s i (j - i); - lines_ s (j+1) k + lines_ s (j + 1) k | exception Not_found -> - if i < String.length s then ( - k s i (String.length s - i) - ) + if i < String.length s then k s i (String.length s - i) let lines_l_ l k = match l with | [] -> () - | [s] -> lines_ s 0 k - | s1::s2::tl -> + | [ s ] -> lines_ s 0 k + | s1 :: s2 :: tl -> lines_ s1 0 k; lines_ s2 0 k; List.iter (fun s -> lines_ s 0 k) tl - let rec of_box (b:B.t) : t = + let rec of_box (b : B.t) : t = let shape = match B.view b with | B.Empty -> Empty - | B.Text {l;style} -> + | B.Text { l; style } -> (* split into lines *) let acc = ref [] in - lines_l_ l (fun s i len -> acc := (s,i,len) :: !acc); - Text {l=List.rev !acc; style} + lines_l_ l (fun s i len -> acc := (s, i, len) :: !acc); + Text { l = List.rev !acc; style } | B.Frame t -> Frame (of_box t) | B.Pad (dim, t) -> Pad (dim, of_box t) - | B.Align {h;v;inner} -> Align {h;v;inner=of_box inner} + | B.Align { h; v; inner } -> Align { h; v; inner = of_box inner } | B.Grid (bars, m) -> Grid (bars, B.map_matrix of_box m) | B.Tree (i, b, l) -> Tree (i, of_box b, Array.map of_box l) - | B.Link {inner;uri} -> + | B.Link { inner; uri } -> (* just encode as a record *) - let self = - of_box (B.v_record ["uri", B.text uri; "inner", inner]) - in + let self = of_box (B.v_record [ "uri", B.text uri; "inner", inner ]) in self.shape in { shape; size = lazy (size_of_shape shape) } @@ -494,16 +524,22 @@ end = struct (** {3 Rendering} *) let write_vline_ ?ct conn_map pos n = - conn_map.m <- create_or_update ?ct ~bottom:true (Pos.move_y pos ~-1) conn_map.m; - for j=0 to n-1 do - conn_map.m <- create_or_update ?ct ~top:true ~bottom:true (Pos.move_y pos j) conn_map.m; + conn_map.m <- + create_or_update ?ct ~bottom:true (Pos.move_y pos ~-1) conn_map.m; + for j = 0 to n - 1 do + conn_map.m <- + create_or_update ?ct ~top:true ~bottom:true (Pos.move_y pos j) + conn_map.m done; conn_map.m <- create_or_update ?ct ~top:true (Pos.move_y pos n) conn_map.m let write_hline_ ?ct conn_map pos n = - conn_map.m <- create_or_update ?ct ~right:true (Pos.move_x pos ~-1) conn_map.m; - for i=0 to n-1 do - conn_map.m <- create_or_update ?ct ~left:true ~right:true (Pos.move_x pos i) conn_map.m; + conn_map.m <- + create_or_update ?ct ~right:true (Pos.move_x pos ~-1) conn_map.m; + for i = 0 to n - 1 do + conn_map.m <- + create_or_update ?ct ~left:true ~right:true (Pos.move_x pos i) + conn_map.m done; conn_map.m <- create_or_update ?ct ~left:true (Pos.move_x pos n) conn_map.m @@ -511,68 +547,86 @@ end = struct 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 *) - let pre_render ~ansi ?(offset=Pos.origin) ?expected_size ~out b pos = - let conn_m : display_connection_map = {m=M.empty} in - let rec render_rec ~ansi ?(offset=offset) ?expected_size b pos = + let pre_render ~ansi ?(offset = Pos.origin) ?expected_size ~out b pos = + let conn_m : display_connection_map = { m = M.empty } in + let rec render_rec ~ansi ?(offset = offset) ?expected_size b pos = match shape b with | Empty -> conn_m.m - | Text {l;style} -> + | Text { l; style } -> let ansi_prelude, ansi_suffix = - if ansi then Style_ansi.brackets style else "", "" in + if ansi then + Style_ansi.brackets style + else + "", "" + in let has_style = ansi_prelude <> "" || ansi_suffix <> "" in List.iteri - (fun line_idx (s,s_i,len)-> - if has_style then ( - Output.put_sub_string_brack out (Pos.move_y pos line_idx) - ~pre:ansi_prelude s s_i len ~post:ansi_suffix - ) else ( - Output.put_sub_string out (Pos.move_y pos line_idx) s s_i len - )) + (fun line_idx (s, s_i, len) -> + if has_style then + Output.put_sub_string_brack out (Pos.move_y pos line_idx) + ~pre:ansi_prelude s s_i len ~post:ansi_suffix + else + 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 + let { x; y } = size b' 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 (Pos.move pos (x+1) (y+1)) conn_m.m; - conn_m.m <- create_or_update ~top:true ~right:true (Pos.move pos 0 (y+1)) conn_m.m; - conn_m.m <- create_or_update ~left:true ~bottom:true (Pos.move pos (x+1) 0) conn_m.m; + conn_m.m <- + create_or_update ~left:true ~top:true + (Pos.move pos (x + 1) (y + 1)) + conn_m.m; + conn_m.m <- + create_or_update ~top:true ~right:true + (Pos.move pos 0 (y + 1)) + conn_m.m; + conn_m.m <- + create_or_update ~left:true ~bottom:true + (Pos.move pos (x + 1) 0) + conn_m.m; write_hline_ conn_m (Pos.move_x pos 1) x; - write_hline_ conn_m (Pos.move pos 1 (y+1)) x; + 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 + 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) | Pad (dim, b') -> - let expected_size = match expected_size with + let expected_size = + match expected_size with | None -> None - | Some p -> Some Pos.(p - (2*dim)) + | Some p -> Some Pos.(p - (2 * dim)) in - render_rec ~offset:Pos.(offset+dim) ~ansi ?expected_size b' Pos.(pos + dim) - | Align {h;v;inner=b'} -> - begin match expected_size with - | Some expected_size -> - (* add padding on the left *) - let hpad = match h with - | `Left -> 0 - | `Center -> max 0 ((expected_size.x - (size b').x) / 2) - | `Right -> max 0 (expected_size.x - (size b').x) - and vpad = match v with - | `Top -> 0 - | `Center -> max 0 ((expected_size.y - (size b').y) / 2) - | `Bottom -> max 0 (expected_size.y - (size b').y) - in - let pos' = Pos.move pos hpad vpad in - (* just render [b'] with new offset *) - render_rec ~offset ~ansi b' pos'; - | None -> - render_rec ~ansi ~offset b' pos - end - | Grid (style,m) -> + render_rec + ~offset:Pos.(offset + dim) + ~ansi ?expected_size b' + Pos.(pos + dim) + | Align { h; v; inner = b' } -> + (match expected_size with + | Some expected_size -> + (* add padding on the left *) + let hpad = + match h with + | `Left -> 0 + | `Center -> max 0 ((expected_size.x - (size b').x) / 2) + | `Right -> max 0 (expected_size.x - (size b').x) + and vpad = + match v with + | `Top -> 0 + | `Center -> max 0 ((expected_size.y - (size b').y) / 2) + | `Bottom -> max 0 (expected_size.y - (size b').y) + in + let pos' = Pos.move pos hpad vpad in + (* just render [b'] with new offset *) + render_rec ~offset ~ansi b' pos' + | None -> render_rec ~ansi ~offset b' pos) + | Grid (style, m) -> let dim = B.dim_matrix m in - let bars = match style with + let bars = + match style with | `None -> false | `Bars -> true in @@ -581,40 +635,63 @@ end = struct (* write boxes *) for j = 0 to dim.y - 1 do for i = 0 to dim.x - 1 do - let expected_x = match expected_size with - | Some es when i=dim.x-1 -> es.x - columns.(i) - | _ -> columns.(i+1) - columns.(i) - (if i=dim.x-1 then 0 else space_for_bars) - and expected_y = match expected_size with - | Some es when j=dim.y-1 -> es.y - lines.(j) - | _ -> lines.(j+1) - lines.(j)- (if j=dim.y-1 then 0 else space_for_bars) + let expected_x = + match expected_size with + | Some es when i = dim.x - 1 -> es.x - columns.(i) + | _ -> + columns.(i + 1) + - columns.(i) + - + if i = dim.x - 1 then + 0 + else + space_for_bars + and expected_y = + match expected_size with + | Some es when j = dim.y - 1 -> es.y - lines.(j) + | _ -> + lines.(j + 1) + - lines.(j) + - + if j = dim.y - 1 then + 0 + else + space_for_bars in - let expected_size = {x=expected_x; y=expected_y} in - let pos' = Pos.move pos (columns.(i)) (lines.(j)) in + let expected_size = { x = expected_x; y = expected_y } in + let pos' = Pos.move pos columns.(i) lines.(j) in conn_m.m <- render_rec ~ansi ~expected_size m.(j).(i) pos' - done; + done done; - let len_hlines, len_vlines = match expected_size with + let len_hlines, len_vlines = + match expected_size with | None -> columns.(dim.x), lines.(dim.y) - | Some {x;y} -> x,y + | Some { x; y } -> x, y in (* write frame if needed *) - begin match style with - | `None -> () - | `Bars -> - for j=1 to dim.y - 1 do - write_hline_ conn_m (Pos.move pos (-offset.x) (lines.(j)-1)) len_hlines - done; - for i=1 to dim.x - 1 do - write_vline_ conn_m (Pos.move pos (columns.(i)-1) (-offset.y)) len_vlines - done; - for j=1 to dim.y - 1 do - for i=1 to dim.x - 1 do - conn_m.m <- create_or_update ~left:true ~right:true ~top:true ~bottom:true (Pos.move pos (columns.(i)-1) (lines.(j)-1)) conn_m.m - done + (match style with + | `None -> () + | `Bars -> + for j = 1 to dim.y - 1 do + write_hline_ conn_m + (Pos.move pos (-offset.x) (lines.(j) - 1)) + len_hlines + done; + for i = 1 to dim.x - 1 do + write_vline_ conn_m + (Pos.move pos (columns.(i) - 1) (-offset.y)) + len_vlines + done; + for j = 1 to dim.y - 1 do + for i = 1 to dim.x - 1 do + conn_m.m <- + create_or_update ~left:true ~right:true ~top:true ~bottom:true + (Pos.move pos (columns.(i) - 1) (lines.(j) - 1)) + conn_m.m done - end; + done); conn_m.m | Tree (indent, n, a) -> conn_m.m <- render_rec ~ansi n pos; @@ -622,36 +699,54 @@ end = struct let pos' = Pos.move pos indent (size n).y in assert (Array.length a > 0); if (size n).y > 0 && has_border (Pos.move_y pos' ~-1) conn_m.m then - conn_m.m <- create_or_update ~ct:`Nontree ~bottom:true (Pos.move_y pos' ~-1) conn_m.m; + conn_m.m <- + create_or_update ~ct:`Nontree ~bottom:true (Pos.move_y pos' ~-1) + conn_m.m; (* To blend-in an empty tree root with a "wall" to the left: *) (* if (size n).y = 0 then - conn_m.m <- create_or_update ~ct:`Nontree ~right:true (Pos.move_x pos' ~-1) conn_m.m; *) - let _ = _array_foldi + conn_m.m <- create_or_update ~ct:`Nontree ~right:true (Pos.move_x pos' ~-1) conn_m.m; *) + let _ = + _array_foldi (fun pos' i b -> - let s = if pos'.y = pos.y then "──" else "└─" in - if pos'.y <> pos.y then - conn_m.m <- create_or_update ~ct:`Tree ~top:true ~right:true pos' conn_m.m - else - conn_m.m <- create_or_update ~ct:`Tree ~left:true ~right:true pos' conn_m.m; - conn_m.m <- create_or_update ~ct:`Tree ~left:true ~right:true (Pos.move_x pos' 1) conn_m.m; - conn_m.m <- create_or_update ~ct:`Tree ~top:true (Pos.move_y pos' 1) conn_m.m; - if i 0 && has_border child_pos conn_m.m then - conn_m.m <- create_or_update ~ct:`Nontree ~left:true child_pos conn_m.m; - Pos.move_y pos' (size b).y - ) pos' a + let s = + if pos'.y = pos.y then + "──" + else + "└─" + in + if pos'.y <> pos.y then + conn_m.m <- + create_or_update ~ct:`Tree ~top:true ~right:true pos' conn_m.m + else + conn_m.m <- + create_or_update ~ct:`Tree ~left:true ~right:true pos' + conn_m.m; + conn_m.m <- + create_or_update ~ct:`Tree ~left:true ~right:true + (Pos.move_x pos' 1) conn_m.m; + conn_m.m <- + create_or_update ~ct:`Tree ~top:true (Pos.move_y pos' 1) + conn_m.m; + if i < Array.length a - 1 then + write_vline_ ~ct:`Tree conn_m (Pos.move_y pos' 1) + ((size b).y - 1); + let child_pos = + Pos.move_x pos' (str_display_width_ s 0 (String.length s)) + in + conn_m.m <- render_rec ~ansi b child_pos; + if (size b).x > 0 && has_border child_pos conn_m.m then + conn_m.m <- + create_or_update ~ct:`Nontree ~left:true child_pos conn_m.m; + Pos.move_y pos' (size b).y) + pos' a in conn_m.m in - render_rec ~ansi:ansi ~offset:offset ?expected_size:expected_size b pos + render_rec ~ansi ~offset ?expected_size b pos let post_render ~out conn_map = let render_conn_pos pos conn = - if (pos.x >= 0) && (pos.y >=0) then + if pos.x >= 0 && pos.y >= 0 then if disp_conn `Nontree conn then Output.put_string out pos (disp_conn_char conn.nontree) else if disp_conn `Tree conn then @@ -659,18 +754,17 @@ end = struct in M.iter render_conn_pos conn_map - let render ~ansi out b = - post_render ~out (pre_render ~ansi ~out b Pos.origin) + let render ~ansi out b = post_render ~out (pre_render ~ansi ~out b Pos.origin) end let to_string_with ~style b = - let buf = Output.create() in + let buf = Output.create () in Box_inner.render ~ansi:style buf (Box_inner.of_box b); Output.to_string buf let to_string = to_string_with ~style:true -let output ?(style=true) ?(indent=0) oc b = +let output ?(style = true) ?(indent = 0) oc b = let buf = Output.create () in Box_inner.render ~ansi:style buf (Box_inner.of_box b); Output.to_chan ~indent oc buf; diff --git a/test/dune b/test/dune index 1446576..b2e3679 100644 --- a/test/dune +++ b/test/dune @@ -1,6 +1,6 @@ - (env - (_ (flags :standard -warn-error -a))) + (_ + (flags :standard -warn-error -a))) (test (name test_ann_0_3) @@ -14,7 +14,6 @@ (package printbox-text) (libraries printbox printbox-text)) - (test (name test_blending) (modules test_blending) @@ -38,4 +37,5 @@ (deps test_md.expected) (targets test_md.expected.md) (mode promote) - (action (copy %{deps} %{targets}))) + (action + (copy %{deps} %{targets}))) diff --git a/test/test1.ml b/test/test1.ml index ad63ce4..7aabf1e 100644 --- a/test/test1.ml +++ b/test/test1.ml @@ -2,8 +2,7 @@ module B = PrintBox (* make a square *) let square n = - Array.init n - (fun i -> Array.init n (fun j -> B.sprintf "(%d,%d)" i j)) + Array.init n (fun i -> Array.init n (fun j -> B.sprintf "(%d,%d)" i j)) |> B.grid let () = @@ -15,94 +14,138 @@ let () = let tree = B.tree (B.text "root") - [ B.tree (B.text "a") [B.text "a1\na1"; B.text "a2\na2\na2"]; - B.tree (B.text "b") [B.text "b1\nb1"; B.text "b2"; B.text "b3"]; + [ + B.tree (B.text "a") [ B.text "a1\na1"; B.text "a2\na2\na2" ]; + B.tree (B.text "b") [ B.text "b1\nb1"; B.text "b2"; B.text "b3" ]; ] -let () = - PrintBox_text.output stdout tree - -let () = - Printf.printf "\n\n" +let () = PrintBox_text.output stdout tree +let () = Printf.printf "\n\n" let grid = - B.frame @@ B.grid_l - [ [B.text "the center of the triangle is"; B.empty]; - [B.center_hv @@ B.text "lil' ol' me"; - B.pad' ~col:0 ~lines:6 @@ B.text "t\na\nl\nl"]; - [B.align_right (B.text "i'm aligned right"); B.empty]; - [ B.text "loooooooooooooooooooooooooooooooooong"; B.empty; ]; - ] + B.frame + @@ B.grid_l + [ + [ B.text "the center of the triangle is"; B.empty ]; + [ + B.center_hv @@ B.text "lil' ol' me"; + B.pad' ~col:0 ~lines:6 @@ B.text "t\na\nl\nl"; + ]; + [ B.align_right (B.text "i'm aligned right"); B.empty ]; + [ B.text "loooooooooooooooooooooooooooooooooong"; B.empty ]; + ] let () = PrintBox_text.output stdout grid; print_endline "" -let b2 = PrintBox.( +let b2 = + PrintBox.( let style = Style.(fg_color Red) in - frame @@ grid_l [ - [text_with_style style "a\nb"; - line_with_style Style.(set_bold true @@ bg_color Green) "OH!"]; - [text "c"; text "ballot"]; - ]) + frame + @@ grid_l + [ + [ + text_with_style style "a\nb"; + line_with_style Style.(set_bold true @@ bg_color Green) "OH!"; + ]; + [ text "c"; text "ballot" ]; + ]) let () = - PrintBox_text.output stdout b2; Printf.printf "\n\n" + PrintBox_text.output stdout b2; + Printf.printf "\n\n" let grid2 = - B.frame @@ B.record ~pad:B.align_right ["name1", B.int 1; "foo", B.bool true] + B.frame + @@ B.record ~pad:B.align_right [ "name1", B.int 1; "foo", B.bool true ] let () = - PrintBox_text.output stdout grid2; print_endline "" + PrintBox_text.output stdout grid2; + print_endline "" let grid3 = - B.frame @@ B.v_record ~pad:B.center_h - ["name_int_long", B.int 1; "foo", B.bool true; "bar!", B.int 42] + B.frame + @@ B.v_record ~pad:B.center_h + [ "name_int_long", B.int 1; "foo", B.bool true; "bar!", B.int 42 ] let () = - PrintBox_text.output stdout grid3; print_endline "" + PrintBox_text.output stdout grid3; + print_endline "" module Box_in = struct let b = let open B in - frame @@ grid_l [ - [ text "a"; text "looooooooooooooooooooooooo\noonng"]; - [ text "bx"; center_hv @@ frame @@ record ["x", int 1; "y", int 2]]; - [ pad' ~col:2 ~lines:2 @@ text "?"; - center_hv @@ record ["x", int 10; "y", int 20]]; - ] + frame + @@ grid_l + [ + [ text "a"; text "looooooooooooooooooooooooo\noonng" ]; + [ + text "bx"; center_hv @@ frame @@ record [ "x", int 1; "y", int 2 ]; + ]; + [ + pad' ~col:2 ~lines:2 @@ text "?"; + center_hv @@ record [ "x", int 10; "y", int 20 ]; + ]; + ] let () = print_endline @@ PrintBox_text.to_string b end let _b = let open PrintBox in - frame @@ record [ - ("subject", text_with_style Style.bold "announce: printbox 0.3"); - ("explanation", - frame @@ text {|PrintBox is a library for rendering nested tables, - trees, and similar structures in monospace text or HTML.|}); - ("github", - text_with_style Style.(bg_color Blue) "https://github.com/c-cube/printbox/releases/tag/0.3"); - ("contributors", - vlist_map (text_with_style Style.(fg_color Green)) ["Simon"; "Guillaume"; "Matt"]); - ("dependencies", - tree empty - [tree (text "mandatory") - [text "dune"; text "bytes"]; - tree (text "optional") - [text "uutf"; text "uucp"; text "tyxml"]]); - ("expected reaction", text "🎉"); - ] + frame + @@ record + [ + "subject", text_with_style Style.bold "announce: printbox 0.3"; + ( "explanation", + frame + @@ text + {|PrintBox is a library for rendering nested tables, + trees, and similar structures in monospace text or HTML.|} + ); + ( "github", + text_with_style + Style.(bg_color Blue) + "https://github.com/c-cube/printbox/releases/tag/0.3" ); + ( "contributors", + vlist_map + (text_with_style Style.(fg_color Green)) + [ "Simon"; "Guillaume"; "Matt" ] ); + ( "dependencies", + tree empty + [ + tree (text "mandatory") [ text "dune"; text "bytes" ]; + tree (text "optional") [ text "uutf"; text "uucp"; text "tyxml" ]; + ] ); + "expected reaction", text "🎉"; + ] module Unicode = struct let b = - B.(frame @@ vlist [text "nice unicode! 💪"; frame @@ - hlist [ - vlist[text "oï ωεird nums:\nπ/2\nτ/4"; - center_hv @@ tree (text "0")[text "1"; tree (text "ω") [text "ω²"]]]; - frame @@ frame @@ frame - @@ vlist [text "sum=Σ_i a·xᵢ²\n—————\n1+1"; align_right @@ text "Ōₒ\nÀ"]]]);; + B.( + frame + @@ vlist + [ + text "nice unicode! 💪"; + frame + @@ hlist + [ + vlist + [ + text "oï ωεird nums:\nπ/2\nτ/4"; + center_hv + @@ tree (text "0") + [ text "1"; tree (text "ω") [ text "ω²" ] ]; + ]; + frame @@ frame @@ frame + @@ vlist + [ + text "sum=Σ_i a·xᵢ²\n—————\n1+1"; + align_right @@ text "Ōₒ\nÀ"; + ]; + ]; + ]) let () = print_endline @@ PrintBox_text.to_string b end diff --git a/test/test_ann_0_3.ml b/test/test_ann_0_3.ml index 9f69ec7..d95a2c1 100644 --- a/test/test_ann_0_3.ml +++ b/test/test_ann_0_3.ml @@ -1,22 +1,38 @@ - let b = let open PrintBox in - frame @@ grid_l [ - [text "subject"; text_with_style Style.bold "announce: printbox 0.3"]; - [text "explanation"; - frame @@ text {|PrintBox is a library for rendering nested tables, - trees, and similar structures in monospace text or HTML.|}]; - [text "github"; - text_with_style Style.(bg_color Blue) "https://github.com/c-cube/printbox/releases/tag/0.3"]; - [text "contributors"; - vlist_map (text_with_style Style.(fg_color Green)) ["Simon"; "Guillaume"; "Matt"]]; - [text "dependencies"; - tree empty - [tree (text "mandatory") - [text "dune"; text "bytes"; text "uutf"; text "uucp"]; - tree (text "optional") - [text "tyxml"]]]; - [text "expected reaction"; text "🎉"]; - ] + frame + @@ grid_l + [ + [ text "subject"; text_with_style Style.bold "announce: printbox 0.3" ]; + [ + text "explanation"; + frame + @@ text + {|PrintBox is a library for rendering nested tables, + trees, and similar structures in monospace text or HTML.|}; + ]; + [ + text "github"; + text_with_style + Style.(bg_color Blue) + "https://github.com/c-cube/printbox/releases/tag/0.3"; + ]; + [ + text "contributors"; + vlist_map + (text_with_style Style.(fg_color Green)) + [ "Simon"; "Guillaume"; "Matt" ]; + ]; + [ + text "dependencies"; + tree empty + [ + tree (text "mandatory") + [ text "dune"; text "bytes"; text "uutf"; text "uucp" ]; + tree (text "optional") [ text "tyxml" ]; + ]; + ]; + [ text "expected reaction"; text "🎉" ]; + ] let () = print_endline @@ PrintBox_text.to_string b diff --git a/test/test_blending.ml b/test/test_blending.ml index 08e2a5d..5a15b4b 100644 --- a/test/test_blending.ml +++ b/test/test_blending.ml @@ -1,18 +1,20 @@ let b = let open PrintBox in - tree (frame @@ text "root") [ - frame @@ text "child 1"; - text "child 2"; - frame @@ tree empty [ - tree (frame @@ text "header 3") [frame @@ text "subchild 3"] - ]; - tree empty [ - tree (frame @@ text "header 4") [frame @@ text "subchild 4"] - ]; - frame @@ text "child 5"; - frame @@ tree (frame @@ text "header 6") [ - tree (frame @@ text "child 6") [frame @@ text "subchild 6"] + tree + (frame @@ text "root") + [ + frame @@ text "child 1"; + text "child 2"; + frame + @@ tree empty + [ tree (frame @@ text "header 3") [ frame @@ text "subchild 3" ] ]; + tree empty + [ tree (frame @@ text "header 4") [ frame @@ text "subchild 4" ] ]; + frame @@ text "child 5"; + frame + @@ tree + (frame @@ text "header 6") + [ tree (frame @@ text "child 6") [ frame @@ text "subchild 6" ] ]; ] - ] let () = print_endline @@ PrintBox_text.to_string b diff --git a/test/test_html.ml b/test/test_html.ml index 195dcdd..e0bf080 100644 --- a/test/test_html.ml +++ b/test/test_html.ml @@ -1,16 +1,18 @@ let b = let open PrintBox in - tree (frame @@ text "root") [ - frame @@ text "child 1"; - text "child 2"; - frame @@ tree empty [ - tree (frame @@ text "header 3") [frame @@ text "subchild 3"] - ]; - tree empty [ - tree (frame @@ text "header 4") [text "subchild 4"] - ]; - frame @@ tree (text "header 5") [text "subchild 5"]; - frame @@ text "child 5" - ] + tree + (frame @@ text "root") + [ + frame @@ text "child 1"; + text "child 2"; + frame + @@ tree empty + [ tree (frame @@ text "header 3") [ frame @@ text "subchild 3" ] ]; + tree empty [ tree (frame @@ text "header 4") [ text "subchild 4" ] ]; + frame @@ tree (text "header 5") [ text "subchild 5" ]; + frame @@ text "child 5"; + ] -let () = print_endline @@ PrintBox_html.(to_string ~config:Config.(tree_summary true default)) b +let () = + print_endline + @@ PrintBox_html.(to_string ~config:Config.(tree_summary true default)) b diff --git a/test/test_md.ml b/test/test_md.ml index d8664ad..abac1ef 100644 --- a/test/test_md.ml +++ b/test/test_md.ml @@ -1,76 +1,119 @@ let b = let open PrintBox in let table = - frame @@ grid_l [ - [ text "a"; text "looooooooooooooooooooooooo\noonng"]; - [ text "bx"; center_hv @@ frame @@ record ["x", int 1; "y", int 2]]; - [ pad' ~col:2 ~lines:2 @@ text "?"; - center_hv @@ record ["x", int 10; "y", int 20]]; - ] in + frame + @@ grid_l + [ + [ text "a"; text "looooooooooooooooooooooooo\noonng" ]; + [ + text "bx"; center_hv @@ frame @@ record [ "x", int 1; "y", int 2 ]; + ]; + [ + pad' ~col:2 ~lines:2 @@ text "?"; + center_hv @@ record [ "x", int 10; "y", int 20 ]; + ]; + ] + in let bold = text_with_style Style.bold in let native = - grid_l [ - [ bold "header 1"; bold "header 2"; frame @@ bold "header 3" ]; - [ line "cell 1.1"; frame @@ line "cell 1.2"; line "cell 1.3" ]; - [ frame @@ line "cell 2.1"; line "cell 2.2"; bold "cell 2.3" ]; - ] in - tree (frame @@ text "root") [ - frame @@ text "child 1"; - text_with_style Style.preformatted "child 2"; - lines ["line 1"; "line 2"; "line 3"]; - vlist ~bars:false [ - line "a row 1"; lines ["a row 2.1"; "a row 2.2"]; frame @@ line "a row 3"]; - vlist ~bars:true [ - line "b row 1"; lines ["b row 2.1"; "b row 2.2"]; bold "b row 3"]; - hlist ~bars:false [ - bold "a longiiish column 1"; line "a longiiish column 2"; - frame @@ line "a longiiish column 3"; line "a longiiish column 4"]; - hlist ~bars:true [ - line "b longiiish column 1"; bold "b longiiish column 2"; - line "b longiiish column 3"; frame @@ line "b longiiish column 4"]; - frame @@ vlist ~bars:true [ - line "c row 1"; lines ["c row 2.1"; "c row 2.2"]; line "c row 3" - ]; - frame @@ tree empty [ - tree (frame @@ text "header 3") [frame @@ text "subchild 3"] - ]; - tree empty [ - tree (frame @@ text "header 4") [ - tree (text " ") [text_with_style Style.preformatted " "]; - text "& **subchild** 4"] - ]; - frame @@ tree (text_with_style Style.preformatted "header 5") - [lines_with_style Style.preformatted - ["subchild 5"; " body 5"; " subbody 5"; - "\tone tab end of sub 5"; "end of 5"]]; - frame table; - native; - frame native - ] + grid_l + [ + [ bold "header 1"; bold "header 2"; frame @@ bold "header 3" ]; + [ line "cell 1.1"; frame @@ line "cell 1.2"; line "cell 1.3" ]; + [ frame @@ line "cell 2.1"; line "cell 2.2"; bold "cell 2.3" ]; + ] + in + tree + (frame @@ text "root") + [ + frame @@ text "child 1"; + text_with_style Style.preformatted "child 2"; + lines [ "line 1"; "line 2"; "line 3" ]; + vlist ~bars:false + [ + line "a row 1"; + lines [ "a row 2.1"; "a row 2.2" ]; + frame @@ line "a row 3"; + ]; + vlist ~bars:true + [ line "b row 1"; lines [ "b row 2.1"; "b row 2.2" ]; bold "b row 3" ]; + hlist ~bars:false + [ + bold "a longiiish column 1"; + line "a longiiish column 2"; + frame @@ line "a longiiish column 3"; + line "a longiiish column 4"; + ]; + hlist ~bars:true + [ + line "b longiiish column 1"; + bold "b longiiish column 2"; + line "b longiiish column 3"; + frame @@ line "b longiiish column 4"; + ]; + frame + @@ vlist ~bars:true + [ + line "c row 1"; lines [ "c row 2.1"; "c row 2.2" ]; line "c row 3"; + ]; + frame + @@ tree empty + [ tree (frame @@ text "header 3") [ frame @@ text "subchild 3" ] ]; + tree empty + [ + tree + (frame @@ text "header 4") + [ + tree (text " ") + [ text_with_style Style.preformatted " " ]; + text "& **subchild** 4"; + ]; + ]; + frame + @@ tree + (text_with_style Style.preformatted "header 5") + [ + lines_with_style Style.preformatted + [ + "subchild 5"; + " body 5"; + " subbody 5"; + "\tone tab end of sub 5"; + "end of 5"; + ]; + ]; + frame table; + native; + frame native; + ] let () = print_endline "Test default:" - let () = print_endline @@ PrintBox_md.(to_string Config.default) b - let () = print_endline "Test uniform unfolded:\n" -let () = print_endline @@ PrintBox_md.(to_string Config.(unfolded_trees uniform)) b +let () = + print_endline @@ PrintBox_md.(to_string Config.(unfolded_trees uniform)) b let () = print_endline "Test foldable:" -let () = print_endline @@ PrintBox_md.(to_string Config.(foldable_trees default)) b +let () = + print_endline @@ PrintBox_md.(to_string Config.(foldable_trees default)) b let () = print_endline "Test uniform tab=2, text tables:" let () = - print_endline @@ - PrintBox_md.(to_string Config.(text_tables @@ tab_width 2 uniform)) b + print_endline + @@ PrintBox_md.(to_string Config.(text_tables @@ tab_width 2 uniform)) b let () = print_endline "Test single quote tab=2, text tables:" let () = - print_endline @@ - PrintBox_md.(to_string Config.( - text_tables @@ tab_width 2 @@ multiline_preformatted Code_quote uniform)) b + print_endline + @@ PrintBox_md.( + to_string + Config.( + text_tables @@ tab_width 2 + @@ multiline_preformatted Code_quote uniform)) + b let () = print_endline "The end."