From 3630f677bc804ae9c6a86908e67b7e116a2123c0 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Sun, 14 Jul 2019 17:59:02 +1200
Subject: [PATCH] Draft html-conduit to Stylish Haskell bindings.

---
 stylish-html-conduit/src/Data/HTML2CSS.hs     | 91 ++++++++++++++++++-
 .../stylish-html-conduit.cabal                |  7 +-
 2 files changed, 94 insertions(+), 4 deletions(-)

diff --git a/stylish-html-conduit/src/Data/HTML2CSS.hs b/stylish-html-conduit/src/Data/HTML2CSS.hs
index 3595ee4..2d16578 100644
--- a/stylish-html-conduit/src/Data/HTML2CSS.hs
+++ b/stylish-html-conduit/src/Data/HTML2CSS.hs
@@ -1,5 +1,92 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Data.HTML2CSS(
-        
+        externalStyles, internalStyles,
+        cssPriorityAgent, cssPriorityUser, cssPriorityAuthor,
+        traverseStyles, traverseStyles', elToStylish
     ) where
 
--- TODO
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Data.Text as Txt
+
+import qualified Text.XML as XML
+import Data.CSS.Syntax.StyleSheet
+import Data.CSS.Style
+
+import Network.URI
+
+---- Constants
+cssPriorityAgent = 1
+cssPriorityUser = 2
+cssPriorityAuthor = 3
+
+---- Parsing
+externalStyles :: PropertyParser s => QueryableStyleSheet s -> (M.Map XML.Name Txt.Text -> Bool) ->
+        XML.Element -> (URI -> IO Txt.Text) -> IO (QueryableStyleSheet s)
+externalStyles stylesheet testMedia html loadURL = do
+    css <- externalStyles' testMedia html loadURL
+    return $ foldl parse stylesheet {priority = cssPriorityAuthor} css
+externalStyles' testMedia html loadURL = go $ linkedStyles' testMedia html
+    where -- TODO parallelise loads
+        go (link:links) = do
+            response <- loadURL $ link
+            rest <- go links
+            return $ response : rest
+        go [] = return []
+
+linkedStyles' testMedia (XML.Element (XML.Name "link" _ _) attrs _)
+    | Just link <- "href" `M.lookup` attrs,
+        Just "stylesheet" <- "rel" `M.lookup` attrs,
+        testMedia attrs,
+        Just uri <- parseURIReference $ Txt.unpack link = [uri]
+linkedStyles' testMedia (XML.Element _ _ children) =
+    concat [linkedStyles' testMedia el | XML.NodeElement el <- children]
+
+internalStyles testMedia stylesheet html =
+    foldl parse (stylesheet {priority = cssPriorityAuthor}) $ internalStyles' testMedia html
+internalStyles' testMedia (XML.Element (XML.Name "style"_ _) attrs children)
+    | testMedia attrs = [strContent children]
+internalStyles' testMedia (XML.Element _ _ children) =
+    concat [internalStyles' testMedia el | XML.NodeElement el <- children]
+
+
+strContent :: [XML.Node] -> Txt.Text
+strContent (XML.NodeContent text : rest) = text `Txt.append` strContent rest
+-- We do want to read in comments for CSS, just not for display.
+strContent (XML.NodeComment text : rest) = text `Txt.append` strContent rest
+strContent (XML.NodeElement (XML.Element _ _ children):rest) =
+    strContent children `Txt.append` strContent rest
+strContent (_:rest) = strContent rest
+strContent [] = ""
+
+---- Styling
+traverseStyles :: PropertyParser s => (s -> [s] -> s) -> (Txt.Text -> s) -> 
+        QueryableStyleSheet s -> XML.Element -> s
+traverseStyles = traverseStyles' Nothing temp Nothing
+traverseStyles' parent parentStyle previous builder textBuilder stylesheet el@(
+        XML.Element _ _ children
+    ) = builder style $ traverseChildren Nothing children
+    where
+        stylishEl = elToStylish el parent previous
+        maybeEl = Just stylishEl
+        style = cascade stylesheet stylishEl overrides parentStyle
+        overrides = [] -- TODO
+
+        traverseChildren prev (XML.NodeContent txt:nodes) =
+            textBuilder txt : traverseChildren prev nodes
+        traverseChildren prev (XML.NodeElement el:nodes) =
+            traverseStyles' maybeEl style prev builder textBuilder stylesheet el :
+                traverseChildren (Just $ elToStylish el maybeEl prev) nodes
+        traverseChildren prev (_:nodes) = traverseChildren prev nodes
+        traverseChildren _ [] = []
+
+elToStylish (XML.Element (XML.Name name _ _) attrs _) parent previous =
+    ElementNode {
+        name = name,
+        attributes = L.sort [
+            Attribute (XML.nameLocalName name) (Txt.unpack value)
+            | (name, value) <- M.toList attrs
+        ],
+        parent = parent,
+        previous = previous
+    }
diff --git a/stylish-html-conduit/stylish-html-conduit.cabal b/stylish-html-conduit/stylish-html-conduit.cabal
index 6fc791e..7558796 100644
--- a/stylish-html-conduit/stylish-html-conduit.cabal
+++ b/stylish-html-conduit/stylish-html-conduit.cabal
@@ -51,7 +51,7 @@ cabal-version:       >=1.10
 
 library
   -- Modules exported by the library.
-  -- exposed-modules:     
+  exposed-modules:     Data.HTML2CSS
   
   -- Modules included in this library but not exported.
   -- other-modules:       
@@ -60,7 +60,10 @@ library
   -- other-extensions:    
   
   -- Other library packages from which modules are imported.
-  build-depends:       base >=4.9 && <4.10
+  build-depends:       base >=4.9 && <4.10,
+                       stylish-haskell >= 0.2.1,
+                       xml-conduit, text, containers,
+                       network-uri
   
   -- Directories containing source files.
   hs-source-dirs:      src
-- 
2.30.2