packages feed

xml-conduit-stylist (empty) → 1.0.0.0

raw patch · 5 files changed

+222/−0 lines, 5 filesdep +basedep +containersdep +css-syntaxsetup-changed

Dependencies added: base, containers, css-syntax, network-uri, stylist, text, unordered-containers, xml-conduit

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for xml-conduit-stylist++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2019 Adrian Cochrane++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/HTML2CSS.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.HTML2CSS(+        externalStyles, externalStylesForURL, internalStyles, internalStylesForURL,+        cssPriorityAgent, cssPriorityUser, cssPriorityAuthor,+        traverseStyles, traversePrepopulatedStyles, traverseStyles', elToStylish+    ) 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 qualified Text.XML as XML+import Data.CSS.Syntax.StyleSheet+import Data.CSS.Style+import Data.CSS.Syntax.Tokens (tokenize)++import Network.URI++---- Constants+cssPriorityAgent, cssPriorityUser, cssPriorityAuthor :: StyleSheet s => s -> s+cssPriorityAgent = setPriority 1+cssPriorityUser = setPriority 2+cssPriorityAuthor = setPriority 3++---- Parsing+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 $ 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]++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) =+    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.+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 [] = ""++---- Styling+traverseStyles :: PropertyParser s => (s -> [o] -> o) -> (s -> Txt.Text -> o) ->+        QueryableStyleSheet s -> XML.Element -> o+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 -> 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 = []++elToStylish (XML.Element (XML.Name name _ _) attrs _) parent previous =+    ElementNode {+        name = name,+        attributes = L.sort [+            Attribute (XML.nameLocalName name) (Txt.unpack value)+            | (name, value) <- M.toList attrs+        ],+        parent = parent,+        previous = previous+    }+addPsuedoclasses el psuedoclasses+    | (Attribute "" value : attrs) <- attributes el = el {+            attributes = Attribute "" (psuedoclasses ++ value) : attrs+        }+    | otherwise = el {+            attributes = Attribute "" psuedoclasses : attributes el+        }
+ xml-conduit-stylist.cabal view
@@ -0,0 +1,73 @@+-- Initial stylish-html-conduit.cabal generated by cabal init.  For further+--  documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                xml-conduit-stylist++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- https://wiki.haskell.org/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             1.0.0.0++-- A short (one-line) description of the package.+synopsis:            Bridge between xml-conduit/html-conduit and stylist++-- A longer description of the package.+description:         Parses CSS from an HTML webpage and queries relevant properties for each element.++-- URL for the project homepage or repository.+homepage:            https://git.nzoss.org.nz/alcinnz/stylish-haskell++-- The license under which the package is released.+license:             MIT++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Adrian Cochrane++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          adrian@openwork.nz++-- A copyright notice.+copyright:           Adrian Cochrane copyright 2019++category:            Web++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+extra-source-files:  ChangeLog.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10+++library+  -- Modules exported by the library.+  exposed-modules:     Data.HTML2CSS+  +  -- Modules included in this library but not exported.+  -- other-modules:       +  +  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:    +  +  -- Other library packages from which modules are imported.+  build-depends:       base >=4.9 && <4.10,+                       stylist >=1 && <2, css-syntax, unordered-containers,+                       xml-conduit >=1.8 && < 1.9, text, containers,+                       network-uri+  +  -- Directories containing source files.+  hs-source-dirs:      src+  +  -- Base language which the package is written in.+  default-language:    Haskell2010+