5 files changed, 47 insertions(+), 24 deletions(-)

M src/Data/CSS/Style.hs
M src/Data/CSS/Syntax/StyleSheet.hs
M stylish-haskell.cabal
M stylish-html-conduit/src/Data/HTML2CSS.hs
M stylish-html-conduit/stylish-html-conduit.cabal

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

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

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

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

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