From 86ec559f913c389e8dc055b494630f21a45e039b Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
Date: Thu, 4 Feb 2021 21:14:01 +0100
Subject: css_merge application

---
 css/merge_lib/merge.ml | 138 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 138 insertions(+)
 create mode 100755 css/merge_lib/merge.ml

(limited to 'css/merge_lib/merge.ml')

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
-- 
cgit v1.2.3