Implemented shorthands and more color names

Makefile

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

color.ml

@@ -13,21 +13,6 @@ let clip = function
   | value -> value
 
 let rec short = function
-  | Ident "black"     -> Hexcolor "000"
-  | Ident "fuchsia"   -> Hexcolor "f0f"
-  | 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
@@ -52,7 +37,10 @@ let rec short = function
   | Function ("rgba", Nary (",", [r; g; b; Number (1., None)])) ->
     short (Function ("rgb", Nary (",", [r; g; b])))
 
-  | v -> v
+  (* TODO: hsl[a](...) *)
+
+  (* transform color names to shorter hex codes and vice-versa *)
+  | v -> Color_names.compress v
 
 let transform = function
   | Expr value -> Expr (short value)

main.ml

@@ -7,6 +7,7 @@ type args = {
   mutable verbose : int;
   mutable echo    : bool;
   mutable pretty  : bool;
+  mutable unfold  : bool;
 }
 
 (* Parse command-line arguments *)
@@ -17,6 +18,7 @@ let parse_args () =
     verbose = 1;
     echo = false;
     pretty = false;
+    unfold = false;
   } in
   let args_spec = [
     ("<file> ...", Arg.Rest (fun _ -> ()),
@@ -34,6 +36,9 @@ let parse_args () =
 
     ("--pretty", Arg.Unit (fun _ -> args.pretty <- true),
                "   Minify, but pretty-print the parsed CSS (for debugging)");
+
+    ("--unfold", Arg.Unit (fun _ -> args.unfold <- true),
+               "   Only unfold shorthands (for debugging)");
   ] in
 
   let usage =
@@ -72,6 +77,9 @@ let handle_args args =
   match args with
   | {echo = true} ->
     write_output (Stringify.string_of_stylesheet stylesheet)
+  | {unfold = true} ->
+    let stylesheet = Shorthand.unfold_stylesheet stylesheet in
+    write_output (Stringify.string_of_stylesheet stylesheet)
   | _ ->
     let stylesheet = Color.compress stylesheet in
     let stylesheet = Shorthand.compress stylesheet in
@@ -102,8 +110,10 @@ let main () =
     with
     | Loc_error (loc, msg) ->
       Util.prerr_loc_msg (args.verbose >= 1) loc ("Error: " ^ msg);
-    | Failure err ->
-      prerr_endline ("Error: " ^ err);
+    | Box_error (box, msg) ->
+      prerr_endline ("Error: " ^ msg ^ ": " ^ Stringify.string_of_box box);
+    | Failure msg ->
+      prerr_endline ("Error: " ^ msg);
   end;
   exit 1
 

shorthand.ml

@@ -9,7 +9,7 @@ module SS = Set.Make(String)
 let pattern = Str.regexp ("^\\(background\\|border\\|font\\|list-style" ^
                           "\\|outline\\|padding\\|margin\\)-\\(.*\\)$")
 
-let subprops = function
+let order = function
   | "background" -> ["color"; "image"; "repeat"; "attachment"; "position"]
   | "border"     -> ["width"; "style"; "color"]
   | "font"       -> ["style"; "variant"; "weight"; "size"; "family"]
@@ -21,15 +21,23 @@ let subprops = function
 
 let rec decls_mem name = function
   | [] -> false
-  | (nm, _, false) :: _ when nm = name -> true
+  | (nm, _, _) :: _ when nm = name -> true
   | _ :: tl -> decls_mem name tl
 
-let rec decls_find name = function
-  | [] -> raise Not_found
-  | (nm, value, false) :: _ when nm = name -> value
-  | _ :: tl -> decls_find name tl
+(* 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 = function
+    | [] -> known
+    | (nm, value, true) :: _ when nm = name -> Some value
+    | (nm, value, false) :: tl when nm = name -> wrap (Some value) tl
+    | _ :: tl -> wrap known tl
+  in
+  match wrap None decls with
+  | None -> raise Not_found
+  | Some value -> value
 
-let order base decls =
+let fold base decls =
   let rec filter = function
     | [] -> []
 
@@ -44,7 +52,7 @@ let order base decls =
 
     | _ :: tl -> filter tl
   in
-  filter (subprops base)
+  filter (order base)
 
 let shorten_box_dims = function
   | [top; right; bottom; left]
@@ -56,16 +64,16 @@ let shorten_box_dims = function
 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 (order "font" decls))
+    Some (Concat (fold "font" decls))
 
   (* `border-style` is required for `border` *)
   | "border" when decls_mem "border-style" decls ->
-    Some (Concat (order "border" decls))
+    Some (Concat (fold "border" decls))
 
   (* others require at least one property, which is the case when this function
    * is called *)
   | ("background" | "list-style" | "outline") as base ->
-    Some (Concat (order base decls))
+    Some (Concat (fold base decls))
 
   (* margin and padding can only be shorthanded when all directions are known,
    * merging into even shorter shorthands is done by `shorten_box_dims` *)
@@ -78,14 +86,161 @@ let shorten decls = function
 
   | _ -> None
 
+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
+
 let 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
+
   (* 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 (subprops base)
+      if List.mem sub (order base)
         then SS.add base (find_props tl)
         else find_props tl
     | _ :: tl -> find_props tl
@@ -102,14 +257,13 @@ let make_shorthands decls =
 
   (* filter out the original, partial properties, and append the shorthands *)
   let keep_prop = function
-    | (_, _, true) -> true
-    | ("line-height", _, false) ->
+    | ("line-height", _, _) ->
       not (decls_mem "font" shorthands)
-    | (name, _, false) ->
+    | (name, _, _) ->
       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)
+      not (List.mem sub (order base)) || not (decls_mem base shorthands)
   in
   List.filter keep_prop decls @ shorthands
 
@@ -119,3 +273,10 @@ let transform = function
   | v -> v
 
 let compress = Util.transform_stylesheet transform
+
+let transform_unfold = function
+  | Statement (Ruleset (selectors, decls)) ->
+    Statement (Ruleset (selectors, unfold decls))
+  | v -> v
+
+let unfold_stylesheet = Util.transform_stylesheet transform_unfold

stringify.ml

@@ -46,12 +46,12 @@ let rec string_of_selector = function
   | Combinator (left, com, right) ->
     string_of_selector left ^ " " ^ com ^ " " ^ string_of_selector right
 
-let string_of_media_feature = function
+let string_of_media_expr = function
   | (feature, None) -> "(" ^ feature ^ ")"
   | (feature, Some value) -> "(" ^ feature ^ ": " ^ string_of_expr value ^ ")"
 
 let string_of_media_query =
-  let features_str = cat " and " string_of_media_feature in
+  let features_str = cat " and " string_of_media_expr in
   function
   | (None, None, []) -> ""
   | (None, Some mtype, []) -> mtype
@@ -82,8 +82,16 @@ let stringify_condition w c =
   in
   str (transform c)
 
+let string_of_condition = stringify_condition " "
+
 let block = function "" -> " {}" | body -> " {\n" ^ indent body ^ "\n}"
 
+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)
+
 let rec string_of_statement = function
   | Ruleset (selectors, decls) ->
     cat ", " string_of_selector selectors ^
@@ -102,22 +110,16 @@ let rec string_of_statement = function
   | Page (Some pseudo, decls) ->
     "@page :" ^ pseudo ^ block (cat "\n" string_of_declaration decls)
   | Font_face decls ->
-    let string_of_descriptor_declaration (name, value) =
-      name ^ ": " ^ string_of_expr value ^ ";"
-    in
     "@font-face" ^ block (cat "\n" string_of_descriptor_declaration decls)
   | Namespace (None, uri) ->
     "@namespace " ^ string_of_expr uri ^ ";"
   | Namespace (Some prefix, uri) ->
     "@namespace " ^ prefix ^ " " ^ string_of_expr uri ^ ";"
   | Keyframes (prefix, id, rules) ->
-    let string_of_keyframe_ruleset (expr, decls) =
-      string_of_expr expr ^ block (cat "\n" string_of_declaration decls)
-    in
     "@" ^ prefix ^ "keyframes " ^ id ^
     block (cat "\n\n" string_of_keyframe_ruleset rules)
   | Supports (condition, statements) ->
-    "@supports " ^ stringify_condition " " condition ^
+    "@supports " ^ string_of_condition condition ^
     block (cat "\n\n" string_of_statement statements)
 
 let string_of_stylesheet = cat "\n\n" string_of_statement
@@ -189,3 +191,33 @@ let rec minify_statement = function
   | statement -> string_of_statement statement
 
 let minify_stylesheet = cat "" minify_statement
+
+(*
+ * 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")

types.ml

@@ -72,3 +72,5 @@ type loc = string * int * int * int * int
 exception Syntax_error of string
 
 exception Loc_error of loc * string
+
+exception Box_error of box * string

util.ml

@@ -215,3 +215,7 @@ let transform_stylesheet f stylesheet =
   and TRAV_ALL(statement, Statement) in
 
   trav_all_statement stylesheet
+
+(* Expression identification *)
+
+let is_color = Color_names.is_color