5 files changed, 67 insertions(+), 21 deletions(-)

M src/Data/CSS/Preprocessor/PsuedoClasses.hs
M src/Data/CSS/Style/Selector/Interpret.hs
M src/Data/CSS/Style/Selector/Specificity.hs
M stylist-traits/src/Stylist.hs
M stylist-traits/src/Stylist/Tree.hs

@@ 2,7 2,8 @@
 -- | Lowers psuedoclasses to rawer syntactic forms.
 module Data.CSS.Preprocessor.PsuedoClasses(LowerPsuedoClasses(..),
     psuedoClassesFilter, htmlPsuedoFilter,
-    addRewrite, addRewrite', addPsuedoEl, addNamespace, addTest, PropertyTest) where
+    addRewrite, addRewrite', addTest, addContains, PropertyTest,
+    addPsuedoEl, addNamespace) where
 
 import Data.CSS.Syntax.StyleSheet
 import Data.CSS.Syntax.Selector


@@ 12,6 13,7 @@ import Data.Text as Txt hiding (elem)
 import Data.Maybe (fromMaybe, listToMaybe)
 import Data.HashMap.Lazy as HM
 import Data.Function ((&))
+import Data.List as L (intercalate)
 
 --------
 ---- core


@@ 88,6 90,16 @@ addRewrite' name sel self =
     spliceArgs (tok:toks) args = tok : spliceArgs toks args
     spliceArgs _ _ = [Ident "\tfail"]
 
+addContains :: Text -> [Int] -> LowerPsuedoClasses s -> LowerPsuedoClasses s
+addContains name path self =
+    addRewrite' name (L.intercalate [Comma] $ buildSelector path [Colon, Ident "root"]) self
+  where
+    buildSelector (p:ps) prefix =
+        let prefix' = prefix ++ [Delim '>', Colon, Function "nth-child", num p, RightParen]
+        in prefix' : buildSelector ps prefix'
+    buildSelector [] _ = []
+    num x = Number (Txt.pack $ show x) $ NVInteger (toInteger x)
+
 addTest :: Text -> Maybe Text -> Text -> PropertyFunc -> LowerPsuedoClasses s -> LowerPsuedoClasses s
 addTest name ns attr test self = addTest' name (noArg [Property ns attr $ Callback test]) self
     where


@@ 124,4 136,5 @@ htmlPsuedoFilter s = psuedoClassesFilter s &
     addRewrite "readonly" "[readonly], [disabled]" &
     addRewrite "read-write" ":not([readonly]):not([disabled])" &
     addRewrite "required" "[required]" &
-    addRewrite "scope" ":root"
+    addRewrite "scope" ":root" &
+    addRewrite "root" "html"

@@ 7,6 7,7 @@ module Data.CSS.Style.Selector.Interpret(
     ) where
 
 import Data.CSS.Style.Common
+import Stylist (compileAttrTest, matched, hasWord)
 
 import Data.Text (unpack)
 import Data.List


@@ 73,16 74,6 @@ lowerInner (Psuedoclass c []:s) =
 lowerInner (Psuedoclass _ _:_) = ([Fail], [])
 lowerInner [] = ([], [])
 
-compileAttrTest :: PropertyTest -> String -> Bool
-compileAttrTest Exists = matched
-compileAttrTest (Equals val) = (== (unpack val))
-compileAttrTest (Suffix val) = isSuffixOf $ unpack val
-compileAttrTest (Prefix val) = isPrefixOf $ unpack val
-compileAttrTest (Substring val) = isInfixOf $ unpack val
-compileAttrTest (Include val) = hasWord $ unpack val
-compileAttrTest (Dash val) = hasLang $ unpack val
-compileAttrTest (Callback (PropertyFunc cb)) = cb
-
 sortAttrs :: [(Text, Maybe Text, b)] -> [(Text, Maybe Text, b)]
 sortAttrs = sortBy compareAttrs where compareAttrs (x, x', _) (y, y', _) = (x, x') `compare` (y, y')
 


@@ 106,8 97,6 @@ indirect traverser upTest test el | Nothing <- traverser el = False
     | not $ test el = False
     | upTest (fromJust $ traverser el) = True
     | otherwise = indirect traverser upTest test $ fromJust $ traverser el
-matched :: t -> Bool
-matched _ = True
 
 testAttr :: Text -> (String -> Bool) -> AttrsFunc -> AttrsFunc
 testAttr expected test next attrs@(Attribute attr _ value : attrs')


@@ 124,11 113,6 @@ testAttrNS expectedNS expected test next attrs@(Attribute attr ns value : attrs'
     | otherwise = False
 testAttrNS _ _ _ _ [] = False
 
-hasWord :: String -> String -> Bool
-hasWord expected value = expected `elem` words value
-hasLang :: [Char] -> [Char] -> Bool
-hasLang expected value = expected == value || isPrefixOf (expected ++ "-") value
-
 --- Pseudoclasses
 recursiveSelect :: Bool -> [SelectorFunc] -> SelectorFunc -> SelectorFunc
 recursiveSelect negate' sels success el | negate' `xor` any ($ el) sels = success el

@@ 40,7 40,10 @@ instance RuleStore inner => RuleStore (OrderedRuleStore inner) where
     new = OrderedRuleStore new 0
     addStyleRule (OrderedRuleStore self count) priority rule = OrderedRuleStore (
             addStyleRule self priority $ rule {
-                rank = (priority, computeSpecificity (psuedoElement rule) $ selector rule, count)
+                rank = (
+                    priority ++ [maxBound], -- Ensure unlayered rules take precedance.
+                    computeSpecificity (psuedoElement rule) $ selector rule,
+                    count)
             }
         ) (count + 1)
     lookupRules (OrderedRuleStore self _) el = sort $ lookupRules self el

@@ 1,12 1,15 @@
 module Stylist(cssPriorityAgent, cssPriorityUser, cssPriorityAuthor,
     PropertyParser(..), TrivialPropertyParser(..),
     StyleSheet(..), TrivialStyleSheet(..), Props,
-    Element(..), Attribute(..)) where
+    Element(..), Attribute(..),
+    elementPath, compileAttrTest, matched, attrTest, hasWord, hasLang) where
 
 import Data.Text (Text, unpack)
 import Data.CSS.Syntax.Tokens (Token)
+import Data.List
 
 import Stylist.Parse (StyleSheet(..), TrivialStyleSheet(..))
+import Stylist.Parse.Selector
 
 -- | Set the priority for a CSS stylesheet being parsed.
 cssPriorityAgent, cssPriorityUser, cssPriorityAuthor :: StyleSheet s => s -> s


@@ 62,3 65,36 @@ data Element = ElementNode {
 }
 -- | A key-value attribute.
 data Attribute = Attribute Text Text String deriving (Eq, Ord)
+
+elementPath :: Element -> [Int]
+elementPath = elementPath' []
+elementPath' path ElementNode { parent = Just parent', previous = prev } =
+    elementPath' (succ (countSib prev) : path) parent'
+elementPath' path ElementNode { parent = Nothing, previous = prev } =
+    (succ (countSib prev) : path)
+countSib (Just (ElementNode { previous = prev })) = succ $ countSib prev
+countSib Nothing = 0
+
+compileAttrTest :: PropertyTest -> String -> Bool
+compileAttrTest Exists = matched
+compileAttrTest (Equals val) = (== (unpack val))
+compileAttrTest (Suffix val) = isSuffixOf $ unpack val
+compileAttrTest (Prefix val) = isPrefixOf $ unpack val
+compileAttrTest (Substring val) = isInfixOf $ unpack val
+compileAttrTest (Include val) = hasWord $ unpack val
+compileAttrTest (Dash val) = hasLang $ unpack val
+compileAttrTest (Callback (PropertyFunc cb)) = cb
+
+matched :: t -> Bool
+matched _ = True
+hasWord :: String -> String -> Bool
+hasWord expected value = expected `elem` words value
+hasLang :: [Char] -> [Char] -> Bool
+hasLang expected value = expected == value || isPrefixOf (expected ++ "-") value
+
+attrTest :: Maybe Text -> Text -> PropertyTest -> Element -> Bool
+attrTest namespace name test ElementNode { attributes = attrs } = any predicate attrs
+    where
+        predicate attr@(Attribute ns' _ _) | Just ns <- namespace = ns == ns' && predicate' attr
+            | otherwise = predicate' attr
+        predicate' (Attribute _ name' value') = name == name' && compileAttrTest test value'

@@ 35,6 35,16 @@ treeFlatten' (StyleTree p []:ps) = p : treeFlatten' ps
 treeFlatten' (StyleTree _ childs:sibs) = treeFlatten' childs ++ treeFlatten' sibs
 treeFlatten' [] = []
 
+treeFlattenAll :: StyleTree p -> [p]
+treeFlattenAll = treeFlatten' . children
+treeFlattenAll' :: [StyleTree p] -> [p]
+treeFlattenAll' (StyleTree p []:ps) = p : treeFlatten' ps
+treeFlattenAll' (StyleTree p childs:sibs) = p : treeFlatten' childs ++ treeFlatten' sibs
+treeFlattenAll' [] = []
+
+treeFind :: StyleTree p -> (p -> Bool) -> [p]
+treeFind p test = filter test $ treeFlattenAll p
+
 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) ->