From 109888197ec28150fb50ca6fed8325fdc134cdc5 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 14 Jul 2019 20:32:22 +1200 Subject: [PATCH] Incorporate Stylish HTML Conduit. Improves clarity of Rhapsody's code and possibly helps someone else create their own browser. --- rhapsode.cabal | 2 +- src/Main.hs | 88 +++++++++++--------------------------------------- 2 files changed, 20 insertions(+), 70 deletions(-) diff --git a/rhapsode.cabal b/rhapsode.cabal index 3c62115..26554d5 100644 --- a/rhapsode.cabal +++ b/rhapsode.cabal @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 7f9251c..183c11f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 -- 2.30.2