From edfaf74d2316be5db17ce05eb7d265f4430bee7d Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 22 Apr 2020 21:02:06 +1200 Subject: [PATCH] Evaluate attribute namespace selectors. --- src/Data/CSS/Style/Cascade.hs | 2 +- src/Data/CSS/Style/Common.hs | 2 +- src/Data/CSS/Style/Selector/Index.hs | 6 ++--- src/Data/CSS/Style/Selector/Interpret.hs | 31 +++++++++++++++--------- test/Test.hs | 24 +++++++++--------- 5 files changed, 37 insertions(+), 28 deletions(-) diff --git a/src/Data/CSS/Style/Cascade.hs b/src/Data/CSS/Style/Cascade.hs index 68a0c32..501b44c 100644 --- a/src/Data/CSS/Style/Cascade.hs +++ b/src/Data/CSS/Style/Cascade.hs @@ -89,7 +89,7 @@ resolveAttr self el = self { } where StyleRule sel attrs psuedo = inner self attrs2Dict :: Element -> HashMap Text String -attrs2Dict el = fromList [(a, b) | Attribute a b <- attributes el] +attrs2Dict el = fromList [(a, b) | Attribute a _ b <- attributes el] resolveAttr' :: [Token] -> HashMap Text String -> [Token] resolveAttr' (Function "attr":Ident attr:RightParen:toks) attrs = diff --git a/src/Data/CSS/Style/Common.hs b/src/Data/CSS/Style/Common.hs index 1ed33f0..5f59fe2 100644 --- a/src/Data/CSS/Style/Common.hs +++ b/src/Data/CSS/Style/Common.hs @@ -26,7 +26,7 @@ data Element = ElementNode { attributes :: [Attribute] } -- | A key-value attribute. -data Attribute = Attribute Text String deriving (Eq, Ord) +data Attribute = Attribute Text Text String deriving (Eq, Ord) class RuleStore a where new :: a diff --git a/src/Data/CSS/Style/Selector/Index.hs b/src/Data/CSS/Style/Selector/Index.hs index c1e7c76..6dd8adb 100644 --- a/src/Data/CSS/Style/Selector/Index.hs +++ b/src/Data/CSS/Style/Selector/Index.hs @@ -68,13 +68,13 @@ testsForAttributes :: [Attribute] -> [SimpleSelector] testsForElement :: Element -> [SimpleSelector] testsForElement element = (Tag $ name element) : (testsForAttributes $ attributes element) -testsForAttributes (Attribute "class" value:attrs) = +testsForAttributes (Attribute "class" _ value:attrs) = (Prelude.map (\s -> Class $ pack s) $ words value) ++ (Property Nothing "class" Exists : testsForAttributes attrs) -testsForAttributes (Attribute "id" value:attrs) = +testsForAttributes (Attribute "id" _ value:attrs) = (Prelude.map (\s -> Id $ pack s) $ words value) ++ (Property Nothing "id" Exists : testsForAttributes attrs) -testsForAttributes (Attribute elName _:attrs) = +testsForAttributes (Attribute elName _ _:attrs) = Property Nothing elName Exists : testsForAttributes attrs testsForAttributes [] = [] diff --git a/src/Data/CSS/Style/Selector/Interpret.hs b/src/Data/CSS/Style/Selector/Interpret.hs index c95c4bd..bb2505b 100644 --- a/src/Data/CSS/Style/Selector/Interpret.hs +++ b/src/Data/CSS/Style/Selector/Interpret.hs @@ -33,7 +33,7 @@ compile (Sibling up sel) = indirect previous (compile up) $ compileInner sel compileInner :: [SimpleSelector] -> SelectorFunc compileInner sel = compileInner' $ lowerInner sel -compileInner' :: ([IL], [(Text, String -> Bool)]) -> SelectorFunc +compileInner' :: ([IL], [(Text, Maybe Text, String -> Bool)]) -> SelectorFunc compileInner' ((Tagname tag:tests), attrs) = testTag tag $ compileInner' (tests, attrs) compileInner' ((NS ns:tests), attrs) = testNS ns $ compileInner' (tests, attrs) compileInner' ((Fail:_), _) = \_ -> False @@ -44,16 +44,17 @@ compileInner' ((Nth ofType n 0:tests), attrs) = compileInner' ((Nth ofType a b:tests), attrs) = nthChild' ofType (fromInteger a) (fromInteger b) $ compileInner' (tests, attrs) compileInner' ([], attrs) = testAttrs (compileAttrs $ sortAttrs attrs) matched -compileAttrs :: [(Text, String -> Bool)] -> AttrsFunc -compileAttrs ((tag, test):attrs) = testAttr tag test $ compileAttrs attrs +compileAttrs :: [(Text, Maybe Text, String -> Bool)] -> AttrsFunc +compileAttrs ((tag, Nothing, test):attrs) = testAttr tag test $ compileAttrs attrs +compileAttrs ((tag, Just ns, test):attrs) = testAttrNS ns tag test $ compileAttrs attrs compileAttrs [] = matched -lowerInner :: [SimpleSelector] -> ([IL], [(Text, String -> Bool)]) +lowerInner :: [SimpleSelector] -> ([IL], [(Text, Maybe Text, String -> Bool)]) lowerInner (Namespace ns:sel) = (NS ns:tests, attrs) where (tests, attrs) = lowerInner sel lowerInner (Tag tag:sel) = (Tagname tag:tests, attrs) where (tests, attrs) = lowerInner sel -lowerInner (Id i:s) = (tests, ("id", hasWord $ unpack i):attrs) where (tests, attrs) = lowerInner s -lowerInner (Class c:s) = (tests, ("class", hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s -lowerInner (Property _ prop test:s) = (tests, (prop, compileAttrTest test):attrs) +lowerInner (Id i:s) = (tests, ("id", Nothing, hasWord $ unpack i):attrs) where (tests, attrs) = lowerInner s +lowerInner (Class c:s) = (tests, ("class", Nothing, hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s +lowerInner (Property ns prop test:s) = (tests, (prop, ns, compileAttrTest test):attrs) where (tests, attrs) = lowerInner s -- psuedos, TODO handle argumented psuedoclasses. lowerInner (Psuedoclass c args:s) @@ -66,7 +67,7 @@ lowerInner (Psuedoclass "nth-child" args:s) = lowerInner (Psuedoclass "nth-of-type" args:s) = (parseNth True (filter (== Whitespace) args):tests, attrs) where (tests, attrs) = lowerInner s lowerInner (Psuedoclass c []:s) = - (tests, ("", hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s + (tests, ("", Nothing, hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s lowerInner (Psuedoclass _ _:_) = ([Fail], []) lowerInner [] = ([], []) @@ -79,8 +80,8 @@ compileAttrTest (Substring val) = isInfixOf $ unpack val compileAttrTest (Include val) = hasWord $ unpack val compileAttrTest (Dash val) = hasLang $ unpack val -sortAttrs :: [(Text, b)] -> [(Text, b)] -sortAttrs = sortBy compareAttrs where compareAttrs x y = fst x `compare` fst y +sortAttrs :: [(Text, Maybe Text, b)] -> [(Text, Maybe Text, b)] +sortAttrs = sortBy compareAttrs where compareAttrs (x, x', _) (y, y', _) = (x, x') `compare` (y, y') -------- ---- Runtime @@ -88,6 +89,7 @@ sortAttrs = sortBy compareAttrs where compareAttrs x y = fst x `compare` fst y testTag :: Text -> SelectorFunc -> SelectorFunc testTag tag success el | name el == tag = success el | otherwise = False +testNS :: Text -> SelectorFunc -> SelectorFunc testNS ns success el | namespace el == ns = success el | otherwise = False testAttrs :: AttrsFunc -> SelectorFunc -> SelectorFunc @@ -105,12 +107,19 @@ matched :: t -> Bool matched _ = True testAttr :: Text -> (String -> Bool) -> AttrsFunc -> AttrsFunc -testAttr expected test next attrs@(Attribute attr value : attrs') +testAttr expected test next attrs@(Attribute attr _ value : attrs') | attr < expected = testAttr expected test next attrs' | attr > expected = False | attr == expected && test value = next attrs | otherwise = False testAttr _ _ _ [] = False +testAttrNS :: Text -> Text -> (String -> Bool) -> AttrsFunc -> AttrsFunc +testAttrNS expectedNS expected test next attrs@(Attribute attr ns value : attrs') + | (attr, ns) < (expected, expectedNS) = testAttrNS expectedNS expected test next attrs' + | (attr, ns) > (expected, expectedNS) = False + | (attr, ns) == (expected, expectedNS) && test value = next attrs + | otherwise = False +testAttrNS _ _ _ _ [] = False hasWord :: String -> String -> Bool hasWord expected value = expected `elem` words value diff --git a/test/Test.hs b/test/Test.hs index 49e0e70..6fa5922 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -103,9 +103,9 @@ spec = do parent = Nothing, previous = Nothing, attributes = [ - Attribute "class" "external", - Attribute "href" "https://adrian.geek.nz/", - Attribute "id" "mysite" + Attribute "class" "" "external", + Attribute "href" "" "https://adrian.geek.nz/", + Attribute "id" "" "mysite" ] } let element2 = ElementNode { @@ -140,10 +140,10 @@ spec = do parent = Nothing, previous = Nothing, attributes = [ - Attribute "class" "external secure link", - Attribute "href" "https://adrian.geek.nz/index.html", - Attribute "id" "mysite", - Attribute "lang" "en-US" + Attribute "class" "" "external secure link", + Attribute "href" "" "https://adrian.geek.nz/index.html", + Attribute "id" "" "mysite", + Attribute "lang" "" "en-US" ] } let sibling = ElementNode { @@ -244,7 +244,7 @@ spec = do namespace = "", parent = Nothing, previous = Nothing, - attributes = [Attribute "class" "link"] + attributes = [Attribute "class" "" "link"] } let rules = parse queryable "a.link {color: green} a {color: red}" let VarParser _ (TrivialPropertyParser style) = cascade rules el [] temp::(VarParser TrivialPropertyParser) @@ -255,7 +255,7 @@ spec = do namespace = "", parent = Nothing, previous = Nothing, - attributes = [Attribute "class" "link"] + attributes = [Attribute "class" "" "link"] } let rules = parse queryable "a {color: red; color: green}" let VarParser _ (TrivialPropertyParser style) = cascade rules el [] temp::(VarParser TrivialPropertyParser) @@ -270,7 +270,7 @@ spec = do namespace = "", parent = Nothing, previous = Nothing, - attributes = [Attribute "class" "link"] + attributes = [Attribute "class" "" "link"] } let rules = parse (queryable {priority = 1}) "a {color: green}" let rules2 = parse (rules {priority = 2}) "a {color: red}" :: QueryableStyleSheet (VarParser TrivialPropertyParser) @@ -282,7 +282,7 @@ spec = do namespace = "", parent = Nothing, previous = Nothing, - attributes = [Attribute "class" "link"] + attributes = [Attribute "class" "" "link"] } let rules' = parse (queryable {priority = 1}) "a {color: red}" let rules2' = parse (rules' {priority = 2}) "a {color: green !important}" :: QueryableStyleSheet (VarParser TrivialPropertyParser) @@ -294,7 +294,7 @@ spec = do namespace = "", parent = Nothing, previous = Nothing, - attributes = [Attribute "class" "link"] + attributes = [Attribute "class" "" "link"] } let rules = parse queryable "a {color: red;}" let VarParser _ (TrivialPropertyParser style) = cascade rules el [("color", [Ident "green"])] temp::(VarParser TrivialPropertyParser) -- 2.30.2