From b63c178768ed51e223c9f2b2e6ad1a779c909abc Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 13 Aug 2022 20:51:16 +1200 Subject: [PATCH] Add utils for implementing :target-within, ensure unlayered styles take precedance. --- src/Data/CSS/Preprocessor/PsuedoClasses.hs | 17 ++++++++-- src/Data/CSS/Style/Selector/Interpret.hs | 18 +--------- src/Data/CSS/Style/Selector/Specificity.hs | 5 ++- stylist-traits/src/Stylist.hs | 38 +++++++++++++++++++++- stylist-traits/src/Stylist/Tree.hs | 10 ++++++ 5 files changed, 67 insertions(+), 21 deletions(-) diff --git a/src/Data/CSS/Preprocessor/PsuedoClasses.hs b/src/Data/CSS/Preprocessor/PsuedoClasses.hs index 2ac3d5c..01ab5d7 100644 --- a/src/Data/CSS/Preprocessor/PsuedoClasses.hs +++ b/src/Data/CSS/Preprocessor/PsuedoClasses.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" diff --git a/src/Data/CSS/Style/Selector/Interpret.hs b/src/Data/CSS/Style/Selector/Interpret.hs index 435dec3..b3eddd3 100644 --- a/src/Data/CSS/Style/Selector/Interpret.hs +++ b/src/Data/CSS/Style/Selector/Interpret.hs @@ -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 diff --git a/src/Data/CSS/Style/Selector/Specificity.hs b/src/Data/CSS/Style/Selector/Specificity.hs index 1ab7474..c537744 100644 --- a/src/Data/CSS/Style/Selector/Specificity.hs +++ b/src/Data/CSS/Style/Selector/Specificity.hs @@ -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 diff --git a/stylist-traits/src/Stylist.hs b/stylist-traits/src/Stylist.hs index de86b8e..f8d206f 100644 --- a/stylist-traits/src/Stylist.hs +++ b/stylist-traits/src/Stylist.hs @@ -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' diff --git a/stylist-traits/src/Stylist/Tree.hs b/stylist-traits/src/Stylist/Tree.hs index 805be4b..4294594 100644 --- a/stylist-traits/src/Stylist/Tree.hs +++ b/stylist-traits/src/Stylist/Tree.hs @@ -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) -> -- 2.30.2