aboutsummaryrefslogtreecommitdiff
path: root/css/lib/menhir_parser.mly
blob: fb5a1cf475a3ca4dcf56e4cde60e2e08886ff119 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
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
%{

(* Workaround for this dune bug: https://github.com/ocaml/dune/issues/2450 *)
module Css = struct end

open Types

%}

%token EOF
%token LEFT_BRACE
%token RIGHT_BRACE
%token LEFT_PAREN
%token RIGHT_PAREN
%token LEFT_BRACKET
%token RIGHT_BRACKET
%token COLON
%token DOT
(* Whitespaces are detected only in selectors, before ":", ".", and "#", to
 * disambiguate between "p :first-child" and "p:first-child", these
 * whitespaces are replaced with "*" *)
%token WHITESPACE
%token SEMI_COLON
%token PERCENTAGE
%token IMPORTANT
%token <string> IDENT
%token <string> STRING
%token <string> URI
%token <string> OPERATOR
%token <string> DELIM
%token <string> NESTED_AT_RULE
%token <string> AT_RULE_WITHOUT_BODY
%token <string> AT_RULE
%token <string> FUNCTION
%token <string> HASH
%token <string> NUMBER
%token <string> UNICODE_RANGE
%token <string * string * Types.dimension> FLOAT_DIMENSION
%token <string * string> DIMENSION

%start <Types.Stylesheet.t> stylesheet
%start <Types.Declaration_list.t> declaration_list

%%

stylesheet:
  s = stylesheet_without_eof; EOF { s }
  ;

stylesheet_without_eof:
  rs = list(rule) { (rs, Lex_buffer.make_loc_and_fix $startpos $endpos) }
  ;

declaration_list:
  ds = declarations_with_loc; EOF { ds }
  ;

rule:
  | r = at_rule { Rule.At_rule r }
  | r = style_rule { Rule.Style_rule r }
  ;

at_rule:
  | name = AT_RULE_WITHOUT_BODY; xs = prelude_with_loc; SEMI_COLON {
      { At_rule.name = (name, Lex_buffer.make_loc_and_fix $startpos(name) $endpos(name));
        prelude = xs;
        block = Brace_block.Empty;
        loc = Lex_buffer.make_loc_and_fix $startpos $endpos;
      }
    }
  | name = NESTED_AT_RULE; xs = prelude_with_loc; LEFT_BRACE; s = stylesheet_without_eof; RIGHT_BRACE {
      { At_rule.name = (name, Lex_buffer.make_loc_and_fix $startpos(name) $endpos(name));
        prelude = xs;
        block = Brace_block.Stylesheet s;
        loc = Lex_buffer.make_loc_and_fix $startpos $endpos;
      }
    }
  | name = AT_RULE; xs = prelude_with_loc; LEFT_BRACE; ds = declarations_with_loc; RIGHT_BRACE {
      { At_rule.name = (name, Lex_buffer.make_loc_and_fix $startpos(name) $endpos(name));
        prelude = xs;
        block = Brace_block.Declaration_list ds;
        loc = Lex_buffer.make_loc_and_fix $startpos $endpos;
      }
    }
  ;

style_rule:
  | xs = prelude_with_loc; LEFT_BRACE; RIGHT_BRACE {
      { Style_rule.prelude = xs;
        block = [], Location.none;
        loc = Lex_buffer.make_loc_and_fix $startpos $endpos;
      }
    }
  | xs = prelude_with_loc; LEFT_BRACE; ds = declarations_with_loc; RIGHT_BRACE {
      { Style_rule.prelude = xs;
        block = ds;
        loc = Lex_buffer.make_loc_and_fix $startpos $endpos;
      }
    }
  ;

prelude_with_loc:
  xs = prelude { (xs, Lex_buffer.make_loc_and_fix $startpos $endpos) }
  ;

prelude:
  xs = list(component_value_with_loc_in_prelude) { xs }
  ;

declarations_with_loc:
  | ds = declarations { (ds, Lex_buffer.make_loc_and_fix ~loc_ghost:true $startpos $endpos) }
  ;

declarations:
  | ds = declarations_without_ending_semi_colon { List.rev ds }
  | ds = declarations_without_ending_semi_colon; SEMI_COLON { List.rev ds }
  ;

declarations_without_ending_semi_colon:
  | d = declaration_or_at_rule { [d] }
  | ds = declarations_without_ending_semi_colon; SEMI_COLON; d = declaration_or_at_rule { d :: ds }
  ;

declaration_or_at_rule:
  | d = declaration { Declaration_list.Declaration d }
  | r = at_rule { Declaration_list.At_rule r }
  ;

declaration:
  n = IDENT; option(WHITESPACE); COLON; v = list(component_value_with_loc); i = boption(IMPORTANT) {
    { Declaration.name = (n, Lex_buffer.make_loc_and_fix $startpos(n) $endpos(n));
      value = (v, Lex_buffer.make_loc_and_fix $startpos(v) $endpos(v));
      important = (i, Lex_buffer.make_loc_and_fix $startpos(i) $endpos(i));
      loc = Lex_buffer.make_loc_and_fix $startpos $endpos;
    }
  }
  ;

paren_block:
  LEFT_PAREN; xs = list(component_value_with_loc); RIGHT_PAREN { xs }
  ;

bracket_block:
  LEFT_BRACKET; xs = list(component_value_with_loc); RIGHT_BRACKET { xs }
  ;

component_value_with_loc:
  | c = component_value { (c, Lex_buffer.make_loc_and_fix $startpos $endpos) }

component_value:
  | b = paren_block { Component_value.Paren_block b }
  | b = bracket_block { Component_value.Bracket_block b }
  | n = NUMBER; PERCENTAGE { Component_value.Percentage n }
  | i = IDENT { Component_value.Ident i }
  | s = STRING { Component_value.String s }
  | u = URI { Component_value.Uri u }
  | o = OPERATOR { Component_value.Operator o }
  | d = DELIM { Component_value.Delim d }
  | option(WHITESPACE); COLON { Component_value.Delim ":" }
  | option(WHITESPACE); DOT { Component_value.Delim "." }
  | f = FUNCTION; xs = list(component_value_with_loc); RIGHT_PAREN {
      Component_value.Function ((f, Lex_buffer.make_loc_and_fix $startpos(f) $endpos(f)),
                                (xs, Lex_buffer.make_loc_and_fix $startpos(xs) $endpos(xs)))
    }
  | option(WHITESPACE); h = HASH { Component_value.Hash h }
  | n = NUMBER { Component_value.Number n }
  | r = UNICODE_RANGE { Component_value.Unicode_range r }
  | d = FLOAT_DIMENSION { Component_value.Float_dimension d }
  | d = DIMENSION { Component_value.Dimension d }
  ;

component_value_with_loc_in_prelude:
  | c = component_value_in_prelude { (c, Lex_buffer.make_loc_and_fix $startpos $endpos) }

component_value_in_prelude:
  | b = paren_block { Component_value.Paren_block b }
  | b = bracket_block { Component_value.Bracket_block b }
  | n = NUMBER; PERCENTAGE { Component_value.Percentage n }
  | i = IDENT { Component_value.Ident i }
  | s = STRING { Component_value.String s }
  | u = URI { Component_value.Uri u }
  | o = OPERATOR { Component_value.Operator o }
  | d = DELIM { Component_value.Delim d }
  | WHITESPACE { Component_value.Delim "*" }
  | COLON { Component_value.Delim ":" }
  | DOT { Component_value.Delim "." }
  | f = FUNCTION; xs = list(component_value_with_loc); RIGHT_PAREN {
      Component_value.Function ((f, Lex_buffer.make_loc_and_fix $startpos(f) $endpos(f)),
                                (xs, Lex_buffer.make_loc_and_fix $startpos(xs) $endpos(xs)))
    }
  | h = HASH { Component_value.Hash h }
  | n = NUMBER { Component_value.Number n }
  | r = UNICODE_RANGE { Component_value.Unicode_range r }
  | d = FLOAT_DIMENSION { Component_value.Float_dimension d }
  | d = DIMENSION { Component_value.Dimension d }
  ;
s="o">: elt array) (v2: elt array) : elt = let rec dotting (i: int) (total: elt) : elt = if i = 0 then total else let curr = C.multiply v1.(i-1) v2.(i-1) in dotting (i - 1) (C.add curr total) in let len1, len2 = Array.length v1, Array.length v2 in if len1 = len2 then dotting len1 C.zero else raise ImproperDimensions (* function to expose the dimensions of a matrix *) let get_dimensions (m: matrix) : (int * int) = let ((x,y), _) = m in (x,y) (*************** End Helper Functions ***************) (*************** Primary Matrix Functions ***************) (* scales a matrix by the appropriate factor *) let scale (m: matrix) (sc: elt) : matrix = map (C.multiply sc) m (* Generates a matrix from a list of lists. The inners lists are the rows *) let from_list (lsts : elt list list) : matrix = let check_length (length: int) (lst: elt list) : int = if List.length lst = length then length else raise ImproperDimensions in let p = List.length lsts in match lsts with | [] -> raise ImproperDimensions | hd::tl -> let len = List.length hd in if List.fold_left check_length len tl = len then ((p,len),Array.map Array.of_list (Array.of_list lsts)) else raise ImproperDimensions (* Generates a matrix from a list of lists. The inners lists are the rows *) let from_array (arrs : elt array array) : matrix = let check_length (length: int) (arr: elt array) : unit = if Array.length arr = length then () else raise ImproperDimensions in let p = Array.length arrs in match Array.length arrs with | 0 -> raise ImproperDimensions | _ -> let len = Array.length (Array.get arrs 0) in Array.iter (check_length len) arrs; ((p, len), arrs) (* Adds two matrices. They must have the same dimensions *) let add ((dim1,m1): matrix) ((dim2,m2): matrix) : matrix = if dim1 = dim2 then let n, p = dim1 in let (dim', sum_m) = empty n p in for i = 0 to n - 1 do for j = 0 to p - 1 do sum_m.(i).(j) <- C.add m1.(i).(j) m2.(i).(j) done; done; (dim',sum_m) else raise ImproperDimensions (* Multiplies two matrices. If the matrices have dimensions m x n and p x q, n * and p must be equal, and the resulting matrix will have dimension n x q *) let mult (matrix1: matrix) (matrix2: matrix) : matrix = let ((m,n), _), ((p,q), _) = matrix1, matrix2 in if n = p then let (dim, result) = empty m q in for i = 0 to m - 1 do for j = 0 to q - 1 do let (_,row), (_,column) = get_row matrix1 (i + 1), get_column matrix2 (j + 1) in result.(i).(j) <- dot row column done; done; (dim,result) else raise ImproperDimensions (*************** Helper Functions for Row Reduce ***************) (* (* returns the index of the first non-zero elt in an array*) let zero (arr: elt array) : int option = let index = ref 1 in let empty (i: int option) (e: elt) : int option = match i, C.compare e C.zero with | None, Equal -> (index := !index + 1; None) | None, _ -> Some (!index) | _, _ -> i in Array.fold_left empty None arr (* returns the the location of the nth non-zero * element in the matrix. Scans column wise. So the nth non-zero element is * the FIRST non-zero element in the nth non-zero column *) let nth_nz_location (m: matrix) (_: int): (int*int) option = let ((n,p), _) = m in let rec check_col (to_skip: int) (j: int) = if j <= p then let (_,col) = get_column m j in match zero col with | None -> check_col to_skip (j + 1) | Some i -> if to_skip = 0 then Some (i,j) else (* we want a later column *) check_col (to_skip - 1) (j + 1) else None in check_col (n - 1) 1 (* returns the the location of the first * non-zero and non-one elt. Scans column wise, from * left to right. Basically, it ignores columns * that are all zero or that *) let fst_nz_no_loc (m: matrix): (int*int) option = let ((_, p), _) = m in let rec check_col (j: int) = if j <= p then let (_,col) = get_column m j in match zero col with | None -> check_col (j + 1) | Some i -> match C.compare col.(i-1) C.one with | Equal -> check_col (j + 1) | _ -> Some (i,j) else None in check_col 1 *) (* Compares two elements in an elt array and returns the greater and its * index. Is a helper function for find_max_col_index *) let compare_helper (e1: elt) (e2: elt) (ind1: int) (ind2: int) : (elt*int) = match C.compare e1 e2 with | Equal -> (e2, ind2) | Greater -> (e1, ind1) | Less -> (e2, ind2) (* Finds the element with the greatest absolute value in a column. Is not * 0-indexed. If two elements are both the maximum value, returns the one with * the lowest index. Returns None if this element is zero (if column is all 0) *) let find_max_col_index (array1: elt array) (start_index: int) : int option = let rec find_index (max_index: int) (curr_max: elt) (curr_index: int) (arr: elt array) = if curr_index = Array.length arr then (if curr_max = C.zero then None else Some (max_index+1)) (* Arrays are 0-indexed but matrices aren't *) else (match C.compare arr.(curr_index) C.zero with | Equal -> find_index max_index curr_max (curr_index+1) arr | Greater -> (let (el, index) = compare_helper (arr.(curr_index)) curr_max curr_index max_index in find_index index el (curr_index+1) arr) | Less -> (let abs_curr_elt = C.subtract C.zero arr.(curr_index) in let (el, index) = compare_helper abs_curr_elt curr_max curr_index max_index in find_index index el (curr_index+1) arr)) in find_index 0 C.zero (start_index -1) array1 (* Basic row operations *) (* Scales a row by sc *) let scale_row (m: matrix) (num: int) (sc: elt) : unit = let (_, row) = get_row m num in let new_row = Array.map (C.multiply sc) row in set_row m num new_row (* Swaps two rows of a matrix *) let swap_row (m: matrix) (r1: int) (r2: int) : unit = let (len1, row1) = get_row m r1 in let (len2, row2) = get_row m r2 in let _ = assert (len1 = len2) in let _ = set_row m r1 row2 in let _ = set_row m r2 row1 in () (* Subtracts a multiple of r2 from r1 *) let sub_mult (m: matrix) (r1: int) (r2: int) (sc: elt) : unit = let (len1, row1) = get_row m r1 in let (len2, row2) = get_row m r2 in let _ = assert (len1 = len2) in for i = 0 to len1 - 1 do (* Arrays are 0-indexed *) row1.(i) <- C.subtract row1.(i) (C.multiply sc row2.(i)) done; set_row m r1 row1 (*************** End Helper Functions for Row Reduce ***************) (* Returns the row reduced form of a matrix. Is not done in place, but creates * a new matrix *) let row_reduce (mat: matrix) : matrix = let[@tailcall] rec row_reduce_h (n_row: int) (n_col: int) (mat2: matrix) : unit = let ((num_row, _), _) = mat2 in if (n_col = num_row + 1) then () else let (_,col) = get_column mat2 n_col in match find_max_col_index col n_row with | None (* Column all 0s *) -> row_reduce_h n_row (n_col+1) mat2 | Some index -> begin swap_row mat2 index n_row; let pivot = get_elt mat2 (n_row, n_col) in scale_row mat2 (n_row) (C.divide C.one pivot); for i = 1 to num_row do if i <> n_row then sub_mult mat2 i n_row (get_elt mat2 (i,n_col)) done; row_reduce_h (n_row+1) (n_col+1) mat2 end in (* Copies the matrix *) let ((n,p),m) = mat in let (dim,mat_cp) = empty n p in for i = 0 to n - 1 do for j = 0 to p - 1 do mat_cp.(i).(j) <- m.(i).(j) done; done; let _ = row_reduce_h 1 1 (dim,mat_cp) in (dim,mat_cp) (*************** End Main Functions ***************) (*************** Optional module functions ***************) (* calculates the trace of a matrix *) let trace (((n,p),m): matrix) : elt = let rec build (elt: elt) (i: int) = if i > -1 then build (C.add m.(i).(i) elt) (i - 1) else elt in if n = p then build C.zero (n - 1) else raise ImproperDimensions (* calculates the transpose of a matrix and retuns a new one *) let transpose (((n,p),m): matrix) = let (dim,m') = empty p n in for i = 0 to n - 1 do for j = 0 to p - 1 do m'.(j).(i) <- m.(i).(j) done; done; assert(dim = (p,n)); ((p,n),m') (* Returns the inverse of a matrix. Uses a pretty simple algorithm *) let inverse (mat: matrix) : matrix = let ((n, p), _) = mat in if n = p then (* create augmented matrix *) let augmented = empty n (2*n) in for i = 1 to n do let (dim,col) = get_column mat i in let arr = Array.make n C.zero in begin assert(dim = n); arr.(i-1) <- C.one; set_column augmented i col; set_column augmented (n + i) arr end done; let augmented' = row_reduce augmented in (* create the inverted matrix and fill in with appropriate values *) let inverse = empty n n in for i = 1 to n do let (dim, col) = get_column augmented' (n + i) in let _ = assert(dim = n) in let _ = set_column inverse i col in () done; inverse else raise NonSquare (***************** HELPER FUNCTIONS FOR DETERMINANT *****************) (* creates an identity matrix of size n*) let create_identity (n:int) : matrix = let (dim,m) = empty n n in for i = 0 to n - 1 do m.(i).(i) <- C.one done; (dim,m) (* Finds the index of the maximum value of an array *) let find_max_index (arr: elt array) (start_index : int) : int = let rec find_index (max_index: int) (curr_index: int) = if curr_index = Array.length arr then max_index+1 else match C.compare arr.(curr_index) arr.(max_index) with | Equal | Less -> find_index max_index (curr_index + 1) | Greater -> find_index curr_index (curr_index + 1) in find_index (start_index - 1) start_index (* Creates the pivoting matrix for A. Returns swqps. Adapted from * http://rosettacode.org/wiki/LU_decomposition#Common_Lisp *) let pivotize (((n,p),m): matrix) : matrix * int = if n = p then let swaps = ref 0 in let pivot_mat = create_identity n in for j = 1 to n do let (_,col) = get_column ((n,p),m) j in let max_index = find_max_index col j in if max_index <> j then (swaps := !swaps + 1; swap_row pivot_mat max_index j) else () done; (pivot_mat,!swaps) else raise ImproperDimensions (* decomposes a matrix into a lower triangualar, upper triangualar * and a pivot matrix. It returns (L,U,P). Adapted from * http://rosettacode.org/wiki/LU_decomposition#Common_Lisp *) let lu_decomposition (((n,p),m): matrix) : (matrix*matrix*matrix)*int = if n = p then let mat = ((n,p),m) in let lower, upper, (pivot,s) = empty n n, empty n n, pivotize mat in let (_ ,l),(_ ,u), _ = lower,upper,pivot in let ((_, _),mat') = mult pivot mat in for j = 0 to n - 1 do l.(j).(j) <- C.one; for i = 0 to j do let sum = ref C.zero in for k = 0 to i - 1 do sum := C.add (!sum) (C.multiply u.(k).(j) l.(i).(k)) done; u.(i).(j) <- C.subtract mat'.(i).(j) (!sum) done; for i = j to n - 1 do let sum = ref C.zero in for k = 0 to j - 1 do sum := C.add (!sum) (C.multiply u.(k).(j) l.(i).(k)) done; let sub = C.subtract mat'.(i).(j) (!sum) in l.(i).(j) <- C.divide sub u.(j).(j) done; done; (lower,upper,pivot),s else raise ImproperDimensions (* Computes the determinant of a matrix *) let determinant (m: matrix) : elt = try let ((n,p), _) = m in if n = p then let rec triangualar_det (a,mat) curr_index acc = if curr_index < n then let acc' = C.multiply mat.(curr_index).(curr_index) acc in triangualar_det (a,mat) (curr_index + 1) acc' else acc in let ((dim1,l),(dim2,u), _),s = lu_decomposition m in let det1, det2 = triangualar_det (dim1,l) 0 C.one, triangualar_det (dim2,u) 0 C.one in if s mod 2 = 0 then C.multiply det1 det2 else C.subtract C.zero (C.multiply det1 det2) else raise ImproperDimensions with | _ -> C.zero (*************** Optional module functions ***************) end