4 files changed, 73 insertions(+), 67 deletions(-)

M src/Data/CSS/StyleTree.hs
M stylist-traits/src/Stylist/Parse.hs
M xml-conduit-stylist/src/Data/HTML2CSS.hs
M xml-conduit-stylist/xml-conduit-stylist.cabal

@@ 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 = []

@@ 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
 --------

@@ 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

@@ 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