2 files changed, 20 insertions(+), 70 deletions(-)

M rhapsode.cabal
M src/Main.hs

@@ 64,7 64,7 @@ executable rhapsode
         http-client, http-client-tls, bytestring,
         html-conduit, xml-conduit, text, containers,
         network-uri,
-        stylish-haskell >= 0.2.0, css-syntax
+        stylish-haskell >= 0.2.0, css-syntax, stylish-html-conduit
   
   -- Directories containing source files.
   hs-source-dirs:      src

@@ 12,12 12,14 @@ 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)
-import qualified Data.Map as M
 
 import qualified Data.CSS.Syntax.StyleSheet as CSS
 import qualified Data.CSS.Style as Style
 import qualified Data.CSS.Syntax.Tokens as CSSTok
+import qualified Data.HTML2CSS as H2C
+
 import qualified Data.List as L
+import qualified Data.Map as M
 
 import DefaultCSS
 


@@ 38,83 40,31 @@ renderElLBS el = XML.renderLBS XML.def $ XML.Document {
         XML.documentEpilogue = []
     }
 
-cssPriorityAgent = 1
-cssPriorityUser = 2
-cssPriorityAuthor = 3
-
 retreiveStyles html manager base = do
-    css <- externalStyles html manager base
-    return agentStyle -- $ authorStyle (css ++ internalStyles html) -- FIXME freezes
+    style <- H2C.externalStyles authorStyle testMedia html loadURL
+    return agentStyle -- FIXME Stylish Haskell freezes when I parse more.
   where
     emptyStyle :: Style.QueryableStyleSheet MapPropertyParser
-    emptyStyle = Style.queryableStyleSheet {Style.priority = cssPriorityAgent}
-    agentStyle = CSS.parse emptyStyle $ Txt.pack userAgentCSS
-    -- authorStyle = foldl CSS.parse $ agentStyle {Style.priority = cssPriorityAuthor}
-
-externalStyles html manager base = go $ linkedStyles html
-    where -- TODO parallelise loads
-        go (link:links) = do
-            request <- setUriRelative base link
-            response <- HTTP.httpLbs request manager
-            rest <- go links
-            return (Txt.pack (C8.unpack $ HTTP.responseBody response) : rest)
-        go [] = return []
+    emptyStyle = Style.queryableStyleSheet
+    agentStyle = H2C.cssPriorityAgent emptyStyle `CSS.parse` Txt.pack userAgentCSS
+    authorStyle = H2C.internalStyles testMedia (H2C.cssPriorityAuthor agentStyle) html
 
-linkedStyles (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 (XML.Element _ _ children) =
-    concat [linkedStyles el | XML.NodeElement el <- children]
-
-internalStyles (XML.Element (XML.Name "style" _ _) attrs children)
-    | testMedia attrs = [strContent children]
-internalStyles (XML.Element _ _ children) =
-    concat [internalStyles el | XML.NodeElement el <- children]
+    loadURL url = do -- TODO parallelise.
+        request <- setUriRelative base url
+        response <- HTTP.httpLbs request manager
+        return $ Txt.pack $ C8.unpack $ HTTP.responseBody response
 
 testMedia attrs = media == Nothing || media == Just "speech"
     where media = "media" `M.lookup` attrs
 
-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 [] = ""
-
 
-stylizeEl = stylizeEl' Nothing Style.temp Nothing
-stylizeEl' parent parentStyle previous stylesheet el@(XML.Element _ _ children) =
-    XML.Element {
-        XML.elementName = XML.Name "style" Nothing Nothing,
-        XML.elementAttributes = innerStyle,
-        XML.elementNodes = stylizeNodes (Just stylishEl) style Nothing stylesheet children
-    } where
-        style@(MPP innerStyle) = Style.cascade stylesheet stylishEl overrides parentStyle
-        stylishEl = elToStylish el parent previous
-        overrides = [] -- TODO parse style attribute
-stylizeNodes up upStyle prev styles (XML.NodeContent txt:nodes) =
-    XML.NodeContent txt : stylizeNodes up upStyle prev styles nodes
-stylizeNodes up upStyle prev styles (XML.NodeElement el:nodes) =
-    XML.NodeElement (stylizeEl' up upStyle prev styles el) :
-        stylizeNodes up upStyle stylishEl styles nodes
-    where stylishEl = Just $ elToStylish el up prev
-stylizeNodes a b c d (_:nodes) = stylizeNodes a b c d nodes
-stylizeNodes _ _ _ _ [] = []
-
-elToStylish (XML.Element (XML.Name name _ _) attrs _) parent previous =
-    Style.ElementNode {
-        Style.name = name,
-        Style.attributes = L.sort [
-            Style.Attribute (XML.nameLocalName name) (Txt.unpack value)
-            | (name, value) <- M.toList attrs
-        ],
-        Style.parent = parent,
-        Style.previous = previous
-    }
+stylizeEl styles html
+        | XML.NodeElement el <- H2C.traverseStyles buildEl buildText styles html = el
+        |otherwise = XML.Element name M.empty []
+    where
+        buildEl (MPP attrs) children = XML.NodeElement $ XML.Element name attrs children
+        buildText _ txt = XML.NodeContent txt
+        name = XML.Name "style" Nothing Nothing
 
 data MapPropertyParser = MPP (M.Map XML.Name Text)
 instance Style.PropertyParser MapPropertyParser where