stringify.ml 9.35 KB
Newer Older
1
open Types
2
open Util
3 4 5 6 7

let tab = "    "

let indent = Str.global_replace (Str.regexp "^\\(.\\)") (tab ^ "\\1")

8 9
let prefix_space = function "" -> "" | s -> " " ^ s

10 11 12 13 14
let rec cat sep fn = function
  | [] -> ""
  | [hd] -> fn hd
  | hd :: tl -> fn hd ^ sep ^ cat sep fn tl

15 16 17 18
(*
 * Pretty-printing
 *)

19
let string_of_num n =
20
  if is_int n
21 22 23
    then string_of_int (int_of_float n)
    else string_of_float n

24
let rec string_of_expr = function
25 26 27 28
  | Ident id -> id
  | Strlit str -> "\"" ^ str ^ "\""
  | Uri uri when String.contains uri ')' -> "url(\"" ^ uri ^ "\")"
  | Uri uri -> "url(" ^ uri ^ ")"
29 30 31 32
  | Concat values -> cat " " string_of_expr values
  | Number (n, None) -> string_of_num n
  | Number (n, Some u) -> string_of_num n ^ u
  | Function (name, arg) -> name ^ "(" ^ string_of_expr arg ^ ")"
33
  | Hexcolor hex -> "#" ^ hex
34
  | Unary (op, opnd) -> op ^ string_of_expr opnd
35
  | Nary (",", opnds) -> cat ", " string_of_expr opnds
36
  | Nary (op, opnds) -> cat op string_of_expr opnds
37
  | Key_value (key, op, value) -> key ^ op ^ string_of_expr value
38

39 40 41
let string_of_declaration (name, value, important) =
  let imp = if important then " !important" else "" in
  name ^ ": " ^ string_of_expr value ^ imp ^ ";"
42

43 44 45 46 47 48 49 50 51 52 53 54 55 56
let rec stringify_selector w selector =
  let str = stringify_selector w in
  match selector with
  | No_element   -> ""
  | All_elements -> "*"
  | Element elem -> elem
  | Id (base, id) ->
    str base ^ "#" ^ id
  | Class (base, cls) ->
    str base ^ "." ^ cls
  | Attribute (base, attr, None) ->
    str base ^ "[" ^ attr ^ "]"
  | Attribute (base, attr, Some (op, value)) ->
    str base ^ "[" ^ attr ^ w ^ op ^ w ^ string_of_expr value ^ "]"
57 58 59
  | Pseudo_class (base, cls, None) ->
    str base ^ ":" ^ cls
  | Pseudo_class (base, fn, Some args) ->
60
    str base ^ ":" ^ fn ^ "(" ^ cat ("," ^ w) (stringify_arg w) args ^ ")"
61 62
  | Pseudo_element (base, elem) ->
    str base ^ "::" ^ elem
63
  | Combinator (left, " ", right) ->
64
    str left ^ " " ^ str right
65
  | Combinator (left, com, right) ->
66 67
    str left ^ w ^ com ^ w ^ str right

68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
and stringify_arg w = function
  | Nested_selector s -> stringify_selector w s
  | Nth nth -> stringify_nth w nth

and stringify_nth w = function
  | Even           -> "even"
  | Odd            -> "odd"
  | Formula (0, b) -> string_of_int b
  | Formula (a, b) ->
    begin
      match a with
      | 1  -> "n"
      | -1 -> "-n"
      | a  -> string_of_int a ^ "n"
    end ^ begin
      match b with
      | 0            -> ""
      | b when b < 0 -> w ^ "-" ^ w ^ string_of_int (-b)
      | b            -> w ^ "+" ^ w ^ string_of_int b
    end

89
let string_of_selector = stringify_selector " "
90

91
let string_of_media_expr = function
92 93 94
  | (feature, None) -> "(" ^ feature ^ ")"
  | (feature, Some value) -> "(" ^ feature ^ ": " ^ string_of_expr value ^ ")"

95
let string_of_media_query =
96
  let features_str = cat " and " string_of_media_expr in
97
  function
98 99 100 101 102 103 104 105 106 107
  | (None, None, []) -> ""
  | (None, Some mtype, []) -> mtype
  | (Some pre, Some mtype, []) -> pre ^ " " ^ mtype
  | (None, None, features) -> features_str features
  | (None, Some mtype, features) -> mtype ^ " and " ^ features_str features
  | (Some pre, Some mtype, features) ->
    pre ^ " " ^ mtype ^ " and " ^ features_str features
  | (Some pre, None, _) ->
    failwith "unexpected media query prefix \"" ^ pre ^ "\""

108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
let stringify_condition w c =
  let rec transform =
    let p c = `Parens (transform c) in
    function
    | Not c -> `Not (p c)
    | And c -> `And (List.map p c)
    | Or c -> `Or (List.map p c)
    | Decl (name, value) -> `Decl (name, value)
  in
  let rec str = function
    | `Not c -> "not " ^ str c
    | `And c -> cat " and " str c
    | `Or c -> cat " or " str c
    | `Decl (name, value) -> "(" ^ name ^ ":" ^ w ^ string_of_expr value ^ ")"
    | `Parens (`Decl _ as d) -> str d
    | `Parens c -> "(" ^ str c ^ ")"
  in
  str (transform c)
126

127 128
let string_of_condition = stringify_condition " "

129
let block = function "" -> " {}" | body -> " {\n" ^ indent body ^ "\n}"
130

131 132 133 134 135 136
let string_of_descriptor_declaration (name, value) =
  name ^ ": " ^ string_of_expr value ^ ";"

let string_of_keyframe_ruleset (expr, decls) =
  string_of_expr expr ^ block (cat "\n" string_of_declaration decls)

137 138
let rec string_of_statement = function
  | Ruleset (selectors, decls) ->
139
    cat ", " string_of_selector selectors ^
140 141
    block (cat "\n" string_of_declaration decls)
  | Media (queries, rulesets) ->
142
    "@media" ^ prefix_space (cat ", " string_of_media_query queries) ^
143
    block (cat "\n\n" string_of_statement rulesets)
144 145 146
  | Import (target, []) ->
    "@import " ^ string_of_expr target ^ ";"
  | Import (target, queries) ->
147
    "@import " ^ string_of_expr target ^ " " ^ cat ", " string_of_media_query queries ^ ";"
148 149
  | Charset charset ->
    "@charset \"" ^ charset ^ "\";"
150 151 152 153
  | Page (None, decls) ->
    "@page" ^ block (cat "\n" string_of_declaration decls)
  | Page (Some pseudo, decls) ->
    "@page :" ^ pseudo ^ block (cat "\n" string_of_declaration decls)
154 155
  | Font_face decls ->
    "@font-face" ^ block (cat "\n" string_of_descriptor_declaration decls)
156
  | Namespace (None, uri) ->
157
    "@namespace " ^ string_of_expr uri ^ ";"
158
  | Namespace (Some prefix, uri) ->
159
    "@namespace " ^ prefix ^ " " ^ string_of_expr uri ^ ";"
160 161 162
  | Keyframes (prefix, id, rules) ->
    "@" ^ prefix ^ "keyframes " ^ id ^
    block (cat "\n\n" string_of_keyframe_ruleset rules)
163
  | Supports (condition, statements) ->
164
    "@supports " ^ string_of_condition condition ^
165
    block (cat "\n\n" string_of_statement statements)
166 167
  | Viewport (prefix, decls) ->
    "@" ^ prefix ^ "viewport" ^ block (cat "\n" string_of_declaration decls)
168

169
let string_of_stylesheet = cat "\n\n" string_of_statement
170 171 172 173 174

(*
 * Minified stringification
 *)

175
let minify_num n =
176 177 178
  (* Round numbers to at most 2 decimal digits *)
  let round2 n = floor (100. *. n +. 0.5) /. 100. in

179 180 181
  if float_of_int (int_of_float n) = n then
    string_of_int (int_of_float n)
  else if n < 1.0 && n > -1.0 then
182
    let s = string_of_float (round2 n) in
183 184
    String.sub s 1 (String.length s - 1)
  else
185
    string_of_float (round2 n)
186

187 188 189 190 191 192
let rec minify_expr = function
  | Concat values -> cat " " minify_expr values
  | Function (name, arg) -> name ^ "(" ^ minify_expr arg ^ ")"
  | Unary (op, opnd) -> op ^ minify_expr opnd
  | Nary (",", opnds) -> cat "," minify_expr opnds
  | Nary (op, opnds) -> cat op minify_expr opnds
193 194
  | Number (n, None) -> minify_num n
  | Number (n, Some u) -> minify_num n ^ u
195
  | Key_value (key, op, value) -> key ^ op ^ minify_expr value
196 197 198 199 200 201
  | expr -> string_of_expr expr

let minify_declaration (name, value, important) =
  let imp = if important then "!important" else "" in
  name ^ ":" ^ minify_expr value ^ imp

202
let rec minify_selector = stringify_selector ""
203

204 205 206 207 208
let minify_media_feature = function
  | (feature, None) -> "(" ^ feature ^ ")"
  | (feature, Some value) -> "(" ^ feature ^ ":" ^ minify_expr value ^ ")"

let minify_media_query query =
209
  let features_str = cat "and " minify_media_feature in
210 211 212 213 214 215 216
  match query with
  | (None, None, features) -> features_str features
  | (None, Some mtype, features) -> mtype ^ " and " ^ features_str features
  | (Some pre, Some mtype, features) ->
    pre ^ " " ^ mtype ^ " and " ^ features_str features
  | _ -> string_of_media_query query

217 218 219
let rec minify_statement = function
  | Ruleset (selectors, decls) ->
    cat "," minify_selector selectors ^
220
    "{" ^ cat ";" minify_declaration decls ^ "}"
221
  | Media (queries, rulesets) ->
222
    "@media" ^ prefix_space (cat "," minify_media_query queries) ^
223
    "{" ^ cat "" minify_statement rulesets ^ "}"
224
  | Import (target, []) ->
225
    "@import " ^ minify_expr target ^ ";"
226
  | Import (target, queries) ->
227
    "@import " ^ minify_expr target ^ " " ^
228
    cat "," string_of_media_query queries ^ ";"
229
  | Page (None, decls) ->
230
    "@page{" ^ cat ";" minify_declaration decls ^ "}"
231
  | Page (Some pseudo, decls) ->
232
    "@page :" ^ pseudo ^ "{" ^ cat ";" minify_declaration decls ^ "}"
233 234
  | Font_face decls ->
    let minify_descriptor_declaration (name, value) =
235
      name ^ ":" ^ minify_expr value
236 237
    in
    "@font-face{" ^ cat ";" minify_descriptor_declaration decls ^ "}"
238
  | Keyframes (prefix, id, rules) ->
239 240 241
    let minify_keyframe_ruleset (expr, decls) =
      minify_expr expr ^ "{" ^ cat ";" minify_declaration decls ^ "}"
    in
242 243
    "@" ^ prefix ^ "keyframes " ^ id ^
    "{" ^ cat "" minify_keyframe_ruleset rules ^ "}"
244
  | Supports (condition, statements) ->
245
    "@supports " ^ stringify_condition "" condition ^
246
    "{" ^ cat "" minify_statement statements ^ "}"
247 248
  | Viewport (prefix, decls) ->
    "@" ^ prefix ^ "viewport{" ^ cat ";" minify_declaration decls ^ "}"
249 250 251
  | statement -> string_of_statement statement

let minify_stylesheet = cat "" minify_statement
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

(*
 * Stringify any AST node in a box
 *)

let string_of_box = function
  | Expr expr ->
    string_of_expr expr
  | Declaration declaration ->
    string_of_declaration declaration
  | Selector selector ->
    string_of_selector selector
  | Media_expr media_expr ->
    string_of_media_expr media_expr
  | Media_query media_query ->
    string_of_media_query media_query
  | Descriptor_declaration descriptor_declaration ->
    string_of_descriptor_declaration descriptor_declaration
  | Keyframe_ruleset keyframe_ruleset ->
    string_of_keyframe_ruleset keyframe_ruleset
  | Condition condition ->
    string_of_condition condition
  | Statement statement ->
    string_of_statement statement
  | Stylesheet stylesheet ->
    string_of_stylesheet stylesheet
  | Clear ->
    "<clear>"
  | _ ->
    raise (Invalid_argument "box")