Implemented a generic traversal function

Makefile

@@ -36,6 +36,7 @@ parser.cmx: parser.cmi lexer.cmi
 parser.mli: parser.ml
 parse.cmx: lexer.cmi parser.cmx
 main.cmx: parse.cmx util.cmx color.cmx
+util.cmx: OCAMLCFLAGS += -pp cpp
 $(addsuffix .cmx,$(MODULES)): $(addsuffix .cmi,$(PRE_TGTS))
 
 clean:

color.ml

@@ -53,17 +53,9 @@ let rec short = function
 
   | c -> c
 
-let rec compress_props = function
-  | [] -> []
+let transform = function
+  | Declaration ("color", color, imp) ->
+    Declaration ("color", short color, imp)
+  | v -> v
 
-  | ("color", c, i) :: tl ->
-    ("color", short c, i) :: compress_props tl
-
-  | hd :: tl -> hd :: compress_props tl
-
-let rec compress = function
-  | [] -> []
-  | Ruleset (selectors, properties) :: tl ->
-    Ruleset (selectors, compress_props properties) :: compress tl
-  | hd :: tl ->
-    hd :: compress tl
+let compress = Util.transform_stylesheet transform

parser.mly

@@ -11,14 +11,7 @@
   open Types
   open Util
 
-  type term_t = Term of expr | Operator of string
-
-  let rec transform_value f = function
-    | Concat terms -> Concat (List.map (transform_value f) terms)
-    | Function (name, arg) -> Function (name, transform_value f arg)
-    | Unary (op, term) -> Unary (op, transform_value f term)
-    | Nary (op, terms) -> Nary (op, List.map (transform_value f) terms)
-    | value -> f value
+  type term = Term of expr | Operator of string
 
   let concat_terms terms =
     let rec transform_ops = function

stringify.ml

@@ -50,9 +50,9 @@ let string_of_media_feature = function
   | (feature, None) -> "(" ^ feature ^ ")"
   | (feature, Some value) -> "(" ^ feature ^ ": " ^ string_of_expr value ^ ")"
 
-let string_of_media_query query =
+let string_of_media_query =
   let features_str = cat " and " string_of_media_feature in
-  match query with
+  function
   | (None, None, []) -> ""
   | (None, Some mtype, []) -> mtype
   | (Some pre, Some mtype, []) -> pre ^ " " ^ mtype

types.ml

@@ -53,6 +53,20 @@ type statement =
 
 type stylesheet = statement list
 
+type traversal_box =
+  | Expr of expr
+  | Declaration of declaration
+  | Selector of selector
+  | Media_expr of media_expr
+  | Media_query of media_query
+  | Descriptor_declaration of descriptor_declaration
+  | Keyframe_ruleset of keyframe_ruleset
+  | Supports_declaration of supports_declaration
+  | Condition of condition
+  | Statement of statement
+  | Stylesheet of stylesheet
+  | Clear
+
 type loc = string * int * int * int * int
 
 exception Syntax_error of string

util.ml

@@ -94,3 +94,118 @@ let prerr_loc_msg verbose loc msg =
         try prerr_loc loc
         with Sys_error _ -> ()
   end
+
+#define TRAV_ALL(id, constructor) \
+  trav_all_##id l = \
+    let rec filter_clear = function \
+      | [] -> [] \
+      | Clear :: tl -> filter_clear tl \
+      | constructor hd :: tl -> hd :: filter_clear tl \
+      | _ -> failwith ("expected " ^ #constructor ^ " or Clear") \
+    in \
+    filter_clear (List.map trav_##id l)
+
+#define EXPECT(id, constructor) \
+  expect_##id value = \
+    match trav_##id value with \
+    | constructor decl -> decl \
+    | _ -> failwith ("expected " ^ #constructor)
+
+let transform_stylesheet (f : traversal_box -> traversal_box) stylesheet =
+  let rec trav_expr = function
+    | Concat terms -> f (Expr (Concat (trav_all_expr terms)))
+    | Function (name, arg) -> f (Expr (Function (name, expect_expr arg)))
+    | Unary (op, opnd) -> f (Expr (Unary (op, expect_expr opnd)))
+    | Nary (op, opnds) -> f (Expr (Nary (op, trav_all_expr opnds)))
+    | value -> f (Expr value)
+  and EXPECT(expr, Expr)
+  and TRAV_ALL(expr, Expr) in
+
+  let trav_declaration (name, value, important) =
+    f (Declaration (name, expect_expr value, important))
+  in
+  let TRAV_ALL(declaration, Declaration) in
+
+  let trav_selector = function
+    | Simple _ as s -> f (Selector s)
+    | Combinator (left, com, right) ->
+      f (Selector (Combinator (left, com, right)))
+  in
+  let TRAV_ALL(selector, Selector) in
+
+  let trav_media_expr = function
+    | (_, None) as value ->
+      f (Media_expr value)
+    | (name, Some value) ->
+      let value =
+        match trav_expr value with
+        | Expr value -> Some value
+        | Clear -> None
+        | _ -> failwith "expected Expr or Clear"
+      in
+      f (Media_expr (name, value))
+  in
+  let TRAV_ALL(media_expr, Media_expr) in
+
+  let trav_media_query (prefix, mtype, queries) =
+    f (Media_query (prefix, mtype, trav_all_media_expr queries))
+  in
+  let TRAV_ALL(media_query, Media_query) in
+
+  let trav_descriptor_declaration (name, value) =
+    f (Descriptor_declaration (name, expect_expr value))
+  in
+  let TRAV_ALL(descriptor_declaration, Descriptor_declaration) in
+
+  let trav_keyframe_ruleset (selector, decls) =
+    f (Keyframe_ruleset (expect_expr selector, trav_all_declaration decls))
+  in
+  let TRAV_ALL(keyframe_ruleset, Keyframe_ruleset) in
+
+  let trav_supports_declaration (name, value) =
+    f (Supports_declaration (name, expect_expr value))
+  in
+  let EXPECT(supports_declaration, Supports_declaration) in
+
+  let rec trav_condition = function
+    | Not c -> f (Condition (Not (expect_condition c)))
+    | And l -> f (Condition (And (trav_all_condition l)))
+    | Or l -> f (Condition (Or (trav_all_condition l)))
+    | Decl d -> f (Condition (Decl (expect_supports_declaration d)))
+  and EXPECT(condition, Condition)
+  and TRAV_ALL(condition, Condition) in
+
+  let rec trav_statement = function
+    | Ruleset (selectors, decls) ->
+      let selectors = trav_all_selector selectors in
+      let decls = trav_all_declaration decls in
+      f (Statement (Ruleset (selectors, decls)))
+    | Media (queries, rulesets) ->
+      let queries = trav_all_media_query queries in
+      let rulesets = trav_all_statement rulesets in
+      f (Statement (Media (queries, rulesets)))
+    | Import (target, queries) ->
+      let target = expect_expr target in
+      let queries = trav_all_media_query queries in
+      f (Statement (Import (target, queries)))
+    | Page (pseudo, decls) ->
+      let decls = trav_all_declaration decls in
+      f (Statement (Page (pseudo, decls)))
+    | Font_face decls ->
+      let decls = trav_all_descriptor_declaration decls in
+      f (Statement (Font_face decls))
+    | Namespace (prefix, uri) ->
+      let uri = expect_expr uri in
+      f (Statement (Namespace (prefix, uri)))
+    | Keyframes (id, rules) ->
+      let rules = trav_all_keyframe_ruleset rules in
+      f (Statement (Keyframes (id, rules)))
+    | Supports (condition, statements) ->
+      let condition = expect_condition condition in
+      let statements = trav_all_statement statements in
+      f (Statement (Supports (condition, statements)))
+    | s ->
+      f (Statement s)
+  and TRAV_ALL(statement, Statement) in
+
+  trav_all_statement stylesheet