From 3e92f6c3f8fdaca139f09b647fa6bbac57285f22 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 16 Aug 2022 19:17:16 +1200 Subject: [PATCH] Revamp XML-Conduit-Stylist API to avoid hard-dependency on Haskell Stylist. --- src/Data/CSS/StyleTree.hs | 37 ++++++- stylist-traits/src/Stylist/Parse.hs | 4 + xml-conduit-stylist/src/Data/HTML2CSS.hs | 97 +++++++------------ xml-conduit-stylist/xml-conduit-stylist.cabal | 2 +- 4 files changed, 73 insertions(+), 67 deletions(-) diff --git a/src/Data/CSS/StyleTree.hs b/src/Data/CSS/StyleTree.hs index abcbcbd..a209632 100644 --- a/src/Data/CSS/StyleTree.hs +++ b/src/Data/CSS/StyleTree.hs @@ -3,7 +3,40 @@ -- but also used internally for generating counter text. -- -- Backwards compatability module, this API has been moved out into "stylist-traits". +-- Though it also contains integration between the styletree & styling APIs. +{-# LANGUAGE OverloadedStrings #-} module Data.CSS.StyleTree(StyleTree(..), treeOrder, treeOrder', - Path, treeMap, treeFlatten, preorder, preorder', postorder) where + Path, treeMap, treeFlatten, preorder, preorder', postorder, + stylize, inlinePseudos) where -import Stylist.Tree +import Stylist.Tree -- Mainly for reexports + +import Stylist +import Data.CSS.Style +import Data.CSS.Syntax.StyleSheet (parseProperties') +import Data.CSS.Syntax.Tokens +import Data.Text (Text, pack) +import Data.HashMap.Strict as M (toList) +import Data.Maybe (fromMaybe) + +stylize :: PropertyParser s => QueryableStyleSheet s -> StyleTree Element -> StyleTree [(Text, s)] +stylize = preorder . stylize' +stylize' :: PropertyParser s => QueryableStyleSheet s -> Maybe [(Text, s)] -> Maybe [(Text, s)] -> + Element -> [(Text, s)] +stylize' stylesheet parent' _ el = ("", base) : [ + (k, cascade' v [] base) | (k, v) <- M.toList $ queryRules stylesheet el + ] where + base = cascade stylesheet el overrides $ fromMaybe temp $ lookup "" =<< parent' + overrides = concat [fst $ parseProperties' $ tokenize $ pack val + | Attribute "style" _ val <- attributes el] + +inlinePseudos :: PropertyParser s => StyleTree [(Text, VarParser s)] -> StyleTree s +inlinePseudos (StyleTree self childs) = StyleTree { + style = fromMaybe temp $ innerParser <$> lookup "" self, + children = pseudo "before" ++ map inlinePseudos childs ++ pseudo "after" + } where + pseudo n + | Just sty <- innerParser <$> lookup n self, + Just style' <- longhand sty sty "::" [Ident n] = [StyleTree style' []] + | Just sty <- innerParser <$> lookup n self = [StyleTree sty []] + | otherwise = [] diff --git a/stylist-traits/src/Stylist/Parse.hs b/stylist-traits/src/Stylist/Parse.hs index ef2ad75..5a5ae50 100644 --- a/stylist-traits/src/Stylist/Parse.hs +++ b/stylist-traits/src/Stylist/Parse.hs @@ -52,6 +52,10 @@ data TrivialStyleSheet = TrivialStyleSheet [StyleRule] deriving (Show, Eq) instance StyleSheet TrivialStyleSheet where addRule (TrivialStyleSheet self) rule = TrivialStyleSheet $ rule:self +-- | In case an indirect caller doesn't actually want to use Haskell Stylist. +instance StyleSheet () where + addRule () _ = () + -------- ---- Basic parsing -------- diff --git a/xml-conduit-stylist/src/Data/HTML2CSS.hs b/xml-conduit-stylist/src/Data/HTML2CSS.hs index c9ec8d3..67e477a 100644 --- a/xml-conduit-stylist/src/Data/HTML2CSS.hs +++ b/xml-conduit-stylist/src/Data/HTML2CSS.hs @@ -1,58 +1,45 @@ {-# LANGUAGE OverloadedStrings #-} -- | Bindings from `xml-conduit` to `haskell-stylist`. module Data.HTML2CSS( - html2css, cssPriorityAgent, cssPriorityUser, cssPriorityAuthor, -- parsing - preorder, el2styletree, els2stylist, el2stylist, stylize, stylize', stylizeEl, -- application - inlinePseudos, stylizeNoPseudos, stylizeElNoPseudos + html2css, -- parsing + el2styletree, els2stylist, el2stylist -- application ) where 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 import qualified Text.XML as XML -import Data.CSS.Syntax.StyleSheet -import Data.CSS.Style -import Data.CSS.StyleTree +import Stylist.Parse +import Stylist +import Stylist.Tree import Data.CSS.Syntax.Tokens -import Data.CSS.Preprocessor.Conditions -import qualified Data.CSS.Preprocessor.Conditions.Expr as Query import Network.URI ----- Constants --- | Set the priority for a CSS stylesheet being parsed. -cssPriorityAgent, cssPriorityUser, cssPriorityAuthor :: StyleSheet s => s -> s -cssPriorityAgent = setPriority 1 -cssPriorityUser = setPriority 2 -cssPriorityAuthor = setPriority 3 - ---- Parsing -- | Converts a parsed XML or HTML file to a `ConditionalStyles` `StyleSheet`. -html2css :: PropertyParser p => XML.Document -> URI -> ConditionalStyles p -html2css xml url = testIsStyled $ ConditionalStyles { - hostURL = url, - mediaDocument = "document", - isUnstyled = False, - rules = Priority 3 : html2css' (XML.documentRoot xml) (conditionalStyles url "document"), - propertyParser = temp -} - -html2css' :: PropertyParser p => XML.Element -> ConditionalStyles p -> [ConditionalRule p] -html2css' (XML.Element (XML.Name "style" _ _) attrs children) base = - [Internal (parseMediaQuery attrs) (parseForURL base (hostURL base) $ strContent children)] -html2css' (XML.Element (XML.Name "link" _ _) attrs _) base - | Just link <- "href" `M.lookup` attrs, +html2css :: StyleSheet s => XML.Document -> URI -> s -> s +html2css xml url self = html2css' (XML.documentRoot xml) url self + +html2css' :: StyleSheet s => XML.Element -> URI -> s -> s +html2css' (XML.Element (XML.Name "style" _ _) attrs children) url self + | M.lookup "type" attrs `notElem` [Nothing, Just "text/css"] = self -- Unsupported stylesheet. + | Just media <- "media" `M.lookup` attrs = + fst $ addAtRule self "media" (tokenize media ++ + LeftCurlyBracket : tokContent url children ++ [RightCurlyBracket]) + | otherwise = parseForURL self url $ strContent children +html2css' (XML.Element (XML.Name "link" _ _) attrs _) baseURL self + | M.lookup "type" attrs `elem` [Nothing, Just "text/css"], Just "stylesheet" <- "rel" `M.lookup` attrs, - Just uri <- parseURIReference $ Txt.unpack link = - [External (parseMediaQuery attrs) (relativeTo uri $ hostURL base)] -html2css' (XML.Element _ _ children) base = concat [html2css' el base | XML.NodeElement el <- children] - -parseMediaQuery :: M.Map XML.Name Txt.Text -> Query.Expr -parseMediaQuery attrs - | Just text <- "media" `M.lookup` attrs = Query.parse' (tokenize text) [] - | otherwise = [] + Just link <- "href" `M.lookup` attrs, + Just url <- parseURIReference $ Txt.unpack link = + fst $ addAtRule self "import" ( + Url (Txt.pack $ uriToString' $ relativeTo url baseURL) : + fromMaybe [] (tokenize <$> M.lookup "media" attrs) ++ + [Semicolon]) +html2css' (XML.Element _ _ children) url self = + L.foldl' (\s el -> html2css' el url s) self [el | XML.NodeElement el <- children] strContent :: [XML.Node] -> Txt.Text @@ -64,6 +51,14 @@ strContent (XML.NodeElement (XML.Element _ _ children):rest) = strContent (_:rest) = strContent rest strContent [] = "" +tokContent :: URI -> [XML.Node] -> [Token] +tokContent baseURL = map absolutizeUrl . tokenize . strContent + where + absolutizeUrl (Url link) | Just url <- parseURIReference $ Txt.unpack link = + Url $ Txt.pack $ uriToString' $ relativeTo url baseURL + +uriToString' uri = uriToString id uri "" + ---- Styling el2styletree el = StyleTree (Left el) $ mapMaybe node2styletree $ XML.elementNodes el @@ -90,29 +85,3 @@ els2stylist' parent previous (Right attrs) = ElementNode { } where style = concat [[prop, ": ", serialize v, "; "] | (prop, v) <- attrs] el2stylist = els2stylist . el2styletree - -stylize :: PropertyParser s => QueryableStyleSheet s -> StyleTree Element -> StyleTree [(Txt.Text, s)] -stylize = preorder . stylize' -stylize' :: PropertyParser s => QueryableStyleSheet s -> Maybe [(Txt.Text, s)] -> Maybe [(Txt.Text, s)] -> - Element -> [(Txt.Text, s)] -stylize' stylesheet parent _ el = ("", base) : [ - (k, cascade' v [] base) | (k, v) <- HM.toList $ queryRules stylesheet el - ] where - base = cascade stylesheet el overrides $ fromMaybe temp $ lookup "" =<< parent - overrides = concat [fst $ parseProperties' $ tokenize $ Txt.pack val - | Attribute "style" _ val <- attributes el] -stylizeEl stylesheet = stylize stylesheet . el2stylist - -inlinePseudos :: PropertyParser s => StyleTree [(Txt.Text, VarParser s)] -> StyleTree s -inlinePseudos (StyleTree self childs) = StyleTree { - style = fromMaybe temp $ innerParser <$> lookup "" self, - children = pseudo "before" ++ map inlinePseudos childs ++ pseudo "after" - } where - pseudo n - | Just style <- innerParser <$> lookup n self, - Just style' <- longhand style style "::" [Ident n] = [StyleTree style' []] - | Just style <- innerParser <$> lookup n self = [StyleTree style []] - | otherwise = [] - -stylizeNoPseudos css = inlinePseudos . stylize css -stylizeElNoPseudos css = inlinePseudos . stylizeEl css diff --git a/xml-conduit-stylist/xml-conduit-stylist.cabal b/xml-conduit-stylist/xml-conduit-stylist.cabal index 759a2d8..004b213 100644 --- a/xml-conduit-stylist/xml-conduit-stylist.cabal +++ b/xml-conduit-stylist/xml-conduit-stylist.cabal @@ -61,7 +61,7 @@ library -- Other library packages from which modules are imported. build-depends: base >=4.9 && <5, - stylist >=2.4 && <3, css-syntax, unordered-containers, + stylist-traits >=0.1 && <2, css-syntax, xml-conduit >=1.8 && < 1.9, text, containers, network-uri -- 2.30.2