package printbox

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file PrintBox.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
(* This file is free software. See file "license" for more details. *)

(** {1 Pretty-Printing of Boxes} *)

type position = { x:int ; y: int }

module Style = struct
  type color =
    | Black
    | Red
    | Yellow
    | Green
    | Blue
    | Magenta
    | Cyan
    | White

  type t = {
    bold: bool;
    bg_color: color option;
    fg_color: color option;
  }

  let default = {bold=false; bg_color=None; fg_color=None}
  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 bold : t = set_bold true default
  let bg_color c : t = set_bg_color c default
  let fg_color c : t = set_fg_color c default
end

type view =
  | Empty
  | Text of {
      l: string list;
      style: Style.t;
    }
  | Frame of t
  | Pad of position * t (* vertical and horizontal padding *)
  | Align of {
      h: [`Left | `Center | `Right];
      v: [`Top | `Center | `Bottom];
      inner: t;
    }
  | Grid of [`Bars | `None] * t array array
  | Tree of int * t * t array
  | Link of {
      uri: string;
      inner: t;
    }

and t = view

let empty = Empty
let[@inline] view (t:t) : view = t

let[@inline] line_ s = Text {l=[s]; style=Style.default}

let line_with_style style s =
  if String.contains s '\n' then invalid_arg "PrintBox.line";
  Text {l=[s]; style}

let line s = line_with_style Style.default s

let text s = Text {l=[s]; style=Style.default}
let text_with_style style s = Text {l=[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

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 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)

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_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 grid ?(pad=fun b->b) ?(bars=true) m =
  let m = map_matrix pad m in
  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
  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_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 =
  grid_map ?bars (fun x -> pad (text x)) m

let grid_text_l ?pad ?bars l =
  grid_text ?pad ?bars (Array.of_list l |> Array.map Array.of_list)

let record ?pad ?bars l =
  let fields, vals = List.split l in
  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)

let dim_matrix m =
  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)))

let tree ?(indent=0) node children =
  if indent < 0 then invalid_arg "tree: need non-negative indent";
  let children =
    List.filter
      (function
        | Empty -> false
        | _ -> true)
      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
    | b, [] -> b
    | b, children -> tree ?indent b (List.map make children)
  in
  make root

let link ~uri inner : t = Link {uri; inner}

(** {2 Simple Structural Interface} *)

type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list]
type box = t

module Simple = struct
  type t =
    [ `Empty
    | `Pad of t
    | `Text of string
    | `Vlist of t list
    | `Hlist of t list
    | `Table of t array array
    | `Tree of t * t list
    ]

  let rec to_box = function
    | `Empty -> empty
    | `Pad b -> pad (to_box b)
    | `Text t -> text t
    | `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)

  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
    | `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

  let asprintf format =
    Format.kasprintf (fun s -> `Text s) format
end
OCaml

Innovation. Community. Security.