Implemented CSS @media queries

lexer.mll

@@ -58,8 +58,6 @@ rule token = parse
   | mystring as s       { STRING (strip_quotes s) }
   | badstring           { raise (SyntaxError "bad string") }
 
-  | ident as id         { IDENT id }
-
   | '#' (name as nm)    { HASH nm }
 
   | "@import"           { IMPORT_SYM }
@@ -67,10 +65,16 @@ rule token = parse
   | "@media"            { MEDIA_SYM }
   | "@charset"          { CHARSET_SYM }
 
+  | "only"              { ONLY }
+  | "not"               { NOT }
+  | "and"               { AND }
+
+  | ident as id         { IDENT id }
+
   | '!' (w | comment)* "important"  { IMPORTANT_SYM }
 
   | (num as n) ("em"|"ex"|"px"|"cm"|"mm"|"in"|"pt"|"pc"|"deg"|"rad"|"grad"|
-                "ms"|"s"|"hz"|"khz"|"%"|ident as u)
+                "ms"|"s"|"hz"|"khz"|"%"|"dpi"|"dpcm"|ident as u)
   { UNIT_VALUE (float_of_string n, u) }
   | num as n            { NUMBER (float_of_string n) }
 
@@ -80,6 +84,7 @@ rule token = parse
 
   | (ident as fn) '('   { FUNCTION fn }
 
+  | '('                 { LPAREN }
   | ')'                 { RPAREN }
   | '{'                 { LBRACE }
   | '}'                 { RBRACE }

parser.mly

@@ -1,17 +1,18 @@
 %{
-  (* CSS grammar based on http://www.w3.org/TR/CSS2/grammar.html *)
+  (* CSS grammar based on:
+   * - http://www.w3.org/TR/CSS2/grammar.html
+   * - http://www.w3.org/TR/css3-mediaqueries/
+   *)
   open Lexing
   open Types
 
   let ( |> ) a b = b a
 
-  let filter_none l =
-    let rec filter l = function
-      | [] -> l
-      | None :: tl -> filter l tl
-      | Some hd :: tl -> filter (hd :: l) tl
-    in
-    List.rev (filter [] l)
+  (* TODO: move this to utils *)
+  let rec filter_none = function
+    | [] -> []
+    | None :: tl -> filter_none tl
+    | Some hd :: tl -> hd :: filter_none tl
 
   type term_t = Term of expr | Operator of string
 
@@ -47,8 +48,8 @@
 %token <float> NUMBER
 %token <float * string> UNIT_VALUE
 %token <string> COMBINATOR RELATION STRING IDENT HASH URI FUNCTION
-%token RPAREN LBRACE RBRACE LBRACK RBRACK SEMICOL COLON COMMA DOT PLUS MINUS
-%token SLASH STAR EOF
+%token LPAREN RPAREN LBRACE RBRACE LBRACK RBRACK SEMICOL COLON COMMA DOT PLUS
+%token MINUS SLASH STAR ONLY AND NOT EOF
 
 (* Start symbol *)
 %type <Types.stylesheet> stylesheet
@@ -58,6 +59,7 @@
 
 (* list with arbitrary whitespace between elements and separators *)
 %inline wslist(sep, x): S? l=separated_list(sep, terminated(x, S?))  { l }
+%inline wspreceded(prefix, x): p=preceded(pair(prefix, S?), x) { p }
 
 cd: CDO S? | CDC S? {}
 
@@ -68,7 +70,8 @@ stylesheet:
                  EOF
   { let charset = match charset with None -> [] | Some c -> [c] in
     charset @ imports @ statements }
-%inline statement:
+
+statement:
   | s=ruleset | s=media | s=page
   { s }
 
@@ -77,15 +80,35 @@ charset:
   { Charset name }
 
 import:
-  | IMPORT_SYM S? tgt=string_or_uri media=wslist(COMMA, IDENT) SEMICOL S?
+  | IMPORT_SYM S? tgt=string_or_uri media=wslist(COMMA, media_type) SEMICOL S?
   { Import (tgt, media) }
 %inline string_or_uri:
   | str=STRING  { Strlit str }
   | uri=URI     { Uri uri }
 
 media:
-  | MEDIA_SYM queries=wslist(COMMA, IDENT) LBRACE S? rulesets=ruleset* RBRACE S?
+  | MEDIA_SYM queries=media_query_list LBRACE S? rulesets=ruleset* RBRACE S?
   { Media (queries, rulesets) }
+media_query_list:
+  | S?
+  { [] }
+  | S? hd=media_query tl=wspreceded(COMMA, media_query)*
+  { hd :: tl }
+media_query:
+  | prefix=only_or_not? typ=media_type S? feat=wspreceded(AND, media_expr)*
+  { (prefix, Some typ, feat) }
+  | hd=media_expr tl=wspreceded(AND, media_expr)*
+  { (None, None, (hd :: tl)) }
+%inline only_or_not:
+  | ONLY S?   { "only" }
+  | NOT S?    { "not" }
+%inline media_type:
+  | id=IDENT  { id }
+media_expr:
+  | LPAREN S? feature=media_feature S? value=wspreceded(COLON, expr)? RPAREN S?
+  { (feature, value) }
+%inline media_feature:
+  | id=IDENT  { id }
 
 page:
   | PAGE_SYM S? pseudo=pseudo_page? decls=decls_block
@@ -96,12 +119,12 @@ pseudo_page:
   { pseudo }
 
 %inline decls_block:
-  | LBRACE S? hd=declaration? tl=preceded(pair(SEMICOL, S?), declaration?)* RBRACE S?
+  | LBRACE S? hd=declaration? tl=wspreceded(SEMICOL, declaration?)* RBRACE S?
   { filter_none (hd :: tl) }
 
 ruleset:
   | selectors_hd = selector
-    selectors_tl = preceded(pair(COMMA, S?), selector)*
+    selectors_tl = wspreceded(COMMA, selector)*
     decls        = decls_block
   { Ruleset (selectors_hd :: selectors_tl, decls) }
 

stringify.ml

@@ -4,6 +4,8 @@ let tab = "    "
 
 let indent = Str.global_replace (Str.regexp "^\\(.\\)") (tab ^ "\\1")
 
+let prefix_space = function "" -> "" | s -> " " ^ s
+
 let rec cat sep fn = function
   | [] -> ""
   | [hd] -> fn hd
@@ -14,6 +16,12 @@ let string_of_num n =
     then string_of_int (int_of_float n)
     else string_of_float n
 
+(* TODO: move this to utils *)
+let rec filter_none = function
+  | [] -> []
+  | None :: tl -> filter_none tl
+  | Some hd :: tl -> hd :: filter_none tl
+
 (*
  * Pretty-printing
  *)
@@ -43,6 +51,23 @@ 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
+  | (feature, None) -> "(" ^ feature ^ ")"
+  | (feature, Some value) -> "(" ^ feature ^ ": " ^ string_of_expr value ^ ")"
+
+let string_of_media_query query =
+  let features_str = cat " and " string_of_media_feature in
+  match query with
+  | (None, None, []) -> ""
+  | (None, Some mtype, []) -> mtype
+  | (Some pre, Some mtype, []) -> pre ^ " " ^ mtype
+  | (None, None, features) -> features_str features
+  | (None, Some mtype, features) -> mtype ^ " and " ^ features_str features
+  | (Some pre, Some mtype, features) ->
+    pre ^ " " ^ mtype ^ " and " ^ features_str features
+  | (Some pre, None, _) ->
+    failwith "unexpected media query prefix \"" ^ pre ^ "\""
+
 let block body = " {\n" ^ indent body ^ "\n}"
 
 let rec string_of_statement = function
@@ -50,7 +75,7 @@ let rec string_of_statement = function
     cat ", " string_of_selector selectors ^
     block (cat "\n" string_of_declaration decls)
   | Media (queries, rulesets) ->
-    "@media " ^ String.concat ", " queries ^
+    "@media" ^ prefix_space (cat ", " string_of_media_query queries) ^
     block (cat "\n\n" string_of_statement rulesets)
   | Import (target, []) ->
     "@import " ^ string_of_expr target ^ ";"
@@ -92,12 +117,25 @@ let rec minify_selector = function
   | Combinator (left, com, right) ->
     minify_selector left ^ com ^ minify_selector right
 
+let minify_media_feature = function
+  | (feature, None) -> "(" ^ feature ^ ")"
+  | (feature, Some value) -> "(" ^ feature ^ ":" ^ minify_expr value ^ ")"
+
+let minify_media_query query =
+  let features_str = cat " and " minify_media_feature in
+  match query with
+  | (None, None, features) -> features_str features
+  | (None, Some mtype, features) -> mtype ^ " and " ^ features_str features
+  | (Some pre, Some mtype, features) ->
+    pre ^ " " ^ mtype ^ " and " ^ features_str features
+  | _ -> string_of_media_query query
+
 let rec minify_statement = function
   | Ruleset (selectors, decls) ->
     cat "," minify_selector selectors ^
     "{" ^ (cat ";" minify_declaration decls) ^ "}"
   | Media (queries, rulesets) ->
-    "@media " ^ String.concat "," queries ^
+    "@media" ^ prefix_space (cat "," minify_media_query queries) ^
     "{" ^ (cat "" minify_statement rulesets) ^ "}"
   | Import (target, []) ->
     "@import " ^ string_of_expr target ^ ";"

types.ml

@@ -15,10 +15,13 @@ type selector =
   | Simple of string
   | Combinator of selector * string * selector
 
+type media_expr = string * expr option
+type media_query = string option * string option * media_expr list
+
 type statement =
   | Ruleset of selector list * declaration list
   (* <selectors> { <declarations> } *)
-  | Media of string list * statement list
+  | Media of media_query list * statement list
   (* @media <queries> { <rulesets> } *)
   | Import of expr * string list
   (* @import <target> [<media>]; *)