util.ml 7.86 KB
Newer Older
1 2 3
open Printf
open Types

4 5 6 7 8 9
(** Operators *)

let (|>) a b = b a

(** List utilities *)

10 11 12 13
let is_none = function None -> true | Some _ -> false
let is_some = function None -> false | Some _ -> true
let some_val = function None -> failwith "no value" | Some v -> v

14 15 16 17 18 19 20
let rec filter_none = function
  | [] -> []
  | None :: tl -> filter_none tl
  | Some hd :: tl -> hd :: filter_none tl

(** Reading input from file/stdin *)

21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
let input_all ic =
  let n = in_channel_length ic in
  let buf = String.create n in
  really_input ic buf 0 n;
  close_in ic;
  buf

let input_buffered ic chunksize =
  let rec read_all buf bufsize pos =
    match input ic buf pos (bufsize - pos) with
    | 0 -> (close_in ic; buf)
    | nread when nread = bufsize - pos ->
      let bufsize = bufsize + chunksize in
      let pos = pos + nread in
      read_all (buf ^ String.create chunksize) bufsize pos
    | nread ->
      read_all buf bufsize (pos + nread)
  in
  read_all (String.create chunksize) chunksize 0

41
(** Error printing *)
42 43 44 45 46 47 48 49 50

let noloc = ("", 0, 0, 0, 0)

let tabwidth = 4

let count_tabs str upto =
  let rec count n = function
    | 0 -> n
    | i -> count (if String.get str (i - 1) = '\t' then n + 1 else n) (i - 1)
51 52
  in
  count 0 upto
53 54 55

let rec repeat s n = if n < 1 then "" else s ^ (repeat s (n - 1))

56
let retab str = Str.global_replace (Str.regexp "\t") (repeat " " tabwidth) str
57 58 59 60 61 62 63

let indent n = repeat (repeat " " (tabwidth - 1)) n

let prerr_loc (fname, ystart, yend, xstart, xend) =
  let file = open_in fname in

  (* skip lines until the first matched line *)
64
  for i = 1 to ystart - 1 do ignore (input_line file) done;
65 66 67 68 69 70 71 72 73 74 75 76 77 78

  (* for each line in `loc`, print the source line with an underline *)
  for l = ystart to yend do
    let line = input_line file in
    let linewidth = String.length line in
    let left = if l = ystart then xstart else 1 in
    let right = if l = yend then xend else linewidth in
    if linewidth > 0 then begin
      prerr_endline (retab line);
      prerr_string (indent (count_tabs line right));
      for i = 1 to left - 1 do prerr_char ' ' done;
      for i = left to right do prerr_char '^' done;
      prerr_endline "";
    end
79
  done
80

81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98
let prerr_loc_msg loc msg =
  let (fname, ystart, yend, xstart, xend) = loc in
  if loc != noloc then begin
    let line_s = if yend != ystart
      then sprintf "lines %d-%d" ystart yend
      else sprintf "line %d" ystart
    in
    let char_s = if xend != xstart || yend != ystart
      then sprintf "characters %d-%d" xstart xend
      else sprintf "character %d" xstart
    in
    eprintf "File \"%s\", %s, %s:\n" fname line_s char_s;
  end;
  eprintf "%s\n" msg;

  if loc != noloc then
    try prerr_loc loc
    with Sys_error _ -> ()
99

Taddeüs Kroes's avatar
Taddeüs Kroes committed
100 101
(** AST traversal *)

102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
#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)

Taddeüs Kroes's avatar
Taddeüs Kroes committed
118
let transform_stylesheet f stylesheet =
119 120 121 122 123 124 125 126 127 128 129 130 131 132
  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

133 134 135 136 137 138 139 140 141 142 143 144 145 146
  let rec trav_selector = function
    | (No_element | All_elements | Element _) as elem ->
      f (Selector elem)
    | Id (base, id) ->
      f (Selector (Id (expect_selector base, id)))
    | Class (base, cls) ->
      f (Selector (Class (expect_selector base, cls)))
    | Attribute (base, attr, value) ->
      f (Selector (Attribute (expect_selector base, attr, value)))
    | Pseudo (base, sel, None) ->
      f (Selector (Pseudo (expect_selector base, sel, None)))
    | Pseudo (base, fn, Some args) ->
      let args = trav_all_selector args in
      f (Selector (Pseudo (expect_selector base, fn, Some args)))
147
    | Combinator (left, com, right) ->
148 149
      let left = expect_selector left in
      let right = expect_selector right in
150
      f (Selector (Combinator (left, com, right)))
151 152
  and EXPECT(selector, Selector)
  and TRAV_ALL(selector, Selector) in
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217

  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)))
218
    | Keyframes (prefix, id, rules) ->
219
      let rules = trav_all_keyframe_ruleset rules in
220
      f (Statement (Keyframes (prefix, id, rules)))
221 222 223 224 225 226 227 228 229
    | 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
230 231 232 233

(* Expression identification *)

let is_color = Color_names.is_color
Taddeüs Kroes's avatar
Taddeüs Kroes committed
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249

(* Sorting declarations *)

let sort_stylesheet =
  let transform_sort_decls = function
    | Statement (Ruleset (selectors, decls)) ->
      let pattern = Str.regexp "^\\([^-]+\\)-" in
      let stem x =
        if Str.string_match pattern x 0 then Str.matched_group 1 x else x
      in
      let cmp (a, _, _) (b, _, _) = String.compare (stem a) (stem b) in
      Statement (Ruleset (selectors, List.stable_sort cmp decls))
    | v -> v
  in
  transform_stylesheet transform_sort_decls