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