xml-conduit-stylist 1.2.0.0 → 2.0.0.0
raw patch · 2 files changed
+46/−94 lines, 2 files
Files
- src/Data/HTML2CSS.hs +45/−93
- xml-conduit-stylist.cabal +1/−1
src/Data/HTML2CSS.hs view
@@ -1,21 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} -- | Bindings from `xml-conduit` to `haskell-stylist`. module Data.HTML2CSS(- externalStyles, externalStylesForURL, internalStyles, internalStylesForURL, -- legacy html2css, cssPriorityAgent, cssPriorityUser, cssPriorityAuthor, -- parsing- traverseStyles, traversePrepopulatedStyles, traverseStyles', elToStylish -- application+ preorder, el2styletree, els2stylist, el2stylist, stylize, stylize', stylizeEl -- 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 (fromMaybe)+import Data.Maybe import qualified Text.XML as XML import Data.CSS.Syntax.StyleSheet import Data.CSS.Style-import Data.CSS.Syntax.Tokens (tokenize)+import Data.CSS.StyleTree+import Data.CSS.Syntax.Tokens import Data.CSS.Preprocessor.Conditions import qualified Data.CSS.Preprocessor.Conditions.Expr as Query import Network.URI@@ -53,43 +53,7 @@ | Just text <- "media" `M.lookup` attrs = Query.parse' (tokenize text) [] | otherwise = [] ----- Parsing (legacy)--- | LEGACY: Extract relative links to external stylesheets.-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--- | LEGACY: Extract absolutized links to external stylesheets.-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 $ relativeTo link base- rest <- go links- return $ (relativeTo link base, 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]---- | LEGACY: Extract internally embedded CSS stylesheets.-internalStyles a b c = internalStylesForURL a b nullURI c--- | LEGACY: Extract internally embedded CSS stylesheets, with absolutized URLs.-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) =- 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.@@ -100,62 +64,50 @@ strContent [] = "" ---- Styling--- | Converts a parsed XML or HTML document to a specified style tree type.-traverseStyles :: PropertyParser s => (s -> [o] -> o) -> (s -> Txt.Text -> o) ->- QueryableStyleSheet s -> XML.Element -> o-traverseStyles = traverseStyles' Nothing temp Nothing (\x y -> Nothing)--- | Converts a parsed XML or HTML document to a specified style tree type,--- with a routine to compute alternative contents based on the raw element or computed styles.-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--- | Full routine for converting a parsed XML or HTML document to a specified style tree type.-traverseStyles' :: PropertyParser s => Maybe Element -> s -> Maybe Element ->- (s -> XML.Element -> Maybe [o]) -> (s -> [o] -> o) -> (s -> Txt.Text -> o) ->- QueryableStyleSheet s -> XML.Element -> o-traverseStyles' parent parentStyle previous prepopulate builder textBuilder stylesheet el@(- XML.Element _ attrs children- ) = builder style traverseChildren- where- stylishEl = elToStylish el parent previous- maybeEl = Just stylishEl- rules = queryRules stylesheet stylishEl- style = cascade' (HM.lookupDefault [] "" rules) overrides parentStyle- overrides | Just styleAttr <- "style" `M.lookup` attrs =- fst $ parseProperties' $ tokenize styleAttr- | otherwise = [] - traverseChildren = traversePsuedo' "before" ++- 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 prepopulate builder textBuilder stylesheet el :- traverseChildren' (Just $ elToStylish el maybeEl prev) nodes- traverseChildren' prev (_:nodes) = traverseChildren' prev nodes- traverseChildren' _ [] = []-traversePsuedo rules psuedo parentStyle builder- | Just rules' <- HM.lookup psuedo rules = [builder (cascade' rules' [] parentStyle) []]- | otherwise = []+preorder :: (Maybe b -> Maybe b -> a -> b) -> StyleTree a -> StyleTree b+preorder cb self = head $ preorder' cb Nothing Nothing [self]+preorder' :: (Maybe b -> Maybe b -> a -> b) ->+ Maybe b -> Maybe b -> [StyleTree a] -> [StyleTree b]+preorder' cb parent previous (self:sibs) = let self' = cb parent previous $ style self+ in StyleTree self' (preorder' cb (Just self') Nothing $ children self) :+ preorder' cb parent (Just self') sibs+preorder' _ _ _ [] = [] --- | Converts a xml-conduit Element to a stylist Element.-elToStylish (XML.Element (XML.Name name ns _) attrs _) parent previous =+el2styletree el = StyleTree (Left el) $ mapMaybe node2styletree $ XML.elementNodes el+node2styletree (XML.NodeElement el) = Just $ el2styletree el+node2styletree (XML.NodeContent txt) = Just $ StyleTree (Right [("content", [String txt])]) []+node2styletree _ = Nothing++previous' (Just ElementNode {name = "", previous = prev'}) = previous' prev'+previous' prev' = prev'++els2stylist = preorder els2stylist'+els2stylist' parent previous (Left (XML.Element (XML.Name name ns _) attrs _)) = ElementNode {- name = name,- namespace = fromMaybe "" ns,+ name = name, namespace = fromMaybe "" ns, attributes = L.sort [- Attribute name (fromMaybe "" ns) (Txt.unpack value)- | (XML.Name name ns _, value) <- M.toList attrs+ Attribute n (fromMaybe "" ns) $ Txt.unpack v | (XML.Name n ns _, v) <- M.toList attrs ],- parent = parent,- previous = previous+ parent = parent, previous = previous' previous }-addPsuedoclasses el psuedoclasses- | (Attribute "" "" value : attrs) <- attributes el = el {- attributes = Attribute "" "" (psuedoclasses ++ value) : attrs- }- | otherwise = el {- attributes = Attribute "" "" psuedoclasses : attributes el- }+els2stylist' parent previous (Right attrs) = ElementNode {+ name = "", namespace = "",+ attributes = [Attribute "style" "" $ Txt.unpack $ Txt.concat style],+ parent = parent, previous = previous' previous+ } 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 = [+ (k, if Txt.null k then base else 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
xml-conduit-stylist.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 1.2.0.0+version: 2.0.0.0 -- A short (one-line) description of the package. synopsis: Bridge between xml-conduit/html-conduit and stylist