From 7ff2b69d66428444d13e97059208ca1a2b498068 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sat, 25 Apr 2020 14:23:27 +1200
Subject: [PATCH] Refactor style application API to use StyleTree abstraction.

---
 xml-conduit-stylist/src/Data/HTML2CSS.hs | 83 +++++++++++++-----------
 1 file changed, 44 insertions(+), 39 deletions(-)

diff --git a/xml-conduit-stylist/src/Data/HTML2CSS.hs b/xml-conduit-stylist/src/Data/HTML2CSS.hs
index e088c15..ba84a30 100644
--- a/xml-conduit-stylist/src/Data/HTML2CSS.hs
+++ b/xml-conduit-stylist/src/Data/HTML2CSS.hs
@@ -2,14 +2,14 @@
 -- | Bindings from `xml-conduit` to `haskell-stylist`.
 module Data.HTML2CSS(
         html2css, cssPriorityAgent, cssPriorityUser, cssPriorityAuthor, -- parsing
-        el2stylist, stylize' -- application
+        preorder, el2styletree, els2stylist, el2stylist, stylize, stylize' -- application
     ) where
 
 import qualified Data.List as L
 import qualified Data.Map as M
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Text as Txt
-import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Maybe
 
 import qualified Text.XML as XML
 import Data.CSS.Syntax.StyleSheet
@@ -65,43 +65,48 @@ strContent [] = ""
 
 ---- Styling
 
-el2stylist el = nodes2stylist [XML.NodeElement el] Nothing Nothing
-nodes2stylist (XML.NodeElement (XML.Element (XML.Name name ns _) attrs childs):nodes) parent previous =
-    let el = ElementNode {
-        name = name,
-        namespace = fromMaybe "" ns,
+preorder :: (Maybe b -> Maybe b -> a -> b) -> StyleTree a -> StyleTree b
+preorder cb self = head $ preorder' cb Nothing Nothing [self]
+preorder' :: (Maybe b -> Maybe b -> a -> b) ->
+        Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]
+preorder' cb parent previous (self:sibs) = let self' = cb parent previous $ style self
+        in StyleTree self' (preorder' cb (Just self') Nothing $ children self) :
+            preorder' cb parent (Just self') sibs
+preorder' _ _ _ [] = []
+
+el2styletree el = StyleTree (Left el) $ mapMaybe node2styletree $ XML.elementNodes el
+node2styletree (XML.NodeElement el) = Just $ el2styletree el
+node2styletree (XML.NodeContent txt) = Just $ StyleTree (Right [("content", [String txt])]) []
+node2styletree _ = Nothing
+
+previous' (Just ElementNode {name = "", previous = prev'}) = previous' prev'
+previous' prev' = prev'
+
+els2stylist = preorder els2stylist'
+els2stylist' parent previous (Left (XML.Element (XML.Name name ns _) attrs _)) =
+    ElementNode {
+        name = name, namespace = fromMaybe "" ns,
         attributes = L.sort [
-            Attribute name (fromMaybe "" ns) (Txt.unpack value)
-            | (XML.Name name ns _, value) <- M.toList attrs
+            Attribute n (fromMaybe "" ns) $ Txt.unpack v | (XML.Name n ns _, v) <- M.toList attrs
         ],
-        parent = parent,
-        previous = previous
-    } in StyleTree {
-        style = el,
-        children = nodes2stylist childs (Just el) Nothing
-    } : nodes2stylist nodes parent previous
-nodes2stylist (XML.NodeContent txt:nodes) parent previous = StyleTree {
-        style = ElementNode {
-            name = "", namespace = "",
-            attributes = [Attribute "style" "" $ Txt.unpack $
-                Txt.append "content: " $ serialize [String txt]],
-            parent = parent, previous = previous
-        },
-        children = []
-    } : nodes2stylist nodes parent previous
-nodes2stylist (_:nodes) parent previous = nodes2stylist nodes parent previous
-nodes2stylist [] _ _ = []
-
-stylize' parent stylesheet (StyleTree el childs) = StyleTree {
-        style = cascade' (HM.lookupDefault [] "" rules) overrides parent,
-        children = traversePseudo "before" ++
-            map (stylize' parent stylesheet) childs ++
-            traversePseudo "after"
+        parent = parent, previous = previous' previous
     }
-  where
-    rules = queryRules stylesheet el
-    overrides = concat [ fst $ parseProperties' $ tokenize $ Txt.pack val
-        | Attribute "style" _ val <- attributes el ]
-    traversePseudo pclass
-        | Just rules' <- pclass `HM.lookup` rules = [StyleTree (cascade' rules' [] parent) []]
-        | otherwise = []
+els2stylist' parent previous (Right attrs) = ElementNode {
+        name = "", namespace = "",
+        attributes = [Attribute "style" "" $ Txt.unpack $ Txt.concat style],
+        parent = parent, previous = previous' previous
+    } where style = concat [[prop, ": ", serialize v, "; "] | (prop, v) <- attrs]
+
+el2stylist = els2stylist . el2styletree
+
+stylize :: PropertyParser s => QueryableStyleSheet s -> StyleTree Element -> StyleTree [(Txt.Text, s)]
+stylize = preorder . stylize'
+stylize' :: PropertyParser s => QueryableStyleSheet s -> Maybe [(Txt.Text, s)] -> Maybe [(Txt.Text, s)] ->
+        Element -> [(Txt.Text, s)]
+stylize' stylesheet parent _ el = [
+        (k, if Txt.null k then base else cascade' v [] base)
+        | (k, v) <- HM.toList $ queryRules stylesheet el
+    ] where
+        base = cascade stylesheet el overrides $ fromMaybe temp $ lookup "" =<< parent
+        overrides = concat [fst $ parseProperties' $ tokenize $ Txt.pack val
+            | Attribute "style" _ val <- attributes el]
-- 
2.30.2