Created basic CSS parser, data stucture and stringifier

.gitignore

+._*/
+mincss
+*.cmo
+*.cmi
+*.cmx
+*.swp
+*.o
+types.ml
+lexer.ml
+lexer.mli
+parser.ml
+parser.mli
+parser.conflicts
+parser.automaton

Makefile

+RESULT := mincss
+SOURCES := types.ml types.mli stringify.ml lexer.mll parser.mly util.ml parse.ml \
+	main.ml
+PRE_TARGETS := types.ml types.cmi stringify.cmi
+LIBS := str
+
+# Set debugging flag to enable exception backtraces for OCAMLRUNPARAM=b
+OCAMLFLAGS := -g
+
+OCAMLYACC := menhir
+YFLAGS := --infer --explain --dump
+
+.PHONY: all myclean
+
+all: native-code
+
+clean:: myclean
+
+# The Types module needs an implementation to stop ocamlc from complaining
+types.ml: types.mli
+	cp $< $@
+
+myclean:
+	rm -f a.out types.ml parser.conflicts parser.automaton
+
+include OCamlMakefile

lexer.mll

+{
+open Lexing
+open Parser
+
+exception SyntaxError of string
+
+let next_line lexbuf =
+  let pos = lexbuf.lex_curr_p in
+  lexbuf.lex_curr_p <- {
+    pos with pos_bol = lexbuf.lex_curr_pos;
+             pos_lnum = pos.pos_lnum + 1
+  }
+}
+
+rule token = parse
+  | '(' { LPAREN }
+  | ')' { RPAREN }
+  | '{' { LBRACE }
+  | '}' { RBRACE }
+  | ';' { SEMICOL }
+  | ',' { COMMA }
+  | ':' { COLON }
+
+  | "@media"     { MEDIA }
+  | "@import"    { IMPORT }
+  | "@charset"   { CHARSET }
+  | "@page"      { PAGE }
+  | "@font-face" { FONTFACE }
+  | "@namespace" { NAMESPACE }
+
+  | "!important" { IMPORTANT }
+  | ['A'-'Z''a'-'z''0'-'9''_''-''#''.']+ as id { ID id }
+  | ['.''#'':']['A'-'Z''a'-'z''_''-']['A'-'Z''a'-'z''0'-'9''_''-''.''#'':']* as id { SELECTOR id }
+
+  | '\r' | '\n' | "\r\n" { next_line lexbuf; token lexbuf }
+  | [' ''\t']+           { token lexbuf }
+  | "/*"                 { comment lexbuf }
+  | '"'                  { str (Buffer.create 17) lexbuf }
+  | eof | '\000'         { EOF }
+
+  | _ as chr { raise (SyntaxError ("unexpected char: " ^ Char.escaped chr)) }
+
+(* Multi-line comments *)
+and comment = parse
+  | '\r' | '\n' | "\r\n"  { next_line lexbuf; comment lexbuf }
+  | "*/"                  { token lexbuf }
+  | _                     { comment lexbuf }
+
+(* Strings *)
+and str buf = parse
+  | '"'              { STRING (Buffer.contents buf) }
+  | '\\''/'          { Buffer.add_char buf '/';    str buf lexbuf }
+  | '\\''\\'         { Buffer.add_char buf '\\';   str buf lexbuf }
+  | '\\''b'          { Buffer.add_char buf '\b';   str buf lexbuf }
+  | '\\''f'          { Buffer.add_char buf '\012'; str buf lexbuf }
+  | '\\''n'          { Buffer.add_char buf '\n';   str buf lexbuf }
+  | '\\''r'          { Buffer.add_char buf '\r';   str buf lexbuf }
+  | '\\''t'          { Buffer.add_char buf '\t';   str buf lexbuf }
+  | [^'"''\\']+ as s { Buffer.add_string buf s;    str buf lexbuf }
+  | eof              { raise (SyntaxError "unterminated string") }
+  | _ as c { raise (SyntaxError ("illegal string character: " ^ Char.escaped c)) }

main.ml

+open Lexing
+open Types
+
+(* Parse command-line arguments *)
+let parse_args () =
+  let args = {
+    infiles = [];
+    outfile = None;
+    verbose = 1;
+  } in
+  let args_spec = [
+    ("<file> ...", Arg.Rest (fun _ -> ()),
+                 " Optional input files (default is to read from stdin)");
+
+    ("-o", Arg.String (fun s -> args.outfile <- Some s),
+         "<file>   Output file (defaults to stdout)");
+
+    ("-v", Arg.Int (fun i -> args.verbose <- i),
+         "<num>    Set verbosity (0: nothing, 1: errors (default), \
+          2: compression rate, 3: debug)");
+  ] in
+
+  let usage =
+    "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-v <verbosity>] [<file> ...]"
+  in
+
+  Arg.parse args_spec (fun f -> args.infiles <- args.infiles @ [f]) usage;
+  args
+
+(* Main function, returns exit status
+ * Command-line arguments are stored in lobals.args *)
+let main () =
+  let args = parse_args () in
+  try
+    let css =
+      match args.infiles with
+      | [] ->
+        let input = Util.input_buffered stdin 512 in
+        Parse.parse_input "<stdin>" input
+      | files ->
+        let rec loop = function
+          | [] -> []
+          | filename :: tl ->
+            let input = Util.input_all (open_in filename) in
+            let css = Parse.parse_input filename input in
+            css @ loop tl
+        in
+        loop files
+    in
+    Util.print_css css;
+    0
+  with
+  | LocError (loc, msg) ->
+    Util.prerr_loc_msg args loc ("Error: " ^ msg);
+    1
+  | Failure err ->
+    prerr_endline ("Error: " ^ err);
+    1
+
+let _ = exit (main ())

parse.ml

+open Lexing
+open Types
+
+let loc_from_lexpos pstart pend =
+  let (fname, ystart, yend, xstart, xend) = begin
+    pstart.pos_fname,
+    pstart.pos_lnum,
+    pend.pos_lnum,
+    (pstart.pos_cnum - pstart.pos_bol + 1),
+    (pend.pos_cnum - pend.pos_bol)
+  end in
+  if ystart = yend && xend < xstart then
+    (fname, ystart, yend, xstart, xstart)
+  else
+    (fname, ystart, yend, xstart, xend)
+
+let get_loc lexbuf =
+  loc_from_lexpos lexbuf.lex_curr_p lexbuf.lex_curr_p
+
+let shift_loc (fname, ystart, yend, xstart, xend) yshift xshift =
+  (fname, ystart + yshift, yend + yshift, xstart + xshift, xend + xshift)
+
+let shift_back lexbuf =
+  shift_loc (get_loc lexbuf) 0 (-1)
+
+let parse_input display_name content =
+  let lexbuf = Lexing.from_string content in
+  lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = display_name };
+  try Parser.stylesheet Lexer.token lexbuf with
+  | Lexer.SyntaxError msg ->
+    raise (LocError (shift_back lexbuf, msg))
+  | Parser.Error ->
+    raise (LocError (shift_back lexbuf, "syntax error"))

parser.mly

+%{
+open Lexing
+open Types
+
+let prop2str (name, value) = name ^ ":" ^ Stringify.value2str value
+%}
+
+(* Tokens *)
+%token LPAREN RPAREN LBRACE RBRACE SEMICOL COMMA COLON
+%token MEDIA IMPORT CHARSET PAGE FONTFACE NAMESPACE
+%token IMPORTANT EOF
+%token <string> ID STRING SELECTOR
+
+(* Start symbol *)
+%type <Types.decl list> stylesheet
+%start stylesheet
+
+%%
+
+(* Left-recursive list (use List.rev to obtain correctly ordered list) *)
+llist(x):
+  |            { [] }
+  | tl=llist(x) hd=x { hd :: tl }
+
+separated_llist(sep, x):
+  |                      { [] }
+  | tl=llist(x) sep hd=x { hd :: tl }
+
+stylesheet:
+  | decls=llist(decl) EOF
+  { List.rev decls }
+
+selector:
+  | id=ID                    { [id] }
+  | id=SELECTOR              { [id] }
+  | tl=selector hd=ID        { hd :: tl }
+  | tl=selector hd=SELECTOR  { hd :: tl }
+
+value:
+  | str=STRING                      { Str str }
+  | lit=ID                          { Lit lit }
+  | name=ID LPAREN arg=value RPAREN { Fn (name, arg) }
+  | IMPORTANT                       { Imp }
+
+prop:
+  | name=ID COLON v=value+
+  { (name, match v with [hd] -> hd | _ -> Lst v) }
+
+propline:
+  | p=prop SEMICOL
+  { p }
+
+props:
+  | LBRACE p=llist(propline) last=prop? RBRACE
+  { List.rev p @ (match last with None -> [] | Some p -> [p]) }
+
+group:
+  | s=separated_nonempty_list(COMMA, selector) p=props
+  { Group (List.rev s, p) }
+
+%inline media:
+  | m=ID
+  { m }
+  | LPAREN p=prop RPAREN
+  { "(" ^ prop2str p ^ ")" }
+
+%inline stringopt: f=STRING | f=ID { f }
+
+decl:
+  | g=group
+  { g }
+  | MEDIA queries=separated_nonempty_list(COMMA, media) LBRACE groups=llist(group) RBRACE
+  { Media (queries, List.rev groups) }
+  | IMPORT f=stringopt q=separated_list(COMMA, ID) SEMICOL
+  { Import (f, q) }
+  | CHARSET c=stringopt SEMICOL
+  { Charset c }
+  | PAGE query=ID? p=props
+  { Page (query, p) }
+  | FONTFACE p=props
+  { Fontface p }
+  | NAMESPACE prefix=ID? uri=STRING SEMICOL
+  { Namespace (prefix, uri) }
+
+%%

stringify.ml

+open Types
+
+let tab = "    "
+
+let indent = Str.global_replace (Str.regexp "^\\(.\\)") (tab ^ "\\1")
+
+let rec cat sep fn = function
+  | [] -> ""
+  | [hd] -> fn hd
+  | hd :: tl -> fn hd ^ sep ^ cat sep fn tl
+
+let rec value2str = function
+  | Lit lit -> lit
+  | Str str -> "\"" ^ str ^ "\""
+  | Lst values -> cat " " value2str values
+  | Dim (x, u) when float_of_int (int_of_float x) = x ->
+    string_of_int (int_of_float x) ^ u
+  | Dim (x, u) -> string_of_float x ^ u
+  | Fn (name, arg) -> name ^ "(" ^ value2str arg ^ ")"
+  | Imp -> "!important"
+
+let prop2str (name, value) = name ^ ": " ^ value2str value ^ ";"
+
+let block body = " {\n" ^ indent body ^ "\n}"
+
+let rec decl2str = function
+  | Group (selectors, props) ->
+    cat ", " (String.concat " ") selectors ^ block (cat "\n" prop2str props)
+  | Media (queries, groups) ->
+    "@media " ^ String.concat ", " queries ^ block (cat "\n\n" decl2str groups)
+  | Import (filename, []) ->
+    "@import \"" ^ filename ^ "\";"
+  | Import (filename, queries) ->
+    "@import \"" ^ filename ^ "\" " ^ String.concat ", " queries ^ ";"
+  | Charset charset ->
+    "@charset \"" ^ charset ^ "\";"
+  | Page (None, props) ->
+    "@page" ^ block (cat "\n" prop2str props)
+  | Page (Some query, props) ->
+    "@page " ^ query ^ block (cat "\n" prop2str props)
+  | Fontface props ->
+    "@font-face " ^ block (cat "\n" prop2str props)
+  | Namespace (None, uri) ->
+    "@namespace \"" ^ uri ^ "\";"
+  | Namespace (Some prefix, uri) ->
+    "@namespace " ^ prefix ^ " \"" ^ uri ^ "\";"
+
+let decls2str = cat "\n\n" decl2str

types.mli

+type value =
+  | Lit of string
+  | Str of string
+  | Lst of value list
+  | Dim of float * string
+  | Fn of string * value
+  | Imp
+
+type prop = string * value
+
+type selector = string list
+
+type decl =
+  | Group of selector list * prop list  (* <selectors> { <props> } *)
+  | Media of string list * decl list    (* @media <queries> { <groups> } *)
+  | Import of string * string list      (* @import "<file>" [<media>]; *)
+  | Charset of string                   (* @charset "<charset>"; *)
+  | Page of string option * prop list   (* @page [<query>] { <props> } *)
+  | Fontface of prop list               (* @font-face { <props> } *)
+  | Namespace of string option * string (* @namespace [<prefix>] "<uri>"; *)
+  (* TODO: @document, @keyframes, @supports *)
+
+type args = {
+  mutable infiles : string list;
+  mutable outfile : string option;
+  mutable verbose : int;
+}
+
+type loc = string * int * int * int * int
+
+exception LocError of loc * string

util.ml

+open Printf
+open Str
+open Types
+
+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
+
+let output_css oc decls =
+  output_string oc (Stringify.decls2str decls);
+  output_char oc '\n'
+
+let print_css = output_css stdout
+
+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)
+  in count 0 upto
+
+let rec repeat s n = if n < 1 then "" else s ^ (repeat s (n - 1))
+
+let retab str = global_replace (regexp "\t") (repeat " " tabwidth) str
+
+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 *)
+  for i = 1 to ystart - 1 do let _ = input_line file in () done;
+
+  (* 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
+  done;
+  ()
+
+let prerr_loc_msg args loc msg =
+  if args.verbose >= 1 then begin
+    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 args.verbose >= 1 && loc != noloc then
+        try prerr_loc loc
+        with Sys_error _ -> ()
+  end;
+  ()