Implemented shorthand compression

Makefile

@@ -1,6 +1,6 @@
 RESULT    := mincss
 PRE_TGTS  := types
-MODULES   := util stringify parser lexer parse color main
+MODULES   := util stringify parser lexer parse color shorthand main
 ALL_NAMES := $(PRE_TGTS) $(MODULES)
 
 OCAMLCFLAGS  := -g
@@ -35,8 +35,9 @@ lexer.cmi: lexer.ml
 parser.cmx: parser.cmi lexer.cmx
 parser.mli: parser.ml
 parse.cmx: lexer.cmi parser.cmx
-main.cmx: parse.cmx util.cmx color.cmx
+main.cmx: parse.cmx util.cmx color.cmx shorthand.cmx
 util.cmx: OCAMLCFLAGS += -pp cpp
+stringify.cmx parser.cmx color.cmx shorthand.cmx: util.cmi
 $(addsuffix .cmx,$(MODULES)): $(addsuffix .cmi,$(PRE_TGTS))
 
 clean:

main.ml

@@ -6,6 +6,7 @@ type args = {
   mutable outfile : string option;
   mutable verbose : int;
   mutable echo : bool;
+  mutable pretty : bool;
 }
 
 (* Parse command-line arguments *)
@@ -15,6 +16,7 @@ let parse_args () =
     outfile = None;
     verbose = 1;
     echo = false;
+    pretty = false;
   } in
   let args_spec = [
     ("<file> ...", Arg.Rest (fun _ -> ()),
@@ -29,10 +31,14 @@ let parse_args () =
 
     ("--echo", Arg.Unit (fun _ -> args.echo <- true),
              "     Don't minify, just pretty-print the parsed CSS");
+
+    ("--pretty", Arg.Unit (fun _ -> args.pretty <- true),
+               "   Minify, but pretty-print the parsed CSS (for debugging)");
   ] in
 
   let usage =
-    "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-v <verbosity>] [<file> ...]"
+    "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-v <verbosity>] [<file> ...] " ^
+    "[--pretty | --echo]"
   in
 
   Arg.parse args_spec (fun f -> args.infiles <- args.infiles @ [f]) usage;
@@ -68,8 +74,17 @@ let handle_args args =
     write_output (Stringify.string_of_stylesheet stylesheet)
   | _ ->
     let stylesheet = Color.compress stylesheet in
-    let output = Stringify.minify_stylesheet stylesheet in
+    let stylesheet = Shorthand.compress stylesheet in
+
+    let stringify =
+      if args.pretty
+        then Stringify.string_of_stylesheet
+        else Stringify.minify_stylesheet
+    in
+    let output = stringify stylesheet in
+
     write_output output;
+
     if args.verbose >= 2 then begin
       let il = String.length input in
       let ol = String.length output in

shorthand.ml

@@ -0,0 +1,100 @@
+(* 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\\)-\\(.*\\)$")
+
+let subprops = function
+  | "background" -> ["color"; "image"; "repeat"; "attachment"; "position"]
+  | "border" -> ["width"; "style"; "color"]
+  | "font" -> ["style"; "variant"; "weight"; "size"; "family"]
+  | "list-style" -> ["type"; "position"; "image"]
+  | "outline" -> ["color"; "style"; "width"]
+  | "margin" | "padding" -> ["top"; "right"; "bottom"; "left"]
+  | _ -> failwith "not a shorthand property"
+
+let rec decls_mem name = function
+  | [] -> false
+  | (nm, _, false) :: _ when nm = name -> true
+  | _ :: tl -> decls_mem name tl
+
+let rec prop_value name = function
+  | [] -> raise Not_found
+  | (nm, value, false) :: _ when nm = name -> value
+  | _ :: tl -> prop_value name tl
+
+let order base decls =
+  let rec filter = function
+    | [] -> []
+    | "size" :: tl when base = "font" && decls_mem "line-height" decls ->
+      let font_size = prop_value "font-size" decls in
+      let line_height = prop_value "line-height" decls in
+      Nary ("/", [font_size; line_height]) :: filter tl
+    | name :: tl when decls_mem (base ^ "-" ^ name) decls ->
+      prop_value (base ^ "-" ^ name) decls :: filter tl
+    | _ :: tl -> filter tl
+  in
+  filter (subprops base)
+
+let rec shorten decls = function
+  | "font" when not (decls_mem "font-size" decls) ->
+    shorten (("font-size", Ident "medium", false) :: decls) "font"
+  | "font" when decls_mem "font-family" decls ->
+    Some (Concat (order "font" decls))
+  | "border" when decls_mem "border-style" decls ->
+    Some (Concat (order "border" decls))
+  | ("background" | "list-style" | "outline") as base ->
+    Some (Concat (order base decls))
+  | ("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 = prop_value (base ^ "-" ^ dir) decls in
+    Some (Concat [get "top"; get "right"; get "bottom"; get "left"])
+  | _ -> None
+
+let make_shorthands decls =
+  (* find basenames 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 (subprops base)
+        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
+
+  (* filter out the original, partial properties, and prepend the shorthands *)
+  let keep_prop = function
+    | (_, _, true) -> true
+    | ("line-height", _, false) ->
+      not (decls_mem "font" shorthands)
+    | (name, _, false) ->
+      not (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 (subprops base)) || not (decls_mem base shorthands)
+  in
+  shorthands @ List.filter keep_prop decls
+
+let transform = function
+  | Statement (Ruleset (selectors, decls)) ->
+    Statement (Ruleset (selectors, make_shorthands decls))
+  | v -> v
+
+let compress = Util.transform_stylesheet transform

util.ml

@@ -7,6 +7,10 @@ let (|>) a b = b a
 
 (** List utilities *)
 
+let is_none = function None -> true | Some _ -> false
+let is_some = function None -> false | Some _ -> true
+let some_val = function None -> failwith "no value" | Some v -> v
+
 let rec filter_none = function
   | [] -> []
   | None :: tl -> filter_none tl