diff options
| -rwxr-xr-x | css/css.html | 131 | ||||
| -rwxr-xr-x | css/dune | 19 | ||||
| -rwxr-xr-x | css/lib/dune | 9 | ||||
| -rwxr-xr-x | css/lib/lex_buffer.ml | 114 | ||||
| -rwxr-xr-x | css/lib/lexer.ml | 351 | ||||
| -rwxr-xr-x | css/lib/location.ml | 19 | ||||
| -rwxr-xr-x | css/lib/menhir_parser.mly | 196 | ||||
| -rwxr-xr-x | css/lib/parser.ml | 5 | ||||
| -rwxr-xr-x | css/lib/parser.mli | 8 | ||||
| -rwxr-xr-x | css/lib/types.ml | 76 | ||||
| -rwxr-xr-x | css/lib/types.mli | 68 | ||||
| -rwxr-xr-x | css/merge_lib/common.ml | 61 | ||||
| -rwxr-xr-x | css/merge_lib/comparator.ml | 160 | ||||
| -rwxr-xr-x | css/merge_lib/css_lib.ml | 5 | ||||
| -rwxr-xr-x | css/merge_lib/dune | 6 | ||||
| -rwxr-xr-x | css/merge_lib/merge.ml | 138 | ||||
| -rwxr-xr-x | css/merge_lib/merge.mli | 10 | ||||
| -rwxr-xr-x | css/merge_lib/merge_style.ml | 132 | ||||
| -rwxr-xr-x | css/merge_lib/print.ml | 225 | ||||
| -rwxr-xr-x | css/merge_lib/print.mli | 7 | ||||
| -rwxr-xr-x | css/merger.ml | 275 | ||||
| -rwxr-xr-x | elements/dune | 2 | ||||
| -rwxr-xr-x | elements/transfert.ml | 22 | ||||
| -rwxr-xr-x | script.it/state.ml | 18 |
24 files changed, 2043 insertions, 14 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 – 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>© 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 diff --git a/elements/dune b/elements/dune index 755bd05..97d0753 100755 --- a/elements/dune +++ b/elements/dune @@ -3,5 +3,7 @@ (libraries brr brr.note + js_of_ocaml ) + (preprocess (pps ppx_hash js_of_ocaml-ppx)) ) diff --git a/elements/transfert.ml b/elements/transfert.ml new file mode 100755 index 0000000..ddeecd0 --- /dev/null +++ b/elements/transfert.ml @@ -0,0 +1,22 @@ +open Js_of_ocaml +open Brr + +let send + : mime_type:Jstr.t -> filename:Jstr.t -> Jstr.t -> unit + = fun ~mime_type ~filename content -> + let btoa = Jv.get Jv.global "btoa" in + let base64data = Jv.apply btoa + [| Jv.of_jstr content |] in + + let mime = (Jv.Id.(of_jv @@ to_jv mime_type)) + and base64 = (Jv.Id.(of_jv @@ to_jv base64data)) + in + + let data = (Js.string "data:")##concat_3 mime (Js.string ";base64,") base64 in + + (* Create the link to download the the element, and simulate a click on it *) + let a = El.a + ~at:At.[ href Jv.Id.(of_jv @@ to_jv data) + ; v (Jstr.v "download") filename ] + [] in + El.click a diff --git a/script.it/state.ml b/script.it/state.ml index ad7abb3..cb5d9ff 100755 --- a/script.it/state.ml +++ b/script.it/state.ml @@ -357,20 +357,10 @@ let do_action )) in let content = El.prop Elements.Prop.outerHTML svg in - - let btoa = Jv.get Jv.global "btoa" in - let base64data = Jv.apply btoa - [| Jv.of_jstr content |] in - - (* Create the link to download the the element, and simulate a click on it *) - let a = El.a - ~at:At.[ - href Jstr.( (v "data:image/svg+xml;base64,") + (Jv.Id.of_jv base64data)) - ; v (Jstr.v "download") (Jstr.v "out.svg") - ] - [] in - El.click a - ); + Elements.Transfert.send + ~mime_type:(Jstr.v "image/svg+xml") + ~filename:(Jstr.v "out.svg") + content); state | `Angle value , _ -> |