diff --git a/Makefile b/Makefile
index e518cef44ea27e1bdf471c9963cf21d390dbaf92..404517de9bad6f0e3e512c4283ccb26bbea00de0 100644
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,6 @@
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))
diff --git a/color.ml b/color.ml
index b1a1445be2ce7a8c58421c87eadfe2289b3782e7..836dad833fdaab68367cec6c58fc54cc0a4b281d 100644
--- a/color.ml
+++ b/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)
diff --git a/main.ml b/main.ml
index 7138771d18ea8ad51e4a2f138914618bdda99b1c..2cf9506de2fa68d61f97ee8b734290623828c5ad 100644
--- a/main.ml
+++ b/main.ml
@@ -5,8 +5,9 @@ type args = {
mutable infiles : string list;
mutable outfile : string option;
mutable verbose : int;
- mutable echo : bool;
- mutable pretty : bool;
+ 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
diff --git a/shorthand.ml b/shorthand.ml
index c8234d82218b64b577cec88246e0b750027d7bfb..d27d62e44e82a96c1832cc6323006a48f773f657 100644
--- a/shorthand.ml
+++ b/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
diff --git a/stringify.ml b/stringify.ml
index 53e224036dbc963ee072da450e1616342ec24c38..ad89086a00bbd13c269852945e7192c7e3e3c199 100644
--- a/stringify.ml
+++ b/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")
diff --git a/types.ml b/types.ml
index d50b4844a09dd7d00094343c65293eb95084c74d..fd2c87a0330ee9e3132cf3650543e213f3b04bac 100644
--- a/types.ml
+++ b/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
diff --git a/util.ml b/util.ml
index 4b81a810885950cb51c52e7dafc3910e2547a8b3..c4cd3e8a83e44018f2f2eb120340a6d2e06ab6b6 100644
--- a/util.ml
+++ b/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