css_merge application

author: Sébastien Dailly <sebastien@chimrod.com> 2021-02-04 21:14:01 +0100
committer: Sébastien Dailly <sebastien@dailly.me> 2022-02-07 14:37:57 +0100
commit: 86ec559f913c389e8dc055b494630f21a45e039b (patch)
tree: 822341b481695c9bf8b39f8b8fcbdeef56e629d6 /css
parent: 03f8a08fe2dde9db9fb656dbea2e5494b67236ad (diff)
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
author	Sébastien Dailly <sebastien@chimrod.com>	2021-02-04 21:14:01 +0100
committer	Sébastien Dailly <sebastien@dailly.me>	2022-02-07 14:37:57 +0100
commit	86ec559f913c389e8dc055b494630f21a45e039b (patch)
tree	822341b481695c9bf8b39f8b8fcbdeef56e629d6 /css
parent	03f8a08fe2dde9db9fb656dbea2e5494b67236ad (diff)