(* Copyright © 2021 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.*) 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 "@[%a@]@." ; style_rule = Stdlib.format_of_string "%a {@;<1 1>@[%a@]@,}@," ; declaration = Stdlib.format_of_string "{@;<1 1>@[%a@]@,}@," ; stylesheet = Stdlib.format_of_string "{@;<1 1>@[%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 "@[%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]" (* There is no need to add a space here, as the bracket as attribute cannot appear detachedfrom any selector *) (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)