Commit 34391515 authored by Taddeüs Kroes's avatar Taddeüs Kroes

Implemented shorthands and more color names

parent 515b05a9
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))
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......@@ -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")
......@@ -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
......@@ -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
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment