From 362b4f07b55d3fb955b29430dbf7da909f2c2b63 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 5 Aug 2019 20:21:32 +1200
Subject: [PATCH] Render CSS counters into the webpage!

---
 src/Main.hs      | 60 ++++++++++++++++++++++++++++++++++++++++++++++--
 src/StyleTree.hs |  5 +++-
 2 files changed, 62 insertions(+), 3 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index c5a72f3..d8a01a9 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -13,7 +13,7 @@ import qualified Data.ByteString.Lazy.Char8 as C8
 import qualified Text.HTML.DOM as HTML
 import qualified Text.XML as XML
 import           Data.Text as Txt (pack, unpack, Text(..), append,
-        words, unwords, head, last, stripStart, stripEnd)
+        words, unwords, head, last, stripStart, stripEnd, intercalate)
 
 import qualified Data.CSS.Syntax.StyleSheet as CSS
 import qualified Data.CSS.Style as Style
@@ -39,7 +39,7 @@ main = do
     let html = XML.documentRoot $ HTML.parseLBS $ HTTP.responseBody response
     style <- retreiveStyles html manager $ fromJust $ parseURI url
     let transcript = stylize style html
-    C8.putStrLn $ renderElLBS $ styleToSSML transcript
+    C8.putStrLn $ renderElLBS $ styleToSSML $ applyCounters transcript
 
 renderElLBS el = XML.renderLBS XML.def $ XML.Document {
         XML.documentPrologue = XML.Prologue [] Nothing [],
@@ -71,3 +71,59 @@ stylize styles html = H2C.traversePrepopulatedStyles buildChild buildNode buildT
             | otherwise = Just [Style.temp {content = content self}]
         buildNode self children = self {children = children}
         buildText _ txt = Style.temp {content = [Content txt]}
+
+--------
+---- Counters
+--------
+treeOrder :: (c -> c -> [Integer] -> StyleTree -> (c, StyleTree)) ->
+        c -> c -> [Integer] -> [StyleTree] -> (c, [StyleTree])
+treeOrder cb prevContext context (num:path) (node:nodes) = (tailContext, node' {children = children'} : nodes')
+    where
+        (selfContext, node') = cb prevContext context (num:path) node
+        (childContext, children') = treeOrder cb selfContext selfContext (0:num:path) $ children node
+        (tailContext, nodes') = treeOrder cb selfContext childContext (num + 1:path) nodes
+treeOrder _ _ context _ [] = (context, [])
+treeOrder _ _ _ [] _ = error "Invalid path during tree traversal!"
+
+inheritCounters path counterSource valueSource = M.intersectionWith cb valueSource counterSource -- indexed by name & el-path
+    where cb val source = [counter | path `elem` [p | (p, _) <- source], counter@(path, _) <- val]
+instantiateCounter counters path name val = M.insertWith appendCounter name [(path, val)] counters
+    where
+        appendCounter new (old@((_:oldPath), _):olds)
+            | oldPath == tail path = new ++ olds
+            | otherwise =  new ++ (old:olds)
+instantiateCounters path instruct counters = foldl cb counters instruct
+    where cb counters' (name, value) = instantiateCounter counters' path name value
+incrementCounter counters path name val = M.insertWith addCounter name [(path, val)] counters
+    where addCounter ((_, new):_) ((path, old):rest) = (path, new + old):rest
+incrementCounters path instruct counters = foldl cb counters instruct
+    where cb counters' (name, value) = incrementCounter counters' path name value
+setCounter counters path name val = M.insertWith setCounter' name [(path, val)] counters
+    where setCounter' ((_, val):_) ((path, _):rest) = (path, val):rest
+setCounters path instruct counters = foldl cb counters instruct
+    where cb counters' (name, value) = setCounter counters' path name value
+
+renderCounter counters (Content txt) = Content txt
+renderCounter counters (Counter name)
+    | Just ((_, count):_) <- name `M.lookup` counters = Content $ Txt.pack $ show count
+    | otherwise = Content ""
+renderCounter counters (Counters name sep)
+    | Just counter <- name `M.lookup` counters = Content $ Txt.intercalate sep [
+            Txt.pack $ show count | (_, count) <- reverse counter
+        ]
+    | otherwise = Content ""
+renderCounters node counters = (counters, node {
+        content = map (renderCounter counters) $ content node,
+        counterSet = [(name, value) | (name, ((_, value):_)) <- M.toList counters]
+    })
+
+applyCounters root = root {
+        children = snd $ treeOrder cb M.empty M.empty [0] $ children root
+    } where
+        cb :: M.Map Text [([Integer], Integer)] -> M.Map Text [([Integer], Integer)] ->
+            [Integer] -> StyleTree -> (M.Map Text [([Integer], Integer)], StyleTree)
+        cb counterSource valueSource path node = renderCounters node $
+            setCounters path (counterSet node) $
+            incrementCounters path (counterIncrement node) $
+            instantiateCounters path (counterReset node) $
+            inheritCounters path counterSource valueSource
diff --git a/src/StyleTree.hs b/src/StyleTree.hs
index 5259d45..5cb8671 100644
--- a/src/StyleTree.hs
+++ b/src/StyleTree.hs
@@ -67,7 +67,7 @@ parseCue [Url source, Dimension _ n "dB"] = Just $ Cue source $ Just $ Unit' "dB
 parseCue [Ident "none"] = Just NoCue
 parseCue _ = Nothing
 
-data StyleLeaf = Content {value :: Text} deriving Eq
+data StyleLeaf = Content {value :: Text} | Counter Text | Counters Text Text deriving Eq
 
 parseCounters _ [Ident "none"] = Just []
 parseCounters _ [] = Just []
@@ -202,6 +202,9 @@ instance Style.PropertyParser StyleTree where
     longhand _ self "cue-after" toks = (\val -> self {cueAfter = val}) <$> parseCue toks
 
     longhand _ self "content" [String txt] = Just self {content = [Content txt]}
+    longhand _ self "content" [Function "counter", Ident c, LeftParen] = Just self {content = [Counter c]}
+    longhand _ self "content" [Function "counters", Ident c, Comma, String sep, LeftParen] =
+        Just self {content = [Counters c sep]}
 
     longhand _ self "counter-reset" toks = (\val -> self {counterReset = val}) <$> parseCounters 0 toks
     longhand _ self "counter-increment" toks = (\val -> self {counterIncrement = val}) <$> parseCounters 1 toks
-- 
2.30.2