1 files changed, 225 insertions, 0 deletions
diff --git a/lib/print.ml b/lib/print.ml
new file mode 100755
index 0000000..5e48923
--- /dev/null
+++ b/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)