From d073900ecfc42d81ce9405798133443531f1ca3c Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 28 Jul 2019 13:19:38 +1200 Subject: [PATCH] Add additional hooks for callers: * Resolve relative URLs. * Set priority on any stylesheet implementation. * Substitute content during XML Conduit traversal in place of computed styles. --- src/Data/CSS/Style.hs | 1 + src/Data/CSS/Syntax/StyleSheet.hs | 16 ++++++- stylish-haskell.cabal | 6 +-- stylish-html-conduit/src/Data/HTML2CSS.hs | 44 +++++++++++-------- .../stylish-html-conduit.cabal | 4 +- 5 files changed, 47 insertions(+), 24 deletions(-) diff --git a/src/Data/CSS/Style.hs b/src/Data/CSS/Style.hs index 70796fd..a2d513a 100644 --- a/src/Data/CSS/Style.hs +++ b/src/Data/CSS/Style.hs @@ -33,6 +33,7 @@ queryableStyleSheet :: PropertyParser p => QueryableStyleSheet p queryableStyleSheet = QueryableStyleSheet' {store = new, parser = temp, priority = 0} instance (RuleStore s, PropertyParser p) => StyleSheet (QueryableStyleSheet' s p) where + setPriority v self = self {priority = v} addRule self@(QueryableStyleSheet' store' _ priority') rule = self { store = addStyleRule store' priority' $ styleRule' rule } diff --git a/src/Data/CSS/Syntax/StyleSheet.hs b/src/Data/CSS/Syntax/StyleSheet.hs index 341916c..67909f7 100644 --- a/src/Data/CSS/Syntax/StyleSheet.hs +++ b/src/Data/CSS/Syntax/StyleSheet.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Data.CSS.Syntax.StyleSheet ( - parse, parse', TrivialStyleSheet(..), + parse, parse', parseForURL, TrivialStyleSheet(..), StyleSheet(..), skipAtRule, StyleRule(..), -- For parsing at-rules, HTML "style" attribute, etc. @@ -14,11 +14,15 @@ import Data.CSS.Syntax.Selector import Data.CSS.Syntax.StylishUtil import Data.Text.Internal (Text(..)) +import Data.Text (pack, unpack) +import Network.URI (parseRelativeReference, relativeTo, uriToString, URI(..)) -------- ---- Output type class -------- class StyleSheet s where + setPriority :: Int -> s -> s + setPriority _ = id addRule :: s -> StyleRule -> s addAtRule :: s -> Text -> [Token] -> (s, [Token]) addAtRule self _ tokens = (self, skipAtRule tokens) @@ -40,6 +44,16 @@ instance StyleSheet TrivialStyleSheet where parse :: StyleSheet s => s -> Text -> s parse stylesheet source = parse' stylesheet $ tokenize source +parseForURL :: StyleSheet s => s -> URI -> Text -> s +parseForURL stylesheet base source = parse' stylesheet $ rewriteURLs $ tokenize source + where + rewriteURLs (Url text:toks) + | Just url <- parseRelativeReference $ unpack text = + Url (pack $ uriToString id (relativeTo url base) "") : rewriteURLs toks + | otherwise = Function "url" : RightParen : rewriteURLs toks + rewriteURLs (tok:toks) = tok : rewriteURLs toks + rewriteURLs [] = [] + parse' :: StyleSheet t => t -> [Token] -> t -- Things to skip. parse' stylesheet (Whitespace:tokens) = parse' stylesheet tokens diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 9aa3dd6..d6fd8cf 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -10,7 +10,7 @@ name: stylish-haskell -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.6.0.0 +version: 0.7.0.0 -- A short (one-line) description of the package. synopsis: Apply CSS styles to a document tree. @@ -59,7 +59,7 @@ library -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.9 && <4.10, css-syntax, text, unordered-containers, hashable + build-depends: base >=4.9 && <4.10, css-syntax, text, unordered-containers, hashable, network-uri -- Directories containing source files. hs-source-dirs: src @@ -75,5 +75,5 @@ test-suite test-stylish type: exitcode-stdio-1.0 main-is: Test.hs other-modules: Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style - build-depends: base >=4.9 && <4.10, css-syntax, text, unordered-containers, hashable, hspec, QuickCheck + build-depends: base >=4.9 && <4.10, css-syntax, text, unordered-containers, hashable, network-uri, hspec, QuickCheck ghc-options: -Wall diff --git a/stylish-html-conduit/src/Data/HTML2CSS.hs b/stylish-html-conduit/src/Data/HTML2CSS.hs index f8b40e9..9517a6f 100644 --- a/stylish-html-conduit/src/Data/HTML2CSS.hs +++ b/stylish-html-conduit/src/Data/HTML2CSS.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Data.HTML2CSS( - externalStyles, internalStyles, + externalStyles, externalStylesForURL, internalStyles, internalStylesForURL, cssPriorityAgent, cssPriorityUser, cssPriorityAuthor, traverseStyles, traverseStyles', elToStylish ) where @@ -9,6 +9,7 @@ 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) import qualified Text.XML as XML import Data.CSS.Syntax.StyleSheet @@ -18,22 +19,24 @@ import Data.CSS.Syntax.Tokens (tokenize) import Network.URI ---- Constants -cssPriorityAgent styles = styles {priority = 1} -cssPriorityUser styles = styles {priority = 2} -cssPriorityAuthor styles = styles {priority = 3} +cssPriorityAgent, cssPriorityUser, cssPriorityAuthor :: StyleSheet s => s -> s +cssPriorityAgent = setPriority 1 +cssPriorityUser = setPriority 2 +cssPriorityAuthor = setPriority 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 (cssPriorityAuthor stylesheet) css -externalStyles' testMedia html loadURL = go $ linkedStyles' testMedia html +externalStyles :: StyleSheet s => s -> (M.Map XML.Name Txt.Text -> Bool) -> + XML.Element -> (URI -> IO Txt.Text) -> IO s +externalStyles a b c d = externalStylesForURL a b c nullURI d +externalStylesForURL stylesheet testMedia html base loadURL = do + css <- externalStyles' testMedia html base loadURL + return $ foldl (\a (b, c) -> parseForURL a b c) (cssPriorityAuthor stylesheet) css +externalStyles' testMedia html base loadURL = go $ linkedStyles' testMedia html where -- TODO parallelise loads go (link:links) = do response <- loadURL $ link rest <- go links - return $ response : rest + return $ (relativeTo link base, response) : rest go [] = return [] linkedStyles' testMedia (XML.Element (XML.Name "link" _ _) attrs _) @@ -44,8 +47,10 @@ linkedStyles' testMedia (XML.Element (XML.Name "link" _ _) attrs _) linkedStyles' testMedia (XML.Element _ _ children) = concat [linkedStyles' testMedia el | XML.NodeElement el <- children] -internalStyles testMedia stylesheet html = - foldl parse (cssPriorityAuthor stylesheet) $ internalStyles' testMedia html +internalStyles a b c = internalStylesForURL a b nullURI c +internalStylesForURL testMedia stylesheet base html = + foldl (\s -> parseForURL s base) (cssPriorityAuthor stylesheet) $ + internalStyles' testMedia html internalStyles' testMedia (XML.Element (XML.Name "style"_ _) attrs children) | testMedia attrs = [strContent children] internalStyles' testMedia (XML.Element _ _ children) = @@ -64,11 +69,14 @@ strContent [] = "" ---- Styling traverseStyles :: PropertyParser s => (s -> [o] -> o) -> (s -> Txt.Text -> o) -> QueryableStyleSheet s -> XML.Element -> o -traverseStyles = traverseStyles' Nothing temp Nothing +traverseStyles = traverseStyles' Nothing temp Nothing (\x y -> Nothing) +traversePrepopulatedStyles :: PropertyParser s => (s -> XML.Element -> Maybe [o]) -> + (s -> [o] -> o) -> (s -> Txt.Text -> o) -> QueryableStyleSheet s -> XML.Element -> o +traversePrepopulatedStyles = traverseStyles' Nothing temp Nothing traverseStyles' :: PropertyParser s => Maybe Element -> s -> Maybe Element -> - (s -> [o] -> o) -> (s -> Txt.Text -> o) -> + (s -> XML.Element -> Maybe [o]) -> (s -> [o] -> o) -> (s -> Txt.Text -> o) -> QueryableStyleSheet s -> XML.Element -> o -traverseStyles' parent parentStyle previous builder textBuilder stylesheet el@( +traverseStyles' parent parentStyle previous prepopulate builder textBuilder stylesheet el@( XML.Element _ attrs children ) = builder style traverseChildren where @@ -81,13 +89,13 @@ traverseStyles' parent parentStyle previous builder textBuilder stylesheet el@( | otherwise = [] traverseChildren = traversePsuedo' "before" ++ - traverseChildren' Nothing children ++ + fromMaybe (traverseChildren' Nothing children) (prepopulate style el) ++ traversePsuedo' "after" traversePsuedo' psuedo = traversePsuedo rules psuedo style builder traverseChildren' prev (XML.NodeContent txt:nodes) = textBuilder style txt : traverseChildren' prev nodes traverseChildren' prev (XML.NodeElement el:nodes) = - traverseStyles' maybeEl style prev builder textBuilder stylesheet el : + traverseStyles' maybeEl style prev prepopulate builder textBuilder stylesheet el : traverseChildren' (Just $ elToStylish el maybeEl prev) nodes traverseChildren' prev (_:nodes) = traverseChildren' prev nodes traverseChildren' _ [] = [] diff --git a/stylish-html-conduit/stylish-html-conduit.cabal b/stylish-html-conduit/stylish-html-conduit.cabal index c5b2506..107703d 100644 --- a/stylish-html-conduit/stylish-html-conduit.cabal +++ b/stylish-html-conduit/stylish-html-conduit.cabal @@ -10,7 +10,7 @@ name: stylish-html-conduit -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.3 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: Bridge between html-conduit and stylish-haskell @@ -61,7 +61,7 @@ library -- Other library packages from which modules are imported. build-depends: base >=4.9 && <4.10, - stylish-haskell >= 0.6.0, css-syntax, unordered-containers, + stylish-haskell >= 0.7.0, css-syntax, unordered-containers, xml-conduit, text, containers, network-uri -- 2.30.2