Source file CSS.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
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
include Declarations
include Colors
include Alias
include Rule
ave a module called Css_types and not Types directly, is because we use a unwrapped library, so all modules are exposed. "Types" would collide with a lot of modules in user's application *)
module Types = Css_types
module Array = struct
include Kloth.Array
include Stdlib.ArrayLabels
type 'a t = 'a array
let ( @ ) = Stdlib.Array.append
let is_empty a = Array.length a == 0
let is_not_empty a = Array.length a != 0
let join ~sep a = String.concat sep (Array.to_list a)
let partition_map ~f t =
let (both : _ Either.t t) = map t ~f in
let firsts =
filter_map ~f:(function Either.Left x -> Some x | Right _ -> None) both
in
let seconds =
filter_map ~f:(function Either.Left _ -> None | Right x -> Some x) both
in
firsts, seconds
let partition ~f t =
(partition_map t ~f:(fun x ->
match f x with true -> Left x | false -> Right x)
[@nontail])
let flatten a = Array.concat (Array.to_list a)
end
let render_declaration rule =
match rule with
| Rule.Declaration ("label", _value) -> None
| Rule.Declaration (property, value) ->
Some (Printf.sprintf "%s: %s;" property value)
| _ -> None
let render_declarations rules =
rules
|> Array.map ~f:Autoprefixer.prefix
|> Array.flatten
|> Array.filter_map ~f:render_declaration
|> Array.join ~sep:" "
let contains_at selector = String.contains selector '@'
let contains_ampersand selector = String.contains selector '&'
let contains_a_coma selector = String.contains selector ','
let starts_with_at selector = String.starts_with ~prefix:"@" selector
let starts_with_dot selector = String.starts_with ~prefix:"." selector
let starts_with_double_dot selector = String.starts_with ~prefix:":" selector
let starts_with_ampersand selector = String.starts_with ~prefix:"&" selector
let prefix ~pre s =
let len = String.length pre in
if len > String.length s then false
else (
let rec check i =
if i = len then true
else if String.unsafe_get s i <> String.unsafe_get pre i then false
else check (i + 1)
in
check 0)
let chop_prefix ~pre s =
if prefix ~pre s then
Some
(String.sub s (String.length pre) (String.length s - String.length pre))
else None
let remove_first_ampersand str = String.sub str 1 (String.length str - 1)
let replace_ampersand ~by str =
let rec replace_ampersand' str var =
let len = String.length str in
if len = 0 then ""
else if str.[0] = '&' then
var ^ replace_ampersand' (String.sub str 1 (len - 1)) var
else
String.sub str 0 1 ^ replace_ampersand' (String.sub str 1 (len - 1)) var
in
replace_ampersand' str by
let rec rule_to_debug nesting accumulator rule =
let next_rule =
match rule with
| Rule.Declaration (property, value) ->
Printf.sprintf "Declaration (\"%s\", \"%s\")" property value
| Rule.Selector (selector, rules) ->
if nesting = 0 then
Printf.sprintf "Selector (\"%s\", [%s])" selector
(to_debug (nesting + 1) rules)
else
Printf.sprintf "Selector (\"%s\", [%s\n%s])" selector
(to_debug (nesting + 1) rules)
(String.make (nesting + 1) ' ')
in
let space = if nesting > 0 then String.make (nesting * 2) ' ' else "" in
accumulator ^ Printf.sprintf "\n%s" space ^ next_rule
and to_debug nesting rules =
rules |> Array.fold_left ~f:(rule_to_debug nesting) ~init:""
let print_rules ?(initial = 0) rules =
match rules with
| [||] ->
let space = if initial > 0 then String.make (initial * 2) ' ' else "" in
print_endline @@ Printf.sprintf "\n%s Empty []\n" space
| _ ->
rules
|> Array.iter ~f:(fun rule -> print_endline (to_debug initial [| rule |]))
let split_by_kind rules =
Array.partition ~f:(function Rule.Declaration _ -> true | _ -> false) rules
let resolve_ampersand hash selector =
let classname = "." ^ hash in
let resolved_selector = replace_ampersand ~by:classname selector in
if contains_ampersand selector then resolved_selector
else if starts_with_at selector then resolved_selector
else if starts_with_double_dot selector then
Printf.sprintf ".%s%s" hash resolved_selector
else Printf.sprintf ".%s %s" hash resolved_selector
let remove_media_from_selector selector =
chop_prefix ~pre:"@media " selector |> Option.value ~default:selector
let join_media left right = left ^ " and " ^ remove_media_from_selector right
let rules_do_not_contain_media rules =
Array.exists
~f:(function Rule.Selector (s, _) when contains_at s -> false | _ -> true)
rules
let rules_contain_media rules =
Array.exists
~f:(function Rule.Selector (s, _) when contains_at s -> true | _ -> false)
rules
let rec move_media_at_top (rule_list : rule array) : rule array =
Array.fold_left
~f:(fun acc rule ->
match rule with
| Rule.Selector (current_selector, rules)
when contains_at current_selector && rules_contain_media rules ->
let new_rules = swap current_selector rules in
Array.append acc new_rules
| Rule.Selector (current_selector, rules)
when Array.is_not_empty rules && rules_contain_media rules ->
let declarations, selectors = split_by_kind rules in
let media_selectors, non_media_selectors =
Array.partition selectors ~f:(function
| Rule.Selector (s, _) when contains_at s -> true
| _ -> false)
in
let new_media_rules =
Array.map
~f:(fun media_rules ->
match media_rules with
| Rule.Selector (nested_media_selector, nested_media_rule_list)
when contains_at nested_media_selector ->
[|
Rule.Selector
( nested_media_selector,
[|
Rule.Selector (current_selector, nested_media_rule_list);
|] );
|]
| _ -> [||])
media_selectors
|> Array.flatten
in
let selector_without_media =
[|
Rule.Selector
(current_selector, Array.(declarations @ non_media_selectors));
|]
in
Array.(acc @ selector_without_media @ new_media_rules)
| Rule.Selector (_current_selector, rules) when Array.is_not_empty rules
->
Array.append acc [| rule |]
| Rule.Declaration (_, _) as rule -> Array.append acc [| rule |]
| _ -> acc)
~init:[||] rule_list
and swap at_media_selector media_rules =
let media_declarations, media_rules_selectors = split_by_kind media_rules in
let resolved_media_selectors =
Array.map
~f:(fun media_rules ->
match media_rules with
| Rule.Selector (nested_media_selector, nested_media_rule_list) ->
[|
Rule.Selector (at_media_selector, media_declarations);
Rule.Selector
( join_media at_media_selector nested_media_selector,
nested_media_rule_list );
|]
| _ -> [||])
media_rules_selectors
|> Array.flatten
in
move_media_at_top resolved_media_selectors
let split_multiple_selectors rule_list =
Array.fold_left
~f:(fun acc rule ->
match rule with
| Rule.Selector (selector, rules) when contains_a_coma selector ->
let selector_list = String.split_on_char ',' selector in
let new_rules =
List.map
(fun selector -> Rule.Selector (String.trim selector, rules))
selector_list
in
List.append acc new_rules
| rule -> List.append acc [ rule ])
~init:[] rule_list
|> Array.of_list
let resolve_selectors rules =
let rec unnest_selectors ~prefix rules =
Array.partition_map rules ~f:(function
| Rule.Selector (current_selector, selector_rules)
when starts_with_at current_selector ->
Right [| Rule.Selector (current_selector, selector_rules) |]
| Rule.Selector (current_selector, selector_rules) ->
let new_prefix =
match prefix with
| None -> current_selector
| Some prefix ->
if starts_with_ampersand current_selector then
prefix ^ remove_first_ampersand current_selector
else if contains_ampersand current_selector then
replace_ampersand ~by:prefix current_selector
else if starts_with_double_dot current_selector then
prefix ^ current_selector
else if starts_with_dot current_selector then
prefix ^ " " ^ current_selector
else prefix ^ " " ^ current_selector
in
let selector_rules = split_multiple_selectors selector_rules in
let selectors, rest_of_declarations =
unnest_selectors ~prefix:(Some new_prefix) selector_rules
in
let new_selector = Rule.Selector (new_prefix, selectors) in
Right (Array.append [| new_selector |] rest_of_declarations)
| _ as rule -> Left rule)
|> fun (selectors, declarations) -> selectors, Array.flatten declarations
in
let rules = move_media_at_top rules in
let rules = split_multiple_selectors rules in
let declarations, selectors = unnest_selectors ~prefix:None rules in
Array.append declarations selectors
let render_keyframes animationName keyframes =
let definition =
keyframes
|> Array.map ~f:(fun (percentage, rules) ->
Printf.sprintf "%i%% { %s }" percentage (render_declarations rules))
|> Array.join ~sep:" "
in
Printf.sprintf "@keyframes %s { %s }" animationName definition
let rec render_rules className rules =
let declarations, selectors = split_by_kind (resolve_selectors rules) in
let declarations =
match declarations with
| [||] -> ""
| _ ->
Printf.sprintf ".%s { %s }" className (render_declarations declarations)
in
let selectors =
match selectors with
| [||] -> ""
| _ ->
selectors
|> Array.filter_map ~f:(render_selectors className)
|> Array.join ~sep:" "
in
String.trim @@ String.concat " " [ declarations; selectors ]
and render_selectors hash rule =
match rule with
| Rule.Selector (_selector, rules) when Array.is_empty rules -> None
| Rule.Selector (selector, rules) when contains_at selector ->
let nested_selectors = render_rules hash rules in
Some (Printf.sprintf "%s { %s }" selector nested_selectors)
| Rule.Selector (selector, rules) ->
let new_selector = resolve_ampersand hash selector in
Some (Printf.sprintf "%s { %s }" new_selector (render_declarations rules))
| _ -> None
let rec rules_to_string rules =
let buff = Buffer.create 16 in
let push = Buffer.add_string buff in
let rule_to_string rule =
match rule with
| Rule.Declaration (property, value) ->
push (Printf.sprintf "%s:%s;" property value)
| Rule.Selector (selector, rules) ->
let rules = rules_to_string rules in
push (Printf.sprintf "%s{%s}" selector rules)
in
Array.iter ~f:rule_to_string rules;
Buffer.contents buff
type declarations =
| Globals of rule array
| Classnames of {
className : string;
styles : rule array;
}
| Keyframes of {
animationName : string;
keyframes : (int * rule array) array;
}
module Stylesheet = struct
module Hashes = Set.Make (String)
type t = {
mutable rules : (string * declarations) list;
mutable hashes : Hashes.t;
}
let make () = { rules = []; hashes = Hashes.empty }
let push stylesheet item =
let hash = fst item in
if Hashes.mem hash stylesheet.hashes then ()
else (
stylesheet.hashes <- Hashes.add hash stylesheet.hashes;
stylesheet.rules <- item :: stylesheet.rules)
let get_all stylesheet = List.rev stylesheet.rules
let flush stylesheet =
stylesheet.rules <- [];
stylesheet.hashes <- Hashes.empty
end
let keyframes_to_string keyframes =
let pp_keyframe (percentage, rules) =
Printf.sprintf "%d%%{%s}" percentage (rules_to_string rules)
in
keyframes |> Array.map ~f:pp_keyframe |> Array.to_list |> String.concat ""
let render_hash hash styles =
let is_label = function
| Rule.Declaration ("label", value) -> Some value
| _ -> None
in
match Array.find_map ~f:is_label styles with
| Some label -> Printf.sprintf "%s-%s" hash label
| None -> Printf.sprintf "%s" hash
let instance = Stylesheet.make ()
let flush () = Stylesheet.flush instance
let style (styles : rule array) =
match styles with
| [||] -> "css-0"
| _ ->
let hash = render_hash (Murmur2.default (rules_to_string styles)) styles in
let className = Printf.sprintf "%s-%s" "css" hash in
Stylesheet.push instance (hash, Classnames { className; styles });
className
let global (styles : rule array) =
match styles with
| [||] -> ()
| _ ->
let hash = Murmur2.default (rules_to_string styles) in
Stylesheet.push instance (hash, Globals styles)
let keyframes (keyframes : (int * rule array) array) =
match keyframes with
| [||] -> Types.AnimationName.make ""
| _ ->
let hash = Murmur2.default (keyframes_to_string keyframes) in
let animationName = Printf.sprintf "%s-%s" "animation" hash in
Stylesheet.push instance (hash, Keyframes { animationName; keyframes });
Types.AnimationName.make animationName
let get_stylesheet () =
Stylesheet.get_all instance
|> List.fold_left
(fun accumulator (_, rules) ->
match rules with
| Globals rules ->
let new_rules = resolve_selectors rules in
let rules = String.trim @@ rules_to_string new_rules in
Printf.sprintf "%s %s" accumulator rules
| Classnames { className; styles } ->
let rules = String.trim @@ render_rules className styles in
Printf.sprintf "%s %s" accumulator rules
| Keyframes { animationName; keyframes } ->
let rules =
String.trim @@ render_keyframes animationName keyframes
in
Printf.sprintf "%s %s" accumulator rules)
""
|> String.trim
let get_string_style_hashes () =
Stylesheet.get_all instance
|> List.fold_left
(fun accumulator (hash, _) ->
String.trim @@ Printf.sprintf "%s %s" accumulator hash)
""
let style_tag ?key:_ ?children:_ () =
React.createElement "style"
[
String ("data-emotion", "css " ^ get_string_style_hashes ());
Bool ("data-s", true);
DangerouslyInnerHtml (get_stylesheet ());
]
[]
let fontFace ~fontFamily ~src ?fontStyle ?fontWeight ?fontDisplay ?sizeAdjust ()
=
let fontFace =
[|
Kloth.Option.map ~f:Declarations.fontStyle fontStyle;
Kloth.Option.map ~f:Declarations.fontWeight fontWeight;
Kloth.Option.map ~f:Declarations.fontDisplay fontDisplay;
Kloth.Option.map ~f:Declarations.sizeAdjust sizeAdjust;
Some (Declarations.fontFamily fontFamily);
Some
(Rule.Declaration
( "src",
Kloth.Array.map_and_join ~sep:{js|, |js}
~f:Css_types.FontFace.toString src ));
|]
|> Kloth.Array.filter_map ~f:(fun i -> i)
in
global [| Rule.Selector ("@font-face", fontFace) |];
fontFamily