Changed the way shorthand generation works so that the result is closer to the source

README.md

@@ -120,5 +120,3 @@ TODO / bugs
   generating the shortest possible representation of the resulting box model.
 - `border:none` could be `border:0`, or in general any shorthand that has both
   a `style` and `width` property should be transformed from `none` into `0`.
-- `padding: 0 !important` is expanded to 4 directions because of the
-  `!important`

shorthand.ml

@@ -4,10 +4,16 @@
 
 open Types
 open Util
-module SS = Set.Make(String)
 
-let pattern = Str.regexp ("^\\(background\\|border\\|font\\|list-style" ^
-                          "\\|outline\\|padding\\|margin\\)-\\(.*\\)$")
+module KM = Map.Make(struct
+  type t = string * bool
+  let compare a b =
+    match a, b with
+    | (_, false), (_, true)    -> -1
+    | (_, true), (_, false)    -> 1
+    | (base_a, _), (base_b, _) -> String.compare base_a base_b
+end)
+
 
 let order = function
   | "background" -> ["color"; "image"; "repeat"; "attachment"; "position-x";
@@ -20,74 +26,68 @@ let order = function
   | "padding"    -> ["top"; "right"; "bottom"; "left"]
   | _            -> failwith "not a shorthand property"
 
-let rec decls_mem name = function
+let fold_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 fold group base =
+  let group_mem name =
+    let rec mem = function
       | [] -> false
       | (nm, _, _) :: _ when nm = name -> true
-  | _ :: tl -> decls_mem name tl
+      | _ :: tl -> mem tl
+    in
+    mem group
+  in
 
-(* 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 =
-  let rec wrap known must_be_imp = function
+  let group_find name =
+    let rec wrap known = 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
+        (match known with Some value -> value | None -> raise Not_found)
+      | (nm, value, _) :: tl when nm = name ->
+        wrap (Some value) tl
       | _ :: tl ->
-      wrap known must_be_imp tl
+        wrap known tl
+    in
+    wrap None group
   in
-  match wrap None false decls with
-  | None -> raise Not_found
-  | Some value -> value
 
-let fold base decls =
-  let rec filter = function
-    | [] -> []
+  let exists sub = group_mem (base ^ "-" ^ sub) in
+  let find sub = group_find (base ^ "-" ^ sub) in
 
+  let rec lookup = function
+    | [] -> []
     (* `font-size` and `line-height` are slash-separated in `font` *)
-    | "size" :: tl when base = "font" && decls_mem "line-height" decls ->
-      let font_size = decls_find "font-size" decls in
-      let line_height = decls_find "line-height" decls in
-      Nary ("/", [font_size; line_height]) :: filter tl
-
-    | name :: tl when decls_mem (base ^ "-" ^ name) decls ->
-      decls_find (base ^ "-" ^ name) decls :: filter tl
-
-    | _ :: tl -> filter tl
+    | "size" :: tl when base = "font" && group_mem "line-height" ->
+      Nary ("/", [find "size"; group_find "line-height"]) :: lookup tl
+    | name :: tl when exists name -> find name :: lookup tl
+    | _ :: tl -> lookup tl
   in
-  filter (order base)
 
-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
+  match base with
 
-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 ->
-    Some (Concat (fold "font" decls))
+  | "font" when exists "size" && exists "family" ->
+    Some (Concat (lookup (order "font")))
 
   (* `border-style` is required for `border` *)
-  | "border" when decls_mem "border-style" decls ->
-    Some (Concat (fold "border" decls))
+  | "border" when exists "style" ->
+    Some (Concat (lookup (order "border")))
 
-  (* others require at least one property, which is the case when this function
-   * is called *)
+  (* others require at least one property, which is already the case when this
+   * function is called *)
   | ("background" | "list-style" | "outline") as base ->
-    Some (Concat (fold base decls))
+    Some (Concat (lookup (order base)))
 
   (* margin and padding can only be shorthanded when all directions are known,
-   * merging into even shorter shorthands is done by `shorten_box_dims` *)
-  | ("margin" | "padding") as base when
-      let has dir = decls_mem (base ^ "-" ^ dir) decls in
-      has "top" && has "right" && has "bottom" && has "left" ->
-    let get dir = decls_find (base ^ "-" ^ dir) decls in
-    Some (Concat (shorten_box_dims [get "top"; get "right";
-                                    get "bottom"; get "left"]))
+   * merging into even shorter shorthands is done by `fold_box_dims` *)
+  | "margin" | "padding"
+    when exists "top" && exists "right" && exists "bottom" && exists "left" ->
+    let dirs = [find "top"; find "right"; find "bottom"; find "left"] in
+    Some (Concat (fold_box_dims dirs))
 
   | _ -> None
 
@@ -234,45 +234,57 @@ let rec unfold = function
   | hd :: tl ->
     hd :: unfold tl
 
-let make_shorthands decls =
+let pattern = Str.regexp ("^\\(background\\|border\\|font\\|list-style" ^
+                          "\\|outline\\|padding\\|margin\\)-\\(.*\\)$")
+
+let rec make_shorthands decls =
   (* unfold currently existing shorthands into separate properties for merging
    * with override properties that are defined later on *)
   (*let decls = unfold decls in
     XXX: done by main function for correct pruning of duplicate declarations*)
 
-  (* find shorthand names for which properties are present *)
-  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
-      if List.mem sub (order base)
-        then SS.add base (find_props tl)
-        else find_props tl
-    | _ :: tl -> find_props tl
+  let rec extract_groups decl_skipped groups rest =
+    let rec find_in_group name = function
+      | [] -> false
+      | (nm, _, _) :: _ when nm = name -> true
+      | _ :: tl -> find_in_group name 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
+    let should_skip base name imp =
+      try find_in_group name (KM.find (base, imp) groups)
+      with Not_found -> false
+    in
+    let add base imp value =
+      let key = base, imp in
+      let group = try KM.find key groups with Not_found -> [] in
+      KM.add key (value :: group) groups
     in
-  let shorthands = SS.fold replace try_shorthands [] in
-
-  (* filter out the original, partial properties, and append the shorthands *)
-  let keep_prop = function
-    | ("line-height", _, _) ->
-      not (decls_mem "font" shorthands)
-    | (name, _, important) ->
-      important ||
-      not (Str.string_match pattern name 0) ||
+    function
+    | [] -> decl_skipped, groups, rest
+    | (("line-height", _, imp) as hd) :: tl
+      when should_skip "font" "line_height" imp ->
+      extract_groups true groups (hd :: rest) tl
+    | (("line-height", _, imp) as hd) :: tl ->
+      extract_groups decl_skipped (add "font" imp hd) rest tl
+    | ((name, _, imp) as hd) :: tl when Str.string_match pattern name 0 ->
       let base = Str.matched_group 1 name in
       let sub = Str.matched_group 2 name in
-      not (List.mem sub (order base)) || not (decls_mem base shorthands)
+      let skip_this = should_skip base name imp in
+      if not skip_this && List.mem sub (order base)
+        then extract_groups decl_skipped (add base imp hd) rest tl
+        else extract_groups (decl_skipped || skip_this) groups (hd :: rest) tl
+    | hd :: tl -> extract_groups decl_skipped groups (hd :: rest) tl
+  in
+  let decl_skipped, groups, rest = extract_groups false KM.empty [] decls in
+
+  let replace (base, important) group tl =
+    match fold (List.rev group) base with
+    | Some short_value -> (base, short_value, important) :: tl
+    | None -> group @ tl
   in
-  List.filter keep_prop decls @ shorthands
+  let shorthands = KM.fold replace groups [] in
+
+  let decls = List.rev_append rest shorthands in
+  if decl_skipped then make_shorthands decls else decls
 
 let compress =
   Util.transform_stylesheet begin function

util.ml

@@ -254,18 +254,15 @@ let sort_stylesheet =
       in
       let rec cmp a b =
         match split a, split b with
-        | Some (stem_a, tail_a), Some (stem_b, tail_b) ->
-          begin
-            match String.compare stem_a stem_b with
-            | 0 -> cmp tail_a tail_b
-            | n -> n
-          end
-        | Some (stem_a, tail_a), None ->
-          String.compare stem_a b
-        | None, Some (stem_b, tail_b) ->
-          String.compare a stem_b
-        | None, None ->
-          String.compare a b
+        | Some (base_a, sub_a), Some (base_b, sub_b) when base_a = base_b ->
+          cmp sub_a sub_b
+        | Some (base_a, _), Some (base_b, _) ->
+          String.compare base_a base_b
+        | Some (base_a, _), None when base_a = b -> 1
+        | Some (base_a, _), None -> String.compare base_a b
+        | None, Some (base_b, _) when a = base_b -> -1
+        | None, Some (base_b, _) -> String.compare a base_b
+        | None, None -> String.compare a b
       in
       let cmp_decls (a, _, _) (b, _, _) = cmp a b in
       Statement (Ruleset (selectors, List.stable_sort cmp_decls decls))