diff options
Diffstat (limited to 'css/merge_lib')
| -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 |
9 files changed, 744 insertions, 0 deletions
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 |