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
let counter = ref 0
let calc_width =
let table = Verdana.table in
let len = Array.length table in
let fallback = table.(64) in
fun text ->
let total = ref 0. in
String.iter
(fun c ->
let code = Char.code c in
let width = if code >= len then fallback else table.(code) in
total := !total +. width )
text;
!total
let sanitize s =
let buffer = Buffer.create @@ String.length s in
let fmt = Format.formatter_of_buffer buffer in
let add = Format.fprintf fmt in
let add_c = Buffer.add_char buffer in
String.iter
(function
| '&' -> add "&"
| '<' -> add "<"
| '>' -> add ">"
| '\'' -> add "'"
| '\"' -> add """
| '@' -> add "@"
| c -> add_c c )
s;
Buffer.contents buffer
let create_accessible_text label status =
if String.equal label "" then status else Format.sprintf "%s: %s" label status
let bare fmt ?(color = Color.Blue) ?(style = Style.Classic) ?(scale = 1.)
~status () =
let st_text_width = calc_width status in
let st_rect_width = st_text_width +. 115. in
let status = sanitize status in
let width = scale *. st_rect_width /. 10. in
let height = scale *. 20. in
match style with
| Classic ->
Format.fprintf fmt
{|<svg xmlns="http://www.w3.org/2000/svg" width="%f" height="%f" viewBox="0 0 %f 200" role="img" aria-label="%s">
<title>%s</title>
<linearGradient id="a" x2="0" y2="100%%">
<stop offset="0" stop-opacity=".1" stop-color="#EEE"/>
<stop offset="1" stop-opacity=".1"/>
</linearGradient>
<mask id="m"><rect width="%f" height="200" rx="30" fill="#FFF"/></mask>
<g mask="url(#m)">
<rect width="%f" height="200" fill="#%a" x="0"/>
<rect width="%f" height="200" fill="url(#a)"/>
</g>
<g aria-hidden="true" fill="#fff" text-anchor="start" font-family="Verdana,DejaVu Sans,sans-serif" font-size="110">
<text x="65" y="148" textLength="%f" fill="#000" opacity="0.25">%s</text>
<text x="55" y="138" textLength="%f">%s</text>
</g>
</svg>@.|}
width height st_rect_width status status st_rect_width st_rect_width
Color.pp color st_rect_width st_text_width status st_text_width status
| Flat ->
Format.fprintf fmt
{|<svg xmlns="http://www.w3.org/2000/svg" width="%f" height="%f" viewBox="0 0 %f 200" role="img" aria-label="%s">
<title>%s</title>
<g>
<rect fill="#%a" x="0" width="%f" height="200"/>
</g>
<g aria-hidden="true" fill="#fff" text-anchor="start" font-family="Verdana,DejaVu Sans,sans-serif" font-size="110">
<text x="65" y="148" textLength="%f" fill="#000" opacity="0.1">%s</text>
<text x="55" y="138" textLength="%f">%s</text>
</g>
</svg>@.|}
width height st_rect_width status status Color.pp color st_rect_width
st_text_width status st_text_width status
let mk fmt ?(counter = counter) ?(label = "") ?(color = Color.Blue)
?(style = Style.Classic) ?(icon = None) ?(icon_width = 13.)
?(label_color = Color.Custom "555") ?(scale = 1.) ~status () =
if String.equal label "" && Option.is_none icon then
bare fmt ~status ~color ~style ~scale ()
else
let icon_width = icon_width *. 10. in
let icon_span_width =
if Option.is_none icon then 0.
else if String.equal label "" then icon_width -. 18.
else icon_width +. 30.
in
let sb_text_start =
if Option.is_none icon then 50. else icon_width +. 50.
in
let sb_text_width = calc_width label in
let st_text_width = calc_width status in
let sb_rect_width = sb_text_width +. 100. +. icon_span_width in
let st_rect_width = st_text_width +. 100. in
let width = sb_rect_width +. st_rect_width in
let xlink =
if Option.is_none icon then ""
else {| xmlns:xlink="http://www.w3.org/1999/xlink"|}
in
let label = sanitize label in
let status = sanitize status in
let accessible_text = create_accessible_text label status in
let svg_width = scale *. width /. 10. in
let svg_height = scale *. 20. in
match style with
| Classic ->
incr counter;
Format.fprintf fmt
{|<svg xmlns="http://www.w3.org/2000/svg"%s width="%f" height="%f" viewBox="0 0 %f 200" role="img" aria-label="%s">
<title>%s</title>
<linearGradient id="ocaml-ocb-a-%d" x2="0" y2="100%%">
<stop offset="0" stop-opacity=".1" stop-color="#EEE"/>
<stop offset="1" stop-opacity=".1"/>
</linearGradient>
<mask id="ocaml-ocb-m-%d"><rect width="%f" height="200" rx="30" fill="#FFF"/></mask>
<g mask="url(#ocaml-ocb-m-%d)">
<rect width="%f" height="200" fill="#%a"/>
<rect width="%f" height="200" fill="#%a" x="%f"/>
<rect width="%f" height="200" fill="url(#ocaml-ocb-a-%d)"/>
</g>
<g aria-hidden="true" fill="#fff" text-anchor="start" font-family="Verdana,DejaVu Sans,sans-serif" font-size="110">
<text x="%f" y="148" textLength="%f" fill="#000" opacity="0.25">%s</text>
<text x="%f" y="138" textLength="%f">%s</text>
<text x="%f" y="148" textLength="%f" fill="#000" opacity="0.25">%s</text>
<text x="%f" y="138" textLength="%f">%s</text>
</g>
%a</svg>@.|}
xlink svg_width svg_height width accessible_text accessible_text
!counter !counter width !counter sb_rect_width Color.pp label_color
st_rect_width Color.pp color sb_rect_width width !counter
(sb_text_start +. 10.) sb_text_width label sb_text_start sb_text_width
label (sb_rect_width +. 55.) st_text_width status (sb_rect_width +. 45.)
st_text_width status Icon.pp (icon, icon_width, 130.)
| Flat ->
Format.fprintf fmt
{|<svg xmlns="http://www.w3.org/2000/svg"%s width="%f" height="%f" viewBox="0 0 %f 200" role="img" aria-label="%s">
<title>%s</title>
<g>
<rect fill="#%a" width="%f" height="200"/>
<rect fill="#%a" x="%f" width="%f" height="200"/>
</g>
<g aria-hidden="true" fill="#fff" text-anchor="start" font-family="Verdana,DejaVu Sans,sans-serif" font-size="110">
<text x="%f" y="148" textLength="%f" fill="#000" opacity="0.1">%s</text>
<text x="%f" y="138" textLength="%f">%s</text>
<text x="%f" y="148" textLength="%f" fill="#000" opacity="0.1">%s</text>
<text x="%f" y="138" textLength="%f">%s</text>
</g>
%a</svg>@.|}
xlink svg_width svg_height width accessible_text accessible_text
Color.pp label_color sb_rect_width Color.pp color sb_rect_width
st_rect_width (sb_text_start +. 10.) sb_text_width label sb_text_start
sb_text_width label (sb_rect_width +. 55.) st_text_width status
(sb_rect_width +. 45.) st_text_width status Icon.pp
(icon, icon_width, 132.)