shorthand.ml 10.5 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11
(* CSS shorthand creation based on:
 * - http://www.cssshorthand.com/
 *)

open Types
open Util
module SS = Set.Make(String)

let pattern = Str.regexp ("^\\(background\\|border\\|font\\|list-style" ^
                          "\\|outline\\|padding\\|margin\\)-\\(.*\\)$")

12
let order = function
13 14
  | "background" -> ["color"; "image"; "repeat"; "attachment"; "position-x";
                     "position-y"]
15 16
  | "border"     -> ["width"; "style"; "color"]
  | "font"       -> ["style"; "variant"; "weight"; "size"; "family"]
17
  | "list-style" -> ["type"; "position"; "image"]
18 19 20 21
  | "outline"    -> ["color"; "style"; "width"]
  | "margin"
  | "padding"    -> ["top"; "right"; "bottom"; "left"]
  | _            -> failwith "not a shorthand property"
22 23 24

let rec decls_mem name = function
  | [] -> false
25
  | (nm, _, _) :: _ when nm = name -> true
26 27
  | _ :: tl -> decls_mem name tl

28 29 30
(* find the value of the last declaration of some property (since the earlier
 * values are overridden), unless an earlier !important value was found *)
let decls_find name decls =
31 32 33 34 35 36 37 38 39
  let rec wrap known must_be_imp = function
    | [] ->
      known
    | (nm, value, false) :: tl when nm = name && not must_be_imp ->
      wrap (Some value) false tl
    | (nm, value, true) :: tl when nm = name ->
      wrap (Some value) true tl
    | _ :: tl ->
      wrap known must_be_imp tl
40
  in
41
  match wrap None false decls with
42 43
  | None -> raise Not_found
  | Some value -> value
44

45
let fold base decls =
46 47
  let rec filter = function
    | [] -> []
48 49

    (* `font-size` and `line-height` are slash-separated in `font` *)
50
    | "size" :: tl when base = "font" && decls_mem "line-height" decls ->
Taddeüs Kroes's avatar
Taddeüs Kroes committed
51 52
      let font_size = decls_find "font-size" decls in
      let line_height = decls_find "line-height" decls in
53
      Nary ("/", [font_size; line_height]) :: filter tl
54

55
    | name :: tl when decls_mem (base ^ "-" ^ name) decls ->
Taddeüs Kroes's avatar
Taddeüs Kroes committed
56
      decls_find (base ^ "-" ^ name) decls :: filter tl
57

58 59
    | _ :: tl -> filter tl
  in
60
  filter (order base)
61

62 63 64 65 66 67 68 69 70 71
let shorten_box_dims = function
  | [top; right; bottom; left]
    when top = bottom && right = left && top = right -> [top]
  | [top; right; bottom; left] when top = bottom && right = left -> [top; right]
  | [top; right; bottom; left] when right = left -> [top; right; bottom]
  | dims -> dims

let shorten decls = function
  (* `font-size` and `font-family` are required for `font` *)
  | "font" when decls_mem "font-size" decls && decls_mem "font-family" decls ->
72
    Some (Concat (fold "font" decls))
73 74

  (* `border-style` is required for `border` *)
75
  | "border" when decls_mem "border-style" decls ->
76
    Some (Concat (fold "border" decls))
77 78 79

  (* others require at least one property, which is the case when this function
   * is called *)
80
  | ("background" | "list-style" | "outline") as base ->
81
    Some (Concat (fold base decls))
82 83 84

  (* margin and padding can only be shorthanded when all directions are known,
   * merging into even shorter shorthands is done by `shorten_box_dims` *)
85 86 87
  | ("margin" | "padding") as base when
      let has dir = decls_mem (base ^ "-" ^ dir) decls in
      has "top" && has "right" && has "bottom" && has "left" ->
Taddeüs Kroes's avatar
Taddeüs Kroes committed
88
    let get dir = decls_find (base ^ "-" ^ dir) decls in
89 90 91
    Some (Concat (shorten_box_dims [get "top"; get "right";
                                    get "bottom"; get "left"]))

92 93
  | _ -> None

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
let rec list_from i = function
  | [] when i > 0 -> raise (Invalid_argument "l")
  | []            -> []  (* make the compiler happy *)
  | l when i = 0  -> l
  | _ :: tl       -> list_from (i - 1) tl

let is_width = function
  | Ident ("thin" | "thick" | "medium")
  | Number _ -> true
  | _ -> false

let rec unfold = function
  | [] -> []

  (* do not unfold "<shorthand>: inherit;" *)
  | (("background" | "border" | "font" | "list-style" | "outline" | "margin" |
      "padding"), Ident "inherit", _) as orig :: tl ->
    orig :: unfold tl

  (* background: [color] [image] [repeat] [attachment] [position] *)
  | ("background", Concat values, imp) :: tl ->
    let make sub value = ("background-" ^ sub, value, imp) in
    let id_color = function
      | [] -> []
      | [color] when Color_names.is_color color -> [make "color" color]
      | tl -> raise (Box_error (Expr (Concat tl), "invalid background shortcut"))
      (*| _ -> failwith "invalid background shortcut"*)
    in
    let id_repeat = function
      | repeat :: (Uri _ as image) :: tl ->
        make "repeat" repeat :: make "image" image :: id_color tl
      | Uri _ as image :: tl ->
        make "image" image :: id_color tl
      | tl -> id_color tl
    in
    let id_attachment = function
      | Ident _ as attachment :: (Ident _ as repeat) :: tl ->
        make "attachment" attachment :: make "repeat" repeat :: id_repeat tl
      | Ident ("scroll" | "fixed") as attachment :: (Uri url :: _ as tl) ->
        make "attachment" attachment :: id_repeat tl
      | (_ :: Uri _ :: _) as tl
      | tl -> id_repeat tl
    in
    let id_pos = function
      | Number _ as posy :: (Number _ as posx) :: tl
      | (Ident ("top" | "center" | "bottom") as posy) ::
        (Ident ("left" | "center" | "right") as posx) :: tl ->
        make "position-y" posy :: make "position-x" posx :: id_attachment tl
      | tl -> id_attachment tl
    in
    List.rev (id_pos (List.rev values)) @ unfold tl
  | ("background", (Uri _ as image), imp) :: tl ->
    ("background-image", image, imp) :: unfold tl
  | ("background", color, imp) :: tl ->
    ("background-color", color, imp) :: unfold tl

  (* border: [width] style [color] *)
  | ("border", Concat [Ident _ as style], imp) :: tl ->
    ("border-style", style, imp) :: unfold tl
  | ("border", Concat [width; Ident _ as style; color], imp) :: tl ->
    ("border-width", width, imp) ::
    ("border-style", style, imp) ::
    ("border-color", color, imp) :: unfold tl
  | ("border", Concat [Number _ as width; Ident _ as style], imp) :: tl ->
    ("border-width", width, imp) ::
    ("border-style", style, imp) :: unfold tl
  | ("border", Concat [Ident _ as style; color], imp) :: tl ->
    ("border-style", style, imp) ::
    ("border-color", color, imp) :: unfold tl

  (* font: [style] [variant] [weight] size[/line-height] family *)
  | ("font", Concat values, imp) as orig :: tl ->
    let replacement =
      let make sub value = ("font-" ^ sub, value, imp) in
      let identify options =
        let return sub = assert (List.mem sub options); sub in
        function
        | Ident "normal" -> List.hd options
        | Ident ("italic" | "oblique") -> return "style"
        | Ident "small-caps" -> return "variant"
        | _ -> return "weight"
      in
      match values with
      | [size; family] ->
        [make "size" size; make "family" family]
      | [first; size; family] ->
        [make (identify ["weight"; "variant"; "style"] first) first;
         make "size" size; make "family" family]
      | [first; second; size; family] ->
        [make (identify ["variant"; "style"] first) first;
         make (identify ["weight"; "variant"] second) second;
         make "size" size; make "family" family]
      | [style; variant; weight; size; family] ->
        [make "style" style; make "variant" variant; make "weight" weight;
         make "size" size; make "family" family]
      | _ -> [orig]
    in
    let rec split_size = function
      | [] -> []
      | ("font-size", Nary ("/", [size; line_height]), _) :: tl ->
        ("font-size", size, imp) ::
        ("line-height", line_height, imp) :: tl
      | hd :: tl -> hd :: split_size tl
    in
    split_size replacement @ unfold tl

  (* list-style: [type] [position] [image] *)
  | ("list-style", Concat [ltype; pos; image], imp) :: tl ->
    ("list-style-type", ltype, imp) ::
    ("list-style-position", pos, imp) ::
    ("list-style-image", image, imp) :: unfold tl
  | ("list-style", Concat [Ident _ as pos; Uri _ as image], imp) :: tl ->
    ("list-style-position", pos, imp) ::
    ("list-style-image", image, imp) :: unfold tl
  | ("list-style", Concat [ltype; Ident _ as pos], imp) :: tl ->
    ("list-style-type", ltype, imp) ::
    ("list-style-position", pos, imp) :: unfold tl

  (* margin: top right bottom left
   *       | top right-left bottom
   *       | top-bottom right-left
   *       | top right bottom left
   *       | all
   *)
  | (("margin"| "padding") as base, value, imp) :: tl ->
    let (top, right, bottom, left) =
      match value with
      | Concat [top; right; bottom; left] ->
        (top, right, bottom, left)
      | Concat [top; right; bottom] ->
        (top, right, bottom, right)
      | Concat [top; right] ->
        (top, right, top, right)
      | _ ->
        (value, value, value, value)
    in
    let make dir value = (base ^ "-" ^ dir, value, imp) in
    make "top" top :: make "right" right :: make "bottom" bottom ::
    make "left" left :: unfold tl

  | hd :: tl ->
    hd :: unfold tl

237
let make_shorthands decls =
238 239
  (* unfold currently existing shorthands into separate properties for merging
   * with override properties that are defined later on *)
240 241
  (*let decls = unfold decls in
    XXX: done by main function for correct pruning of duplicate declarations*)
242

Taddeüs Kroes's avatar
Taddeüs Kroes committed
243
  (* find shorthand names for which properties are present *)
244 245 246 247 248
  let rec find_props = function
    | [] -> SS.empty
    | (name, value, false) :: tl when Str.string_match pattern name 0 ->
      let base = Str.matched_group 1 name in
      let sub = Str.matched_group 2 name in
249
      if List.mem sub (order base)
250 251 252 253 254 255 256 257 258 259 260 261 262 263
        then SS.add base (find_props tl)
        else find_props tl
    | _ :: tl -> find_props tl
  in
  let try_shorthands = find_props decls in

  (* try to generate shorthands for the matched base properties *)
  let rec replace base tl =
    match shorten decls base with
    | None -> tl
    | Some short_value -> (base, short_value, false) :: tl
  in
  let shorthands = SS.fold replace try_shorthands [] in

264
  (* filter out the original, partial properties, and append the shorthands *)
265
  let keep_prop = function
266
    | ("line-height", _, _) ->
267
      not (decls_mem "font" shorthands)
268 269
    | (name, _, imp) ->
      imp ||
270 271 272
      not (Str.string_match pattern name 0) ||
      let base = Str.matched_group 1 name in
      let sub = Str.matched_group 2 name in
273
      not (List.mem sub (order base)) || not (decls_mem base shorthands)
274
  in
275
  List.filter keep_prop decls @ shorthands
276 277 278 279 280 281 282

let transform = function
  | Statement (Ruleset (selectors, decls)) ->
    Statement (Ruleset (selectors, make_shorthands decls))
  | v -> v

let compress = Util.transform_stylesheet transform
283 284 285 286 287 288 289

let transform_unfold = function
  | Statement (Ruleset (selectors, decls)) ->
    Statement (Ruleset (selectors, unfold decls))
  | v -> v

let unfold_stylesheet = Util.transform_stylesheet transform_unfold