Started implementing some color optimization

Makefile

@@ -1,6 +1,7 @@
 RESULT    := mincss
-BASENAMES := types util stringify parser lexer parse main
-OFILES    := $(addsuffix .cmx,$(BASENAMES))
+PRE_TGTS  := types
+MODULES   := util stringify parser lexer parse color main
+ALL_NAMES := $(PRE_TGTS) $(MODULES)
 
 OCAMLCFLAGS  := -g
 OCAMLLDFLAGS :=
@@ -10,7 +11,7 @@ OCAMLLEX  := ocamllex
 OCAMLYACC := menhir --infer --explain --dump
 
 .PHONY: all clean
-.PRECIOUS: $(addprefix .cmi,$(BASENAMES))
+.PRECIOUS: $(addprefix .cmi,$(ALL_NAMES))
 
 all: $(RESULT)
 
@@ -26,7 +27,7 @@ all: $(RESULT)
 %.cmx: %.ml
 	ocamlfind ocamlopt -package batteries -c $(OCAMLCFLAGS) -o $@ $(<:.cmi=.ml)
 
-$(RESULT): $(OFILES)
+$(RESULT): $(addsuffix .cmx,$(ALL_NAMES))
 	ocamlopt -o $@ $(OCAMLLDFLAGS) $(OCAMLLDLIBS) $^
 
 # intra-module dependencies
@@ -34,9 +35,8 @@ lexer.cmi: lexer.ml
 parser.cmx: parser.cmi lexer.cmi
 parser.mli: parser.ml
 parse.cmx: lexer.cmi parser.cmx
-main.cmx: parse.cmx util.cmx
-stringify.cmx parser.cmi parser.cmx lexer.cmx util.cmx parse.cmx main.cmx: \
-	types.cmi
+main.cmx: parse.cmx util.cmx color.cmx
+$(addsuffix .cmx,$(MODULES)): $(addsuffix .cmi,$(PRE_TGTS))
 
 clean:
 	rm -f *.cmi *.cmx *.o lexer.ml parser.ml parser.mli parser.conflicts \

color.ml

@@ -0,0 +1,69 @@
+open Types
+
+let hex6 = Str.regexp "\\([0-9a-f]\\)\\1\\([0-9a-f]\\)\\2\\([0-9a-f]\\)\\3"
+
+let is_num = function
+  | Number (n, (None | Some "%")) -> true
+  | _ -> false
+
+let clip = function
+  | Number (n, (None | Some "%")) when n < 0. -> Number (0., Some "%")
+  | Number (n, None) when n > 255.            -> Number (255., None)
+  | Number (n, Some "%") when n > 100.        -> Number (100., Some "%")
+  | value -> value
+
+let rec short = function
+  | Ident "aqua"      -> Hexcolor "0ff"
+  | Ident "black"     -> Hexcolor "000"
+  | Ident "blue"      -> Hexcolor "00f"
+  | Ident "fuchsia"   -> Hexcolor "f0f"
+  | Ident "lime"      -> Hexcolor "0f0"
+  | Ident "white"     -> Hexcolor "fff"
+  | Ident "yellow"    -> Hexcolor "ff0"
+  | Hexcolor "808080" -> Ident "gray"
+  | Hexcolor "008000" -> Ident "green"
+  | Hexcolor "800000" -> Ident "maroon"
+  | Hexcolor "000080" -> Ident "navy"
+  | Hexcolor "8080000"-> Ident "olive"
+  | Hexcolor "800080" -> Ident "purple"
+  | Hexcolor "ff0000"
+  | Hexcolor "f00"    -> Ident "red"
+  | Hexcolor "c0c0c0" -> Ident "silver"
+  | Hexcolor "008080" -> Ident "teal"
+
+  (* #aabbcc -> #abc *)
+  | Hexcolor h when Str.string_match hex6 h 0 ->
+    let gr n = Str.matched_group n h in
+    Hexcolor (gr 1 ^ gr 2 ^ gr 3)
+
+  (* rgb(r,g,b) -> #rrggbb *)
+  | Function ("rgb", Nary (",", [r; g; b]))
+    when is_num r & is_num g & is_num b ->
+    let i c =
+      match clip c with
+      | Number (n, None) -> int_of_float n
+      | Number (n, Some "%") -> int_of_float (n *. 2.55 +. 0.5)
+      | _ -> assert false
+    in
+    short (Hexcolor (Printf.sprintf "%02x%02x%02x" (i r) (i g) (i b)))
+
+  (* clip rgb values, e.g. rgb(-1,256,0) -> rgb(0,255,0) *)
+  | Function ("rgb", Nary (",", [r; g; b])) ->
+    Function ("rgb", Nary (",", [clip r; clip g; clip b]))
+
+  | c -> c
+
+let rec compress_props = function
+  | [] -> []
+
+  | ("color", c, i) :: tl ->
+    ("color", short c, i) :: compress_props tl
+
+  | hd :: tl -> hd :: compress_props tl
+
+let rec compress = function
+  | [] -> []
+  | Ruleset (selectors, properties) :: tl ->
+    Ruleset (selectors, compress_props properties) :: compress tl
+  | hd :: tl ->
+    hd :: compress tl

main.ml

@@ -67,6 +67,7 @@ let handle_args args =
   | {echo = true} ->
     write_output (Stringify.string_of_stylesheet stylesheet)
   | _ ->
+    let stylesheet = Color.compress stylesheet in
     let output = Stringify.minify_stylesheet stylesheet in
     write_output output;
     if args.verbose >= 2 then begin

parser.mly

@@ -37,6 +37,13 @@
     match terms |> transform_ops |> flatten_nary with
     | [hd] -> hd
     | l -> Concat l
+
+  (* TODO: move this to a normalization stage, because the syntax should be
+   * preserved during parsing (e.g. for -echo command) *)
+  let unary_number = function
+    | Unary ("-", Number (n, u)) -> Number (-.n, u)
+    | Unary ("+", (Number _ as n)) -> n
+    | value -> value
 %}
 
 (* Tokens *)
@@ -260,7 +267,7 @@ expr:
   | COMMA S*            { "," }
 
 term:
-  | op=unary_operator v=numval S*   { Unary (op, v) }
+  | op=unary_operator v=numval S*   { unary_number (Unary (op, v)) }
   | v=numval S*                     { v }
   | str=STRING S*                   { Strlit str }
   | id=IDENT S*                     { Ident id }