aboutsummaryrefslogtreecommitdiff
path: root/css
diff options
context:
space:
mode:
Diffstat (limited to 'css')
-rwxr-xr-xcss/css.html131
-rwxr-xr-xcss/dune19
-rwxr-xr-xcss/lib/dune9
-rwxr-xr-xcss/lib/lex_buffer.ml114
-rwxr-xr-xcss/lib/lexer.ml351
-rwxr-xr-xcss/lib/location.ml19
-rwxr-xr-xcss/lib/menhir_parser.mly196
-rwxr-xr-xcss/lib/parser.ml5
-rwxr-xr-xcss/lib/parser.mli8
-rwxr-xr-xcss/lib/types.ml76
-rwxr-xr-xcss/lib/types.mli68
-rwxr-xr-xcss/merge_lib/common.ml61
-rwxr-xr-xcss/merge_lib/comparator.ml160
-rwxr-xr-xcss/merge_lib/css_lib.ml5
-rwxr-xr-xcss/merge_lib/dune6
-rwxr-xr-xcss/merge_lib/merge.ml138
-rwxr-xr-xcss/merge_lib/merge.mli10
-rwxr-xr-xcss/merge_lib/merge_style.ml132
-rwxr-xr-xcss/merge_lib/print.ml225
-rwxr-xr-xcss/merge_lib/print.mli7
-rwxr-xr-xcss/merger.ml275
21 files changed, 2015 insertions, 0 deletions
diff --git a/css/css.html b/css/css.html
new file mode 100755
index 0000000..82b0558
--- /dev/null
+++ b/css/css.html
@@ -0,0 +1,131 @@
+
+<!DOCTYPE html>
+<html lang="fr_fr">
+<head>
+ <meta charset="utf-8" />
+ <meta http-equiv="X-UA-Compatible" content="IE=edge" />
+ <meta name="HandheldFriendly" content="True" />
+ <meta name="viewport" content="width=device-width, initial-scale=1.0" />
+ <meta name="robots" content="noindex, nofollow" />
+
+ <link href="https://fonts.googleapis.com/css2?family=Source+Code+Pro:ital,wght@0,400;0,700;1,400&family=Source+Sans+Pro:ital,wght@0,300;0,400;0,700;1,400&display=swap" rel="stylesheet">
+
+ <link rel="stylesheet" type="text/css" href="/theme/stylesheet/style.min.css">
+
+
+ <link id="pygments-light-theme" rel="stylesheet" type="text/css"
+ href="//localhost:8000/theme/pygments/monokai.min.css">
+
+
+ <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/fontawesome.css">
+ <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/brands.css">
+ <link rel="stylesheet" type="text/css" href="/theme/font-awesome/css/solid.css">
+
+ <link href="//localhost:8000/custom.css" rel="stylesheet">
+
+ <link href="//localhost:8000/feeds/all.atom.xml" type="application/atom+xml" rel="alternate" title="Chimrod Atom">
+
+
+
+
+
+ <meta name="author" content="Chimrod" />
+ <meta name="description" content="" />
+<meta property="og:site_name" content="Chimrod"/>
+<meta property="og:type" content="blog"/>
+<meta property="og:title" content="Chimrod"/>
+<meta property="og:description" content=""/>
+<meta property="og:locale" content="en_US"/>
+<meta property="og:url" content="//localhost:8000"/>
+<meta property="og:image" content="/images/profile.png">
+
+
+
+ <title>Chimrod &ndash; Drawer</title>
+
+</head>
+<style>
+.button {
+
+ margin: 10px;
+
+}
+</style>
+<body class="light-theme">
+ <aside>
+ <div>
+ <a href="//localhost:8000">
+ <img src="/profile.png" alt="Chimrod" title="Chimrod">
+ </a>
+
+ <h1>
+ <a href="//localhost:8000">Chimrod</a>
+ </h1>
+
+
+
+ <nav>
+ <ul class="list">
+ <li>
+ <a target="_self" href="http://git.chimrod.com" >git</a>
+ </li>
+ </ul>
+ </nav>
+
+ <ul class="social">
+ </ul>
+ </div>
+
+ </aside>
+ <main>
+
+ <nav>
+ <a href="//localhost:8000">Accueil</a>
+
+
+ <a href="//localhost:8000/feeds/all.atom.xml">Atom</a>
+
+ </nav>
+
+<article class="single">
+ <header>
+ <h1 id="Application">Application</h1>
+ </header>
+ <div id="selector"></div>
+ <div>
+ <noscript>Sorry, you need to enable JavaScript to see this page.</noscript>
+ <script id="css_js" type="text/javascript" defer="defer" src="css.js"></script>
+ <script>
+ var script = document.getElementById('css_js');
+ var div = document.getElementById('selector');
+ script.addEventListener('load', function() {
+ merger.attach(div);
+ });
+ </script>
+ </div>
+</article>
+
+ <footer>
+<p>&copy; Sébastien Dailly</p>
+<p>
+Built with <a href="http://getpelican.com" target="_blank">Pelican</a>
+</p> </footer>
+ </main>
+
+
+
+
+<script type="application/ld+json">
+{
+ "@context" : "http://schema.org",
+ "@type" : "Blog",
+ "name": " Chimrod ",
+ "url" : "//localhost:8000",
+ "image": "./profile.png",
+ "description": ""
+}
+</script>
+
+
+</body>
+</html>
diff --git a/css/dune b/css/dune
new file mode 100755
index 0000000..65a9c41
--- /dev/null
+++ b/css/dune
@@ -0,0 +1,19 @@
+(executable
+ (name merger)
+ (libraries
+ brr
+ brr.note
+ elements
+ blog
+ Css
+ css_lib
+ )
+ (modes js)
+ (preprocess (pps js_of_ocaml-ppx))
+ (link_flags (:standard -no-check-prims))
+ )
+
+(rule
+ (targets css.js)
+ (deps merger.bc.js)
+ (action (copy %{deps} %{targets})))
diff --git a/css/lib/dune b/css/lib/dune
new file mode 100755
index 0000000..1b84385
--- /dev/null
+++ b/css/lib/dune
@@ -0,0 +1,9 @@
+(menhir
+ (modules menhir_parser)
+ (flags --explain))
+
+(library
+ (name Css)
+ (libraries sedlex menhirLib)
+ (preprocess (pps sedlex.ppx)))
+
diff --git a/css/lib/lex_buffer.ml b/css/lib/lex_buffer.ml
new file mode 100755
index 0000000..0416e53
--- /dev/null
+++ b/css/lib/lex_buffer.ml
@@ -0,0 +1,114 @@
+(* Based on
+ * https://github.com/smolkaj/ocaml-parsing/blob/master/src/LexBuffer.ml *)
+
+(** A custom lexbuffer that automatically keeps track of the source location.
+ This module is a thin wrapper arounds sedlexing's default buffer, which does
+ not provide this functionality. *)
+
+type t = {
+ buf : Sedlexing.lexbuf;
+ mutable pos : Lexing.position;
+ mutable pos_mark : Lexing.position;
+ mutable last_char : int option;
+ mutable last_char_mark : int option;
+}
+(** the lex buffer type *)
+
+let of_sedlex ?(file = "<n/a>") ?pos buf =
+ let pos =
+ match pos with
+ | None ->
+ {
+ Lexing.pos_fname = file;
+ pos_lnum = 1;
+ (* line number *)
+ pos_bol = 0;
+ (* offset of beginning of current line *)
+ pos_cnum = 0 (* total offset *);
+ }
+ | Some p -> p
+ in
+ { buf; pos; pos_mark = pos; last_char = None; last_char_mark = None }
+
+let of_ascii_string ?pos s = of_sedlex ?pos (Sedlexing.Latin1.from_string s)
+
+let of_ascii_file file =
+ let chan = open_in file in
+ of_sedlex ~file (Sedlexing.Latin1.from_channel chan)
+
+(** The next four functions are used by sedlex internally.
+ See https://www.lexifi.com/sedlex/libdoc/Sedlexing.html. *)
+let mark lexbuf p =
+ lexbuf.pos_mark <- lexbuf.pos;
+ lexbuf.last_char_mark <- lexbuf.last_char;
+ Sedlexing.mark lexbuf.buf p
+
+let backtrack lexbuf =
+ lexbuf.pos <- lexbuf.pos_mark;
+ lexbuf.last_char <- lexbuf.last_char_mark;
+ Sedlexing.backtrack lexbuf.buf
+
+let start lexbuf =
+ lexbuf.pos_mark <- lexbuf.pos;
+ lexbuf.last_char_mark <- lexbuf.last_char;
+ Sedlexing.start lexbuf.buf
+
+(** location of next character *)
+let next_loc lexbuf = { lexbuf.pos with pos_cnum = lexbuf.pos.pos_cnum + 1 }
+
+let cr = Char.code '\r'
+
+(** next character *)
+let next lexbuf =
+ let c = Sedlexing.next lexbuf.buf in
+ let pos = next_loc lexbuf in
+ let ch =
+ match c with
+ | None -> None
+ | Some c -> ( try Some (Uchar.to_char c) with Invalid_argument _ -> None )
+ in
+ ( match ch with
+ | Some '\r' ->
+ lexbuf.pos <-
+ { pos with pos_bol = pos.pos_cnum - 1; pos_lnum = pos.pos_lnum + 1 }
+ | Some '\n' when not (lexbuf.last_char = Some cr) ->
+ lexbuf.pos <-
+ { pos with pos_bol = pos.pos_cnum - 1; pos_lnum = pos.pos_lnum + 1 }
+ | Some '\n' -> ()
+ | _ -> lexbuf.pos <- pos );
+ ( match c with
+ | None -> lexbuf.last_char <- None
+ | Some c -> lexbuf.last_char <- Some (Uchar.to_int c) );
+ c
+
+let raw lexbuf = Sedlexing.lexeme lexbuf.buf
+
+let latin1 ?(skip = 0) ?(drop = 0) lexbuf =
+ let len = Sedlexing.lexeme_length lexbuf.buf - skip - drop in
+ Sedlexing.Latin1.sub_lexeme lexbuf.buf skip len
+
+let utf8 ?(skip = 0) ?(drop = 0) lexbuf =
+ let len = Sedlexing.lexeme_length lexbuf.buf - skip - drop in
+ Sedlexing.Utf8.sub_lexeme lexbuf.buf skip len
+
+let container_lnum_ref = ref 0
+
+let fix_loc loc =
+ let fix_pos pos =
+ (* It looks like lex_buffer.ml returns a position with 2 extra
+ * chars for parsed lines after the first one. Bug? *)
+ let pos_cnum =
+ if pos.Lexing.pos_lnum > !container_lnum_ref then pos.Lexing.pos_cnum - 2
+ else pos.Lexing.pos_cnum
+ in
+ { pos with Lexing.pos_cnum }
+ in
+ let loc_start = fix_pos loc.Location.loc_start in
+ let loc_end = fix_pos loc.Location.loc_end in
+ { loc with Location.loc_start; loc_end }
+
+let make_loc ?(loc_ghost = false) start_pos end_pos : Location.t =
+ { Location.loc_start = start_pos; loc_end = end_pos; loc_ghost }
+
+let make_loc_and_fix ?(loc_ghost = false) start_pos end_pos : Location.t =
+ make_loc ~loc_ghost start_pos end_pos |> fix_loc
diff --git a/css/lib/lexer.ml b/css/lib/lexer.ml
new file mode 100755
index 0000000..9185acc
--- /dev/null
+++ b/css/lib/lexer.ml
@@ -0,0 +1,351 @@
+(** CSS lexer.
+ * Reference:
+ * https://www.w3.org/TR/css-syntax-3/
+ * https://github.com/yahoo/css-js/blob/master/src/l/css.3.l *)
+
+module Sedlexing = Lex_buffer
+
+exception LexingError of (Lexing.position * string)
+(** Signals a lexing error at the provided source location. *)
+
+exception
+ ParseError of (Menhir_parser.token * Lexing.position * Lexing.position)
+(** Signals a parsing error at the provided token and its start and end
+ * locations. *)
+
+exception GrammarError of (string * Location.t)
+(** Signals a grammar error at the provided location. *)
+
+let position_to_string pos =
+ Printf.sprintf "[%d,%d+%d]" pos.Lexing.pos_lnum pos.Lexing.pos_bol
+ (pos.Lexing.pos_cnum - pos.Lexing.pos_bol)
+
+let location_to_string loc =
+ Printf.sprintf "%s..%s"
+ (position_to_string loc.Location.loc_start)
+ (position_to_string loc.Location.loc_end)
+
+let dimension_to_string = function
+ | Types.Length -> "length"
+ | Angle -> "angle"
+ | Time -> "time"
+ | Frequency -> "frequency"
+
+let token_to_string = function
+ | Menhir_parser.EOF -> "EOF"
+ | LEFT_BRACE -> "{"
+ | RIGHT_BRACE -> "}"
+ | LEFT_PAREN -> "("
+ | RIGHT_PAREN -> ")"
+ | LEFT_BRACKET -> "["
+ | RIGHT_BRACKET -> "]"
+ | COLON -> ":"
+ | DOT -> "."
+ (* Whitespaces are detected only in selectors, before ":", ".", and "#", to
+ * disambiguate between "p :first-child" and "p:first-child", these
+ * whitespaces are replaced with "*" *)
+ | WHITESPACE -> "*"
+ | SEMI_COLON -> ";"
+ | PERCENTAGE -> "%"
+ | IMPORTANT -> "!important"
+ | IDENT s -> "IDENT(" ^ s ^ ")"
+ | STRING s -> "STRING(" ^ s ^ ")"
+ | URI s -> "URI(" ^ s ^ ")"
+ | OPERATOR s -> "OPERATOR(" ^ s ^ ")"
+ | DELIM s -> "DELIM(" ^ s ^ ")"
+ | NESTED_AT_RULE s -> "NESTED_AT_RULE(" ^ s ^ ")"
+ | AT_RULE_WITHOUT_BODY s -> "AT_RULE_WITHOUT_BODY(" ^ s ^ ")"
+ | AT_RULE s -> "AT_RULE(" ^ s ^ ")"
+ | FUNCTION s -> "FUNCTION(" ^ s ^ ")"
+ | HASH s -> "HASH(" ^ s ^ ")"
+ | NUMBER s -> "NUMBER(" ^ s ^ ")"
+ | UNICODE_RANGE s -> "UNICODE_RANGE(" ^ s ^ ")"
+ | FLOAT_DIMENSION (n, s, d) ->
+ "FLOAT_DIMENSION(" ^ n ^ ", " ^ s ^ ", " ^ dimension_to_string d ^ ")"
+ | DIMENSION (n, d) -> "DIMENSION(" ^ n ^ ", " ^ d ^ ")"
+
+let () =
+ Location.register_error_of_exn (function
+ | LexingError (pos, msg) ->
+ let loc = Lex_buffer.make_loc_and_fix pos pos in
+ Some (Location.error ~loc msg)
+ | ParseError (token, start_pos, end_pos) ->
+ let loc = Lex_buffer.make_loc_and_fix start_pos end_pos in
+ let msg =
+ Printf.sprintf "Parse error while reading token '%s'"
+ (token_to_string token)
+ in
+ Some (Location.error ~loc msg)
+ | GrammarError (msg, loc) -> Some (Location.error ~loc msg)
+ | _ -> None)
+
+(* Regexes *)
+let newline = [%sedlex.regexp? '\n' | "\r\n" | '\r' | '\012']
+
+let white_space = [%sedlex.regexp? " " | '\t' | newline]
+
+let ws = [%sedlex.regexp? Star white_space]
+
+let hex_digit = [%sedlex.regexp? '0' .. '9' | 'a' .. 'f' | 'A' .. 'F']
+
+let digit = [%sedlex.regexp? '0' .. '9']
+
+let non_ascii = [%sedlex.regexp? '\160' .. '\255']
+
+let up_to_6_hex_digits = [%sedlex.regexp? Rep (hex_digit, 1 .. 6)]
+
+let unicode = [%sedlex.regexp? '\\', up_to_6_hex_digits, Opt white_space]
+
+let unicode_range =
+ [%sedlex.regexp?
+ ( Rep ((hex_digit | '?'), 1 .. 6)
+ | up_to_6_hex_digits, '-', up_to_6_hex_digits )]
+
+let escape =
+ [%sedlex.regexp? unicode | '\\', Compl ('\r' | '\n' | '\012' | hex_digit)]
+
+let ident_start =
+ [%sedlex.regexp? '_' | 'a' .. 'z' | 'A' .. 'Z' | non_ascii | escape]
+
+let ident_char =
+ [%sedlex.regexp?
+ '_' | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | non_ascii | escape]
+
+let ident = [%sedlex.regexp? (Opt '-', ident_start | '-', '-'), Star ident_char]
+
+let string_quote =
+ [%sedlex.regexp?
+ '"', Star (Compl ('\n' | '\r' | '\012' | '"') | '\\', newline | escape), '"']
+
+let string_apos =
+ [%sedlex.regexp?
+ ( '\'',
+ Star (Compl ('\n' | '\r' | '\012' | '\'') | '\\', newline | escape),
+ '\'' )]
+
+let string = [%sedlex.regexp? string_quote | string_apos]
+
+let name = [%sedlex.regexp? Plus ident_char]
+
+let number =
+ [%sedlex.regexp?
+ ( ( Opt ('+' | '-'),
+ Plus digit,
+ Opt ('.', Plus digit),
+ Opt (('e' | 'E'), ('+' | '-'), Plus digit) )
+ | ( Opt ('+' | '-'),
+ '.',
+ Plus digit,
+ Opt (('e' | 'E'), ('+' | '-'), Plus digit) ) )]
+
+let non_printable =
+ [%sedlex.regexp? '\x00' .. '\x08' | '\x0B' | '\x0E' .. '\x1F' | '\x7F']
+
+let url_unquoted =
+ [%sedlex.regexp?
+ Star (Compl ('"' | '\'' | '(' | ')' | '\\' | non_printable) | escape)]
+
+let url = [%sedlex.regexp? url_unquoted | string]
+
+let operator = [%sedlex.regexp? "~=" | "|=" | "^=" | "$=" | "*=" | "||"]
+
+let at_rule = [%sedlex.regexp? "@", ident]
+
+let at_rule_without_body =
+ [%sedlex.regexp? "@", ("charset" | "import" | "namespace")]
+
+let vendor_prefix = [%sedlex.regexp? "-webkit-" | "-moz-" | "-o-" | "-ms-"]
+
+let nested_at_rule =
+ [%sedlex.regexp?
+ ( "@",
+ ( "document" | "keyframes"
+ | vendor_prefix, "keyframes"
+ | "media" | "supports" | "scope" ) )]
+
+let _a = [%sedlex.regexp? 'A' | 'a']
+
+let _b = [%sedlex.regexp? 'B' | 'b']
+
+let _c = [%sedlex.regexp? 'C' | 'c']
+
+let _d = [%sedlex.regexp? 'D' | 'd']
+
+let _e = [%sedlex.regexp? 'e' | 'E']
+
+let _f = [%sedlex.regexp? 'F' | 'f']
+
+let _g = [%sedlex.regexp? 'G' | 'g']
+
+let _h = [%sedlex.regexp? 'H' | 'h']
+
+let _i = [%sedlex.regexp? 'I' | 'i']
+
+let _j = [%sedlex.regexp? 'J' | 'j']
+
+let _k = [%sedlex.regexp? 'K' | 'k']
+
+let _l = [%sedlex.regexp? 'L' | 'l']
+
+let _m = [%sedlex.regexp? 'M' | 'm']
+
+let _n = [%sedlex.regexp? 'N' | 'n']
+
+let _o = [%sedlex.regexp? 'O' | 'o']
+
+let _p = [%sedlex.regexp? 'P' | 'p']
+
+let _q = [%sedlex.regexp? 'Q' | 'q']
+
+let _r = [%sedlex.regexp? 'R' | 'r']
+
+let _s = [%sedlex.regexp? 'S' | 's']
+
+let _t = [%sedlex.regexp? 'T' | 't']
+
+let _u = [%sedlex.regexp? 'U' | 'u']
+
+let _v = [%sedlex.regexp? 'V' | 'v']
+
+let _w = [%sedlex.regexp? 'W' | 'w']
+
+let _x = [%sedlex.regexp? 'X' | 'x']
+
+let _y = [%sedlex.regexp? 'Y' | 'y']
+
+let _z = [%sedlex.regexp? 'Z' | 'z']
+
+let important = [%sedlex.regexp? "!", ws, _i, _m, _p, _o, _r, _t, _a, _n, _t]
+
+let length =
+ [%sedlex.regexp?
+ ( _c, _a, _p
+ | _c, _h
+ | _e, _m
+ | _e, _x
+ | _i, _c
+ | _l, _h
+ | _r, _e, _m
+ | _r, _l, _h
+ | _v, _h
+ | _v, _w
+ | _v, _i
+ | _v, _b
+ | _v, _m, _i, _n
+ | _v, _m, _a, _x
+ | _c, _m
+ | _m, _m
+ | _q
+ | _i, _n
+ | _p, _c
+ | _p, _t
+ | _p, _x )]
+
+let angle =
+ [%sedlex.regexp? _d, _e, _g | _g, _r, _a, _d | _r, _a, _d | _t, _u, _r, _n]
+
+let time = [%sedlex.regexp? _s | _m, _s]
+
+let frequency = [%sedlex.regexp? _h, _z | _k, _h, _z]
+
+(* Returns true if white spaces were discarded *)
+let discard_comments_and_white_spaces buf =
+ let rec discard_white_spaces buf spaces_detected =
+ match%sedlex buf with
+ | Plus white_space -> discard_white_spaces buf true
+ | "/*" -> discard_comments buf spaces_detected
+ | _ -> spaces_detected
+ and discard_comments buf spaces_detected =
+ match%sedlex buf with
+ | eof ->
+ raise (LexingError (buf.Lex_buffer.pos, "Unterminated comment at EOF"))
+ | "*/" -> discard_white_spaces buf spaces_detected
+ | any -> discard_comments buf spaces_detected
+ | _ -> assert false
+ in
+ discard_white_spaces buf false
+
+let rec get_next_tokens buf spaces_detected =
+ let open Menhir_parser in
+ match%sedlex buf with
+ | eof -> [ EOF ]
+ | ';' -> [ SEMI_COLON ]
+ | '}' -> [ RIGHT_BRACE ]
+ | '{' -> [ LEFT_BRACE ]
+ | ':' -> if spaces_detected then [ WHITESPACE; COLON ] else [ COLON ]
+ | '.' -> if spaces_detected then [ WHITESPACE; DOT ] else [ DOT ]
+ | '(' -> [ LEFT_PAREN ]
+ | ')' -> [ RIGHT_PAREN ]
+ | '[' -> [ LEFT_BRACKET ]
+ | ']' -> [ RIGHT_BRACKET ]
+ | '%' -> [ PERCENTAGE ]
+ | operator -> [ OPERATOR (Lex_buffer.latin1 buf) ]
+ | string -> [ STRING (Lex_buffer.latin1 ~skip:1 ~drop:1 buf) ]
+ | "url(" -> [ get_url "" buf ]
+ | important -> [ IMPORTANT ]
+ | nested_at_rule -> [ NESTED_AT_RULE (Lex_buffer.latin1 ~skip:1 buf) ]
+ | at_rule_without_body ->
+ [ AT_RULE_WITHOUT_BODY (Lex_buffer.latin1 ~skip:1 buf) ]
+ | at_rule -> [ AT_RULE (Lex_buffer.latin1 ~skip:1 buf) ]
+ (* NOTE: should be placed above ident, otherwise pattern with
+ * '-[0-9a-z]{1,6}' cannot be matched *)
+ | _u, '+', unicode_range -> [ UNICODE_RANGE (Lex_buffer.latin1 buf) ]
+ | ident, '(' -> [ FUNCTION (Lex_buffer.latin1 ~drop:1 buf) ]
+ | ident -> [ IDENT (Lex_buffer.latin1 buf) ]
+ | '#', name ->
+ if spaces_detected then
+ [ WHITESPACE; HASH (Lex_buffer.latin1 ~skip:1 buf) ]
+ else [ HASH (Lex_buffer.latin1 ~skip:1 buf) ]
+ | number -> [ get_dimension (Lex_buffer.latin1 buf) buf ]
+ | any -> [ DELIM (Lex_buffer.latin1 buf) ]
+ | _ -> assert false
+
+and get_dimension n buf =
+ match%sedlex buf with
+ | length -> FLOAT_DIMENSION (n, Lex_buffer.latin1 buf, Types.Length)
+ | angle -> FLOAT_DIMENSION (n, Lex_buffer.latin1 buf, Types.Angle)
+ | time -> FLOAT_DIMENSION (n, Lex_buffer.latin1 buf, Types.Time)
+ | frequency -> FLOAT_DIMENSION (n, Lex_buffer.latin1 buf, Types.Frequency)
+ | ident -> DIMENSION (n, Lex_buffer.latin1 buf)
+ | _ -> NUMBER n
+
+and get_url url buf =
+ match%sedlex buf with
+ | ws -> get_url url buf
+ | url -> get_url (Lex_buffer.latin1 buf) buf
+ | ")" -> URI url
+ | eof -> raise (LexingError (buf.Lex_buffer.pos, "Incomplete URI"))
+ | any ->
+ raise
+ (LexingError
+ ( buf.Lex_buffer.pos,
+ "Unexpected token: " ^ Lex_buffer.latin1 buf ^ " parsing an URI" ))
+ | _ -> assert false
+
+let token_queue = Queue.create ()
+
+let queue_next_tokens_with_location buf =
+ let spaces_detected = discard_comments_and_white_spaces buf in
+ let loc_start = Lex_buffer.next_loc buf in
+ let tokens = get_next_tokens buf spaces_detected in
+ let loc_end = Lex_buffer.next_loc buf in
+ List.iter (fun t -> Queue.add (t, loc_start, loc_end) token_queue) tokens
+
+let parse buf p =
+ let last_token =
+ ref (Menhir_parser.EOF, Lexing.dummy_pos, Lexing.dummy_pos)
+ in
+ let next_token () =
+ if Queue.is_empty token_queue then queue_next_tokens_with_location buf;
+ last_token := Queue.take token_queue;
+ !last_token
+ in
+ try MenhirLib.Convert.Simplified.traditional2revised p next_token with
+ | LexingError _ as e -> raise e
+ | _ -> raise (ParseError !last_token)
+
+let parse_string ?container_lnum ?pos s p =
+ (match container_lnum with
+ | None -> ()
+ | Some lnum -> Lex_buffer.container_lnum_ref := lnum);
+ parse (Lex_buffer.of_ascii_string ?pos s) p
diff --git a/css/lib/location.ml b/css/lib/location.ml
new file mode 100755
index 0000000..23e9c49
--- /dev/null
+++ b/css/lib/location.ml
@@ -0,0 +1,19 @@
+type t = {
+
+ loc_start : Lexing.position;
+ loc_end : Lexing.position;
+ loc_ghost : bool;
+}
+
+let none =
+ { loc_start = Lexing.dummy_pos
+ ; loc_end = Lexing.dummy_pos
+ ; loc_ghost = true
+ }
+
+let register_error_of_exn _ = ()
+
+let error ~loc ?(sub=[]) _ =
+ let _ = loc
+ and _ = sub in
+ ()
diff --git a/css/lib/menhir_parser.mly b/css/lib/menhir_parser.mly
new file mode 100755
index 0000000..fb5a1cf
--- /dev/null
+++ b/css/lib/menhir_parser.mly
@@ -0,0 +1,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 }
+ ;
diff --git a/css/lib/parser.ml b/css/lib/parser.ml
new file mode 100755
index 0000000..1b4a5e7
--- /dev/null
+++ b/css/lib/parser.ml
@@ -0,0 +1,5 @@
+let parse_stylesheet ?container_lnum ?pos css =
+ Lexer.parse_string ?container_lnum ?pos css Menhir_parser.stylesheet
+
+let parse_declaration_list ?container_lnum ?pos css =
+ Lexer.parse_string ?container_lnum ?pos css Menhir_parser.declaration_list
diff --git a/css/lib/parser.mli b/css/lib/parser.mli
new file mode 100755
index 0000000..3ddb9ae
--- /dev/null
+++ b/css/lib/parser.mli
@@ -0,0 +1,8 @@
+val parse_stylesheet :
+ ?container_lnum:int -> ?pos:Lexing.position -> string -> Types.Stylesheet.t
+
+val parse_declaration_list :
+ ?container_lnum:int ->
+ ?pos:Lexing.position ->
+ string ->
+ Types.Declaration_list.t
diff --git a/css/lib/types.ml b/css/lib/types.ml
new file mode 100755
index 0000000..8767fdf
--- /dev/null
+++ b/css/lib/types.ml
@@ -0,0 +1,76 @@
+type 'a with_loc = 'a * Location.t
+
+type dimension = Length | Angle | Time | Frequency
+
+module rec Component_value : sig
+ type t =
+ | Paren_block of t with_loc list
+ | Bracket_block of t with_loc list
+ | Percentage of string
+ | Ident of string
+ | String of string
+ | Uri of string
+ | Operator of string
+ | Delim of string
+ | Function of string with_loc * t with_loc list with_loc
+ | Hash of string
+ | Number of string
+ | Unicode_range of string
+ | Float_dimension of (string * string * dimension)
+ | Dimension of (string * string)
+end =
+ Component_value
+
+and Brace_block : sig
+ type t =
+ | Empty
+ | Declaration_list of Declaration_list.t
+ | Stylesheet of Stylesheet.t
+end =
+ Brace_block
+
+and At_rule : sig
+ type t = {
+ name : string with_loc;
+ prelude : Component_value.t with_loc list with_loc;
+ block : Brace_block.t;
+ loc : Location.t;
+ }
+end =
+ At_rule
+
+and Declaration : sig
+ type t = {
+ name : string with_loc;
+ value : Component_value.t with_loc list with_loc;
+ important : bool with_loc;
+ loc : Location.t;
+ }
+end =
+ Declaration
+
+and Declaration_list : sig
+ type kind = Declaration of Declaration.t | At_rule of At_rule.t
+
+ type t = kind list with_loc
+end =
+ Declaration_list
+
+and Style_rule : sig
+ type t = {
+ prelude : Component_value.t with_loc list with_loc;
+ block : Declaration_list.t;
+ loc : Location.t;
+ }
+end =
+ Style_rule
+
+and Rule : sig
+ type t = Style_rule of Style_rule.t | At_rule of At_rule.t
+end =
+ Rule
+
+and Stylesheet : sig
+ type t = Rule.t list with_loc
+end =
+ Stylesheet
diff --git a/css/lib/types.mli b/css/lib/types.mli
new file mode 100755
index 0000000..94b0ea1
--- /dev/null
+++ b/css/lib/types.mli
@@ -0,0 +1,68 @@
+type 'a with_loc = 'a * Location.t
+
+type dimension = Length | Angle | Time | Frequency
+
+module rec Component_value : sig
+ type t =
+ | Paren_block of t with_loc list
+ | Bracket_block of t with_loc list
+ | Percentage of string
+ | Ident of string
+ | String of string
+ | Uri of string
+ | Operator of string
+ | Delim of string
+ | Function of string with_loc * t with_loc list with_loc
+ | Hash of string
+ | Number of string
+ | Unicode_range of string
+ | Float_dimension of (string * string * dimension)
+ | Dimension of (string * string)
+end
+
+and Brace_block : sig
+ type t =
+ | Empty
+ | Declaration_list of Declaration_list.t
+ | Stylesheet of Stylesheet.t
+end
+
+and At_rule : sig
+ type t = {
+ name : string with_loc;
+ prelude : Component_value.t with_loc list with_loc;
+ block : Brace_block.t;
+ loc : Location.t;
+ }
+end
+
+and Declaration : sig
+ type t = {
+ name : string with_loc;
+ value : Component_value.t with_loc list with_loc;
+ important : bool with_loc;
+ loc : Location.t;
+ }
+end
+
+and Declaration_list : sig
+ type kind = Declaration of Declaration.t | At_rule of At_rule.t
+
+ type t = kind list with_loc
+end
+
+and Style_rule : sig
+ type t = {
+ prelude : Component_value.t with_loc list with_loc;
+ block : Declaration_list.t;
+ loc : Location.t;
+ }
+end
+
+and Rule : sig
+ type t = Style_rule of Style_rule.t | At_rule of At_rule.t
+end
+
+and Stylesheet : sig
+ type t = Rule.t list with_loc
+end
diff --git a/css/merge_lib/common.ml b/css/merge_lib/common.ml
new file mode 100755
index 0000000..48c1b1f
--- /dev/null
+++ b/css/merge_lib/common.ml
@@ -0,0 +1,61 @@
+open StdLabels
+open Css.Types
+
+let location_none = Css.Location.none
+
+(** Update the declaration list with this new property if the same property
+ name is already present.
+
+ If not return [None] *)
+let merge_declations
+ : Declaration_list.t -> Declaration_list.kind -> Declaration_list.t option
+ = fun decls1 decl2 ->
+ let declarations, loc = decls1 in
+ let updated, list' =
+ List.fold_left_map declarations
+ ~init:false
+ ~f:(fun res kind ->
+ if Comparator.declaration_kind' kind decl2 = 0 then
+ true, decl2
+ else
+ res, kind)
+ in
+ match updated with
+ | false -> None
+ | _ -> Some
+ ( list'
+ , loc )
+
+(** Add all the declarations from [decl2] into the list [decl1]
+ and return the list, and all the new declarations to add *)
+let add_all_declarations
+ : Declaration_list.t -> Declaration_list.t -> Declaration_list.t * Declaration_list.t
+ = fun decls1 (decls2, loc2) ->
+
+ let decls1, remain' = List.fold_left decls2
+ ~init:(decls1, [])
+ ~f:(fun (decls1, remain) new_declaration ->
+ match merge_declations decls1 new_declaration with
+ (* TODO : Handle empty property as None *)
+ | None -> decls1, (Some new_declaration::remain)
+ | Some decls1 -> decls1, remain
+ ) in
+ (* Remove all the unused properties *)
+ let remain' = List.filter_map ~f:(fun x -> x) remain' in
+ ( decls1
+ , (remain', loc2) )
+
+
+let update_declarations
+ : (Declaration_list.t * Css.Location.t) -> (Declaration_list.t * Css.Location.t) list -> (Declaration_list.t * Css.Location.t) list
+ = fun (block, loc) existing ->
+ let remain, tl = List.fold_left
+ existing
+ ~init:(block, [])
+ ~f:(fun (block, prev) (declarations, location) ->
+
+ let update, remain = add_all_declarations declarations block in
+ remain, (update, location)::prev) in
+ match fst remain with
+ | [] -> tl
+ | other -> (((other, loc), loc)::tl)
diff --git a/css/merge_lib/comparator.ml b/css/merge_lib/comparator.ml
new file mode 100755
index 0000000..a7b1c09
--- /dev/null
+++ b/css/merge_lib/comparator.ml
@@ -0,0 +1,160 @@
+open Css.Types
+open StdLabels
+
+(** The module Comparator helps to compare two stylesheet together. *)
+
+(** Compare two list in a safe way *)
+let compare_list
+ : ('a -> 'a -> int) -> 'a list -> 'a list -> int
+ = fun cmp l1 l2 ->
+ let length = List.compare_lengths l1 l2 in
+ if length <> 0 then
+ length
+ else
+ List.fold_left2
+ ~f:(fun res v1 v2 ->
+ if res <> 0 then res
+ else cmp v1 v2
+ )
+ ~init:0
+ l1 l2
+
+(** Compare each component without the loccation information *)
+let rec component_value
+ : Component_value.t with_loc -> Component_value.t with_loc -> int
+ = fun v1 v2 ->
+ let open Component_value in
+ match (fst v1), (fst v2) with
+ | Paren_block b1, Paren_block b2
+ | Bracket_block b1, Bracket_block b2 ->
+ compare_list
+ component_value
+ b1 b2
+ | Percentage v1, Percentage v2
+ | Ident v1, Ident v2
+ | String v1, String v2
+ | Uri v1, Uri v2
+ | Operator v1, Operator v2
+ | Delim v1, Delim v2
+ | Hash v1, Hash v2
+ | Number v1, Number v2
+ | Unicode_range v1, Unicode_range v2 ->
+ String.compare v1 v2
+ | Float_dimension v1, Float_dimension v2 ->
+ Stdlib.compare v1 v2
+ | Dimension v1, Dimension v2 ->
+ Stdlib.compare v1 v2
+
+ | Function (n1, v1), Function (n2, v2) ->
+ let name1 = fst (n1)
+ and name2 = fst (n2) in
+ let cmp = String.compare name1 name2 in
+ if cmp <> 0 then cmp
+ else
+ compare_list
+ component_value
+ (fst v1) (fst v2)
+ | v1, v2 -> Stdlib.compare v1 v2
+
+let rec brace_block
+ : Brace_block.t -> Brace_block.t -> int
+ = fun v1 v2 ->
+ match v1, v2 with
+ | Declaration_list l1, Declaration_list l2 -> declaration_list l1 l2
+ | Stylesheet s1, Stylesheet s2 -> style_sheet s1 s2
+ | _, _ -> Stdlib.compare v1 v2
+
+and at_rule
+ : At_rule.t -> At_rule.t -> int
+ = fun v1 v2 ->
+ let cmp = String.compare (fst v1.name) (fst v2.name) in
+ if cmp <> 0 then cmp
+ else
+ let cmp =
+ compare_list
+ component_value
+ (fst v1.prelude) (fst v2.prelude)
+ in
+ if cmp <> 0 then cmp
+ else
+ brace_block v1.block v2.block
+
+and declaration
+ : Declaration.t -> Declaration.t -> int
+ = fun v1 v2 ->
+ let cmp = String.compare (fst v1.name) (fst v2.name) in
+ if cmp <> 0 then cmp
+ else
+ let cmp = Stdlib.compare (fst v1.important) (fst v2.important) in
+ if cmp <> 0 then cmp
+ else
+ compare_list
+ component_value
+ (fst v1.value) (fst v2.value)
+
+and declaration_kind
+ : Declaration_list.kind -> Declaration_list.kind -> int
+ = fun v1 v2 ->
+ match v1, v2 with
+ | Declaration v1, Declaration v2 -> declaration v1 v2
+ | At_rule v1, At_rule v2 -> at_rule v1 v2
+ | _, _ -> Stdlib.compare v1 v2
+
+and declaration_list
+ : Declaration_list.t -> Declaration_list.t -> int
+ = fun v1 v2 ->
+ compare_list
+ declaration_kind
+ (fst v1) (fst v2)
+
+and style_rule
+ : Style_rule.t -> Style_rule.t -> int
+ = fun v1 v2 ->
+ let cmp = declaration_list v1.block v2.block in
+ if cmp <> 0 then
+ cmp
+ else
+ compare_list
+ component_value
+ (fst v1.prelude) (fst v2.prelude)
+
+and rule
+ : Rule.t -> Rule.t -> int
+ = fun v1 v2 ->
+ begin match v1, v2 with
+ | Style_rule v1, Style_rule v2 -> style_rule v1 v2
+ | At_rule v1, At_rule v2 -> at_rule v1 v2
+ | _, _ -> Stdlib.compare v1 v2
+ end
+
+and style_sheet
+ : Stylesheet.t -> Stylesheet.t -> int
+ = fun v1 v2 ->
+ compare_list rule (fst v1) (fst v2)
+
+(** Compare two rules by name only *)
+let at_rule'
+ : At_rule.t -> At_rule.t -> int
+ = fun v1 v2 ->
+ let cmp = String.compare (fst v1.name) (fst v2.name) in
+ if cmp <> 0 then
+ cmp
+ else
+ compare_list
+ component_value
+ (fst v1.prelude) (fst v2.prelude)
+
+(** Compare two declarations by name only *)
+let declaration'
+ : Declaration.t -> Declaration.t -> int
+ = fun v1 v2 ->
+ String.compare (fst v1.name) (fst v2.name)
+
+(** Compare two declaration_kind by name only *)
+let declaration_kind'
+ : Declaration_list.kind -> Declaration_list.kind -> int
+ = fun v1 v2 ->
+ match v1, v2 with
+ | Declaration v1, Declaration v2 -> declaration' v1 v2
+ | At_rule v1, At_rule v2 -> at_rule' v1 v2
+ | _, _ -> Stdlib.compare v1 v2
diff --git a/css/merge_lib/css_lib.ml b/css/merge_lib/css_lib.ml
new file mode 100755
index 0000000..dbd689d
--- /dev/null
+++ b/css/merge_lib/css_lib.ml
@@ -0,0 +1,5 @@
+(** Merge CSS *)
+module Merge = Merge
+
+(** Print CSS *)
+module Print = Print
diff --git a/css/merge_lib/dune b/css/merge_lib/dune
new file mode 100755
index 0000000..e6748cd
--- /dev/null
+++ b/css/merge_lib/dune
@@ -0,0 +1,6 @@
+(library
+ (name css_lib)
+ (libraries
+ Css
+ )
+)
diff --git a/css/merge_lib/merge.ml b/css/merge_lib/merge.ml
new file mode 100755
index 0000000..af95298
--- /dev/null
+++ b/css/merge_lib/merge.ml
@@ -0,0 +1,138 @@
+open StdLabels
+open Css.Types
+
+module AtRule = Map.Make(struct
+ type t = string * (Component_value.t list)
+ let compare at1 at2 =
+
+ let cmp = String.compare (fst at1) (fst at2) in
+ if cmp <> 0 then cmp
+ else
+ Comparator.compare_list (fun l1 l2 ->
+ Comparator.component_value
+ (l1, Common.location_none)
+ (l2, Common.location_none) )
+ (snd at1)
+ (snd at2)
+ end)
+
+type at_type =
+ | Empty
+ | Declaration of (Declaration_list.t * Css.Location.t) list
+ | Stylesheet of (Merge_style.t * ats)
+
+and at_map_content = (Css.Location.t * at_type)
+
+and ats = at_map_content AtRule.t
+
+type t = Merge_style.t * ats
+
+let rec add_brace_block
+ : Brace_block.t -> Css.Location.t -> at_map_content option -> at_map_content option
+ = fun block loc value ->
+
+ begin match block, value with
+ (* Empty element, update the existing one if any *)
+ | Brace_block.Empty, _ ->
+ Some
+ ( loc
+ , Empty )
+
+ (* New declarationList, juste add it *)
+ | Brace_block.Declaration_list decls, None ->
+ Some
+ ( loc
+ , Declaration [(decls, loc)])
+
+ | Brace_block.Declaration_list decls, (Some (loc, Declaration decl2)) ->
+ Some
+ ( loc
+ , Declaration (Common.update_declarations
+ (decls, Common.location_none) decl2 ))
+
+ | Brace_block.Stylesheet s, None ->
+ let eval = add_css (Merge_style.empty, AtRule.empty) s in
+ Some
+ ( loc
+ , Stylesheet eval )
+
+ | Brace_block.Stylesheet s, Some (loc, Stylesheet css) ->
+ let eval = add_css css s in
+ Some
+ ( loc
+ , Stylesheet eval )
+
+ (* Othe cases are not handled *)
+ | _ -> None
+ end
+
+(** Add a new @ definition *)
+and add_at
+ : Css.Types.At_rule.t -> ats -> ats
+ = fun {name; prelude; block; loc} map ->
+
+ let prelude = List.map (fst prelude) ~f:fst in
+ let key = (fst name), prelude in
+ AtRule.update key
+ (add_brace_block block loc)
+ map
+
+and add_css
+ : t -> Stylesheet.t -> t
+ = fun (styles, atrules) css ->
+ List.fold_left (fst css)
+ ~init:(styles, atrules)
+ ~f:(fun (styles, ats)-> function
+ | Rule.At_rule r -> (styles, add_at r ats)
+ | Rule.Style_rule r -> (Merge_style.add_style r styles, ats))
+
+(** Helper function for retrieving the location *)
+let get_loc
+ : Rule.t -> Css.Location.t
+ = function
+ | Rule.Style_rule t -> t.Style_rule.loc
+ | Rule.At_rule t -> t.At_rule.loc
+
+let rec extract_at
+ : ats -> Css.Types.Rule.t Seq.t
+ = fun map ->
+ AtRule.to_seq map
+ |> Seq.map (fun ((name, prelude), (loc, value)) ->
+
+ let name = name, loc
+ and prelude = List.map ~f:(fun x -> x, loc) prelude, loc in
+
+ match value with
+ | Stylesheet css ->
+
+ let stylesheet = extract_css css in
+ let block = Brace_block.Stylesheet stylesheet in
+ (Rule.At_rule (At_rule.{name; prelude; block; loc}))
+ | Empty ->
+ let block = Brace_block.Empty in
+ (Rule.At_rule (At_rule.{name; prelude; block; loc}))
+
+ | Declaration decls ->
+ let declarations = List.fold_left decls
+ ~init:[]
+ ~f:(fun acc (decl, _) ->
+ let elems = fst decl in
+ List.append elems acc) in
+ let block = Brace_block.Declaration_list (declarations, loc) in
+ (Rule.At_rule (At_rule.{name; prelude; block; loc})))
+
+and extract_css
+ : t -> Stylesheet.t
+ = fun (styles, ats) ->
+ let arr =
+ Seq.append
+ (extract_at ats)
+ (Merge_style.extract_style styles)
+ |> Array.of_seq in
+ (* Sort the declaration in initial ordering (using the location attribute) *)
+ Array.fast_sort ~cmp:(fun v1 v2 -> Stdlib.compare (get_loc v1) (get_loc v2) ) arr;
+ (Array.to_list arr, Common.location_none)
+
+let empty
+ : t
+ = Merge_style.empty, AtRule.empty
diff --git a/css/merge_lib/merge.mli b/css/merge_lib/merge.mli
new file mode 100755
index 0000000..2fa9254
--- /dev/null
+++ b/css/merge_lib/merge.mli
@@ -0,0 +1,10 @@
+type t
+
+val empty
+ : t
+
+val add_css
+ : t -> Css.Types.Stylesheet.t -> t
+
+val extract_css
+ : t -> Css.Types.Stylesheet.t
diff --git a/css/merge_lib/merge_style.ml b/css/merge_lib/merge_style.ml
new file mode 100755
index 0000000..6d8851b
--- /dev/null
+++ b/css/merge_lib/merge_style.ml
@@ -0,0 +1,132 @@
+open StdLabels
+open Css.Types
+
+let delim_coma = ( Component_value.Delim ","
+ , Common.location_none )
+
+module MapRule = Map.Make(struct
+ type t = Component_value.t list
+ let compare =
+ Comparator.compare_list (fun l1 l2 ->
+ Comparator.component_value
+ (l1, Common.location_none)
+ (l2, Common.location_none)
+ )
+ end)
+
+(** The type of the map contains both :
+
+ - The declaration inside the selector
+ - The selector Location
+
+*)
+type t = (Declaration_list.t * Css.Location.t) list MapRule.t
+
+type acc = Component_value.t list * Component_value.t list list
+
+(** Group all the selectors together, using a given delimiter *)
+let group_selector
+ : string -> Component_value.t with_loc list with_loc -> Component_value.t list list
+ = fun delim elems ->
+
+ let add_element
+ : acc -> Component_value.t with_loc -> acc
+ = fun (acc, prev) elem ->
+ match (fst elem) with
+ | Delim s when String.equal s delim -> [], (List.rev acc)::prev
+ | other -> other::acc, prev
+ in
+ let last, prev = List.fold_left
+ (fst elems)
+ ~init:([], [])
+ ~f:add_element in
+ (List.rev last)::prev
+
+(** Add a new style in the map. *)
+let add_style
+ : Style_rule.t -> t -> t
+ = fun {prelude; block; loc} map ->
+ List.fold_left (group_selector "," prelude)
+ ~init:map
+ ~f:(fun map group ->
+ MapRule.update group
+ (function
+ | None ->
+ (* There is no declaration yet, just add this one *)
+ Some [(block, loc)]
+ | Some tl ->
+
+ (* The declaration is already present.
+
+ For each of them, we check if the declaration is overriden
+ by the new one, and update the list.
+
+ The news declarations are added in a new block (a second
+ pass may be necessary to join all the remaining elements
+ together.
+ *)
+ Some (Common.update_declarations (block, loc) tl))
+ map)
+
+module ReversedMapRule = Map.Make(struct
+ type t = Declaration_list.t * Css.Location.t
+
+ (* Use a custom comparaison without the location *)
+ let compare l1 l2 =
+ Comparator.declaration_list
+ (fst l1)
+ (fst l2)
+ end)
+type splitted_rules' = (Component_value.t list list) ReversedMapRule.t
+
+(** Extract all the styles, and return them as a Rule.t sequence *)
+let extract_style
+ : t -> Rule.t Seq.t
+ = fun map ->
+ (* First, iterate all the values and match the identical one together *)
+
+ let table:splitted_rules' =
+ MapRule.fold
+ (fun k values map' ->
+
+ (* Each element may be present multiple times in the declaration. We
+ have te extract each of them *)
+ List.fold_left values
+ ~init:map'
+ ~f:(fun map' (v, loc) ->
+
+ ReversedMapRule.update (v, loc)
+ (function
+ | None -> Some [k]
+ | Some tl -> Some (k::tl))
+ map' ))
+ map
+ ReversedMapRule.empty in
+
+ (* The rebuild the rules *)
+ ReversedMapRule.to_seq table
+ |> Seq.map (fun ((block, loc), k) ->
+
+ let selectors =
+ List.fold_left k
+ ~init:[]
+ ~f:(fun acc v ->
+ let selectors = List.map
+ v
+ ~f:(fun x -> x , Common.location_none) in
+ let tail = List.append selectors acc in
+ delim_coma::tail) in
+
+ let prelude =
+ match selectors with
+ | (Component_value.Delim ",", _)::tl ->
+ (* Remove the first delimiter element *)
+ ( tl
+ , Common.location_none)
+ | _->
+ ( selectors
+ , Common.location_none )
+ in
+ Rule.Style_rule (Style_rule.{prelude; block; loc}))
+
+let empty = MapRule.empty
diff --git a/css/merge_lib/print.ml b/css/merge_lib/print.ml
new file mode 100755
index 0000000..5e48923
--- /dev/null
+++ b/css/merge_lib/print.ml
@@ -0,0 +1,225 @@
+open StdLabels
+open Css.Types
+
+(* Types helpers *)
+
+type ('a, 'b) printer = (Format.formatter -> 'a -> unit) -> 'a -> 'b
+type ('a, 'b) format_printer = (('a, 'b) printer, Format.formatter, unit) format
+
+type style_rule_format = ( Component_value.t with_loc list
+ , (Declaration_list.kind list, unit) printer) format_printer
+type declaration_format= ( Declaration_list.kind list,
+ unit) format_printer
+type stylesheet_format = ( Rule.t list,
+ unit) format_printer
+type at_rule_format = (string ->
+ ( Component_value.t with_loc list
+ , (Brace_block.t, unit) printer) printer, Format.formatter, unit) format
+
+type important_format = (unit, Format.formatter, unit) format
+
+
+type template =
+ { main_css : stylesheet_format
+ ; style_rule : style_rule_format
+ ; declaration : declaration_format
+ ; stylesheet : stylesheet_format
+ ; at_rule : at_rule_format
+ ; important : important_format
+ }
+
+let pp_sep_column formater () = Format.fprintf formater ";@,"
+
+let pretty_printer =
+ { main_css = Stdlib.format_of_string "@[<v>%a@]@."
+ ; style_rule = Stdlib.format_of_string "%a {@;<1 1>@[<v>%a@]@,}@,"
+ ; declaration = Stdlib.format_of_string "{@;<1 1>@[<v>%a@]@,}@,"
+ ; stylesheet = Stdlib.format_of_string "{@;<1 1>@[<v>%a@]@,}@,"
+ ; at_rule = Stdlib.format_of_string "@%s%a%a@,"
+ ; important = Stdlib.format_of_string " !important"
+ }
+
+let minify_printer =
+ { main_css = Stdlib.format_of_string "@[<h>%a@]@."
+ ; style_rule = Stdlib.format_of_string "%a{%a}"
+ ; declaration = Stdlib.format_of_string " {%a}"
+ ; stylesheet = Stdlib.format_of_string " {%a}"
+ ; at_rule = Stdlib.format_of_string "@%s%a%a"
+ ; important = Stdlib.format_of_string "!important"
+ }
+
+type sep_printer
+ = Format.formatter -> bool -> unit
+
+let print_space
+ : sep_printer
+ = fun formatter -> function
+ | true -> Format.fprintf formatter " "
+ | false -> ()
+
+let print_coma
+ : sep_printer
+ = fun formatter -> function
+ | true -> Format.fprintf formatter ","
+ | false -> ()
+
+let rec print_block
+ : ?printer:sep_printer -> ?add_space:bool -> bool -> Format.formatter -> Component_value.t with_loc list -> unit
+ = fun ?(printer=print_space) ?(add_space=false) is_selector formatter values ->
+ let _ = List.fold_left values
+ ~init:add_space
+ ~f:(fun v -> print_component printer is_selector v formatter) in
+ ()
+
+(** Print a component list.
+
+ [print_component sep is_selector]
+
+ [sep] : The space is the common separator, but it may be a coma when the
+ components are selectors.
+
+ [is_selector] tell if we are in a selector or in declaration. Some
+ operators are handled differently in selectors (hash represent id and
+ should be prepend by space)
+
+ [add_space] tell the printer that a space shall be added before the print.
+
+
+*)
+and print_component
+ : sep_printer -> bool -> bool -> Format.formatter -> Component_value.t with_loc -> bool
+ = fun sep_printer is_selector add_space formatter (value, _) ->
+ let _ = sep_printer in
+ match value with
+ | Delim str ->
+ begin match is_selector, str with
+ | true, "*"-> Format.fprintf formatter "%a*" print_space add_space
+ | _ -> Format.fprintf formatter "%s" str
+ end;
+ false
+ | Uri str ->
+ Format.fprintf formatter {|%aurl(%s)|}
+ print_space add_space
+ str;
+ true
+ | Ident str
+ | Operator str
+ | Number str ->
+ Format.fprintf formatter {|%a%s|}
+ print_space add_space
+ str;
+ true
+ | String str
+ | Unicode_range str ->
+ Format.fprintf formatter {|"%a%s"|}
+ print_space add_space
+ str;
+ true
+ | Hash str ->
+ begin match is_selector with
+ | true ->
+ (* We are in a selector, the # Operator is alway attached to an
+ element — * are explicited in the parser. We do not need to add
+ space before *)
+ Format.fprintf formatter "#%s" str
+ | false ->
+ Format.fprintf formatter "%a#%s"
+ print_space add_space
+ str;
+ end;
+ true
+ | Percentage str ->
+ Format.fprintf formatter "%a%s%%"
+ print_space add_space
+ str;
+ true
+ | Dimension (str, unit') ->
+ Format.fprintf formatter "%a%s %s"
+ print_space add_space
+ str unit';
+ true
+ | Float_dimension (str, unit', _) ->
+ Format.fprintf formatter "%a%s%s"
+ print_space add_space
+ str unit';
+ true
+ | Bracket_block elems ->
+ Format.fprintf formatter "%a[%a]"
+ print_space add_space
+ (print_block is_selector) elems;
+ true
+ | Paren_block elems ->
+ Format.fprintf formatter "%a(%a)"
+ print_space add_space
+ (print_block is_selector) elems;
+ true
+ | Function (name, elems) ->
+
+ let printer = print_coma in
+
+ Format.fprintf formatter "%a%s(%a)"
+ print_space add_space
+ (fst name)
+ (print_block ~printer is_selector) (fst elems);
+ true
+
+let print_important
+ : template -> Format.formatter -> bool with_loc -> unit
+ = fun template formatter (is_important, _) ->
+ match is_important with
+ | true -> Format.fprintf formatter template.important
+ | false -> ()
+
+let rec print_brace_block
+ : template -> Format.formatter -> Brace_block.t -> unit
+ = fun template formatter -> function
+ | Empty -> Format.fprintf formatter ";"
+ | Declaration_list d ->
+ Format.fprintf formatter template.declaration
+ (Format.pp_print_list ~pp_sep:pp_sep_column (print_declaration_list template)) (fst d)
+ | Stylesheet css ->
+ Format.fprintf formatter template.stylesheet
+ (Format.pp_print_list (print_rule template)) (fst css)
+
+and print_at_rule
+ : template -> Format.formatter -> At_rule.t -> unit
+ = fun template formatter rule ->
+ Format.fprintf formatter template.at_rule
+ (fst rule.name)
+ (print_block true ~add_space:true) (fst rule.prelude)
+ (print_brace_block template) rule.block
+
+and print_declaration
+ : template -> Format.formatter -> Css.Types.Declaration.t -> unit
+ = fun template formatter {name; value; important; _ } ->
+ Format.fprintf formatter "%s:%a%a"
+ (fst name)
+ (print_block false) (fst value)
+ (print_important template) important
+
+and print_declaration_list
+ : template -> Format.formatter -> Css.Types.Declaration_list.kind -> unit
+ = fun template formatter -> function
+ | Declaration decl -> print_declaration template formatter decl
+ | At_rule rule -> print_at_rule template formatter rule
+
+and print_style_rule
+ : template -> Format.formatter -> Css.Types.Style_rule.t -> unit
+ = fun template formatter rule ->
+ Format.fprintf formatter template.style_rule
+ (print_block true) (fst rule.prelude)
+ (Format.pp_print_list ~pp_sep:pp_sep_column (print_declaration_list template)) (fst rule.block)
+
+and print_rule
+ : template -> Format.formatter -> Css.Types.Rule.t -> unit
+ = fun template formatter -> function
+ | Rule.Style_rule style ->
+ print_style_rule template formatter style
+ | Rule.At_rule rule ->
+ print_at_rule template formatter rule
+
+let css
+ : template -> Format.formatter -> Css.Types.Stylesheet.t -> unit
+ = fun template formatter css ->
+ Format.fprintf formatter template.main_css
+ (Format.pp_print_list (print_rule template)) (fst css)
diff --git a/css/merge_lib/print.mli b/css/merge_lib/print.mli
new file mode 100755
index 0000000..2884f9b
--- /dev/null
+++ b/css/merge_lib/print.mli
@@ -0,0 +1,7 @@
+type template
+
+val pretty_printer : template
+val minify_printer : template
+
+val css
+ : template -> Format.formatter -> Css.Types.Stylesheet.t -> unit
diff --git a/css/merger.ml b/css/merger.ml
new file mode 100755
index 0000000..7f525ff
--- /dev/null
+++ b/css/merger.ml
@@ -0,0 +1,275 @@
+open StdLabels
+open Js_of_ocaml
+
+open Brr
+open Note
+open Brr_note
+
+module Printer = Css_lib.Print
+
+let min = Printer.minify_printer
+
+type file =
+ { file : File.t
+ ; css : Css.Types.Stylesheet.t option
+ }
+
+type state =
+ { files : file Js.js_array Js.t
+ ; result_css : Css.Types.Stylesheet.t option
+ ; elements : int
+ }
+
+let init =
+ { files = new%js Js.array_empty
+ ; result_css = None
+ ; elements = 0 }
+
+type event =
+ | AddFile of file
+ | DelFile of File.t
+
+let build_result
+ : file Js.js_array Js.t -> Css.Types.Stylesheet.t option
+ = fun documents ->
+ let merge_result = documents##reduce_init
+ (Js.wrap_callback @@
+ (fun acc v _idx _arr ->
+
+ match acc, v.css with
+ | None, None -> None
+ | None, Some css -> Some (Css_lib.Merge.(add_css empty css))
+ | Some res, Some css -> Some (Css_lib.Merge.(add_css res css ))
+ | v, None -> v ))
+ None in
+ Option.map
+ Css_lib.Merge.extract_css
+ merge_result
+
+let do_action
+ : event -> state -> state
+ = fun event state ->
+ match event with
+ | AddFile file ->
+ let _ = state.files##push file in
+ let elements = state.files##.length
+ and result_css = build_result state.files in
+ { state with elements ; result_css }
+ | DelFile file ->
+
+ let files = state.files##filter
+ (Js.wrap_callback @@ (fun elt _ _ -> Js.bool (elt.file != file))) in
+ let elements = files##.length
+ and result_css = build_result files in
+ { files ; elements ; result_css }
+
+type file_event = event S.t
+
+(** Read the content from the file *)
+let file_loader
+ : file E.send -> File.t -> unit
+ = fun event file ->
+ let blob = File.as_blob file in
+ Fut.await
+ (Blob.text blob)
+ (Result.iter
+ (fun content ->
+
+ let str_content = Jstr.to_string content in
+ let css = try
+ Some (Css.Parser.parse_stylesheet str_content)
+ with
+ | _ -> None
+ in
+ event {file; css} ))
+
+let header =
+ let button =
+ El.span
+ [ El.txt' "Retirer" ] in
+
+ El.set_inline_style
+ (Jstr.v "float")
+ (Jstr.v "right")
+ button;
+
+ let block =
+ El.div
+ [ El.span [El.txt' "Fichier"]
+ ; button ]
+ in
+ El.set_inline_style
+ (El.Style.display)
+ (Jstr.v "block")
+ block;
+ block
+
+let file_list
+ : event E.send -> file -> El.t
+ = fun sender f ->
+ let icon =
+ El.i []
+ ~at:At.[ class' (Jstr.v "fas")
+ ; class' (Jstr.v "fa-check") ] in
+
+ let button =
+ El.i []
+ ~at:At.[ class' (Jstr.v "fas")
+ ; class' (Jstr.v "fa-times-circle") ] in
+
+ El.set_inline_style
+ (Jstr.v "float")
+ (Jstr.v "right")
+ button;
+
+ Ev.listen
+ Ev.click
+ (fun _ -> sender (DelFile f.file))
+ (El.as_target button);
+
+ match f.css with
+ (* A css exists, add the icon element *)
+ | Some _ ->
+ El.div
+ [ El.txt (File.name f.file)
+ ; icon
+ ; button ]
+
+ | None ->
+ El.div
+ [ El.txt (File.name f.file)
+ ; button ]
+
+
+let buttons:
+ state -> on_change:(Brr.File.t list -> unit) -> El.t list
+ = fun state ~on_change ->
+ let _ = state in
+ (* The input file can't be styled we hide it and use a click forwarding
+ button instead. *)
+ let i = El.input ()
+ ~at:[ At.type' (Jstr.v "file")
+ ; (At.v (Jstr.v "accept")) (Jstr.v ".css")
+ ] in
+ El.set_inline_style El.Style.display (Jstr.v "none") i;
+
+ let b = El.button [ El.txt' "Ajouter un fichier…" ]
+ ~at:[ At.class' (Jstr.v "button")] in
+
+ let d = El.button [ El.txt' "Télécharger" ]
+ ~at:[ At.class' (Jstr.v "button")] in
+
+ Ev.listen Ev.click (fun _e -> El.click i) (El.as_target b);
+ Ev.listen Ev.change (fun _e -> on_change (El.Input.files i)) (El.as_target i);
+
+ Ev.listen Ev.click (fun _ ->
+
+ match state.result_css with
+ | None -> ()
+ | Some result ->
+ let formatter = Format.str_formatter in
+ Css_lib.Print.(css minify_printer formatter result);
+ let content = Format.flush_str_formatter () in
+ Elements.Transfert.send
+ ~mime_type:(Jstr.v "text/css")
+ ~filename:(Jstr.v "result.css")
+ (Jstr.v content)
+ )
+ (El.as_target d);
+
+ let has_css = state.files##some
+ (Js.wrap_callback (fun elem _idx _arr -> Js.bool (elem.css != None))) in
+
+ match Js.to_bool has_css with
+ | true -> [i; b; d]
+ | false -> [i; b]
+
+let display_content css =
+
+ match css with
+ | None -> []
+ | Some result ->
+ let formatter = Format.str_formatter in
+ Css_lib.Print.(css pretty_printer formatter result);
+ let content = Format.flush_str_formatter () in
+
+ let area =
+ El.textarea
+ [ El.txt' content ] in
+
+ El.set_inline_style
+ (Jstr.v "width")
+ (Jstr.v "100%")
+ area;
+
+ El.set_inline_style
+ (Jstr.v "height")
+ (Jstr.v "200px")
+ area;
+
+ El.set_inline_style
+ (Jstr.v "max-height")
+ (Jstr.v "50vh")
+ area;
+
+ El.set_inline_style
+ (Jstr.v "resize")
+ (Jstr.v "none")
+ area;
+
+ [ El.h2 [ El.txt' "Prévisualisation"]
+ ; area ]
+
+let main id =
+
+ match (Jv.is_none id) with
+ | true -> Console.(error [str "No element with id '%s' found"; id])
+ | false ->
+ let elements = El.div [] in
+
+ let add_file_event, add_file_sender = Note.E.create () in
+ let del_file_event, del_file_sender = Note.E.create () in
+
+ let state =
+ E.select
+ [ E.map (fun f -> AddFile f) add_file_event
+ ; del_file_event
+ ]
+ |> E.map do_action
+ |> Note.S.accum init in
+
+ let _ = Elr.def_children
+ elements
+ (S.map (fun state ->
+ let elements =
+ Jv.to_list
+ (fun x -> file_list del_file_sender (Jv.Id.of_jv x))
+ (Jv.Id.to_jv state.files) in
+ match elements with
+ | [] -> display_content state.result_css
+ | _ ->
+ List.append
+ (header::elements)
+ (display_content state.result_css)
+ )
+ state) in
+
+ let on_change files = file_loader add_file_sender (List.hd files) in
+ let header = El.span [] in
+
+ Elr.def_children
+ header
+ (S.map (fun state ->
+ buttons ~on_change state)
+
+ state);
+
+ El.set_children (Jv.Id.of_jv id) [El.p [header]; elements]
+
+let () =
+
+ let open Jv in
+ let main = obj
+ [| "attach", (repr main) |] in
+
+ set global "merger" main
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 20:46:06 +0000