From 6344dc8ecd9cd36efdff13522a4e8b2e9724b1cd Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 19 Jul 2019 19:58:35 +1200 Subject: [PATCH] Rework psuedoelement infrastructure so they can be their own boxes. --- src/Data/CSS/Style.hs | 26 ++++++++------ src/Data/CSS/Style/Cascade.hs | 15 +++++--- src/Data/CSS/Style/Common.hs | 8 +++-- src/Data/CSS/Style/Importance.hs | 4 +-- src/Data/CSS/Style/Selector/Index.hs | 1 - src/Data/CSS/Style/Selector/Interpret.hs | 2 -- src/Data/CSS/Style/Selector/Specificity.hs | 17 ++++----- src/Data/CSS/Syntax/Selector.hs | 3 +- src/Data/CSS/Syntax/StyleSheet.hs | 22 +++++++----- stylish-haskell.cabal | 2 +- test/Test.hs | 42 +++++++++++----------- 11 files changed, 79 insertions(+), 63 deletions(-) diff --git a/src/Data/CSS/Style.hs b/src/Data/CSS/Style.hs index a59bbd2..70796fd 100644 --- a/src/Data/CSS/Style.hs +++ b/src/Data/CSS/Style.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} module Data.CSS.Style( QueryableStyleSheet, QueryableStyleSheet'(..), queryableStyleSheet, queryRules, - PropertyParser(..), cascade, + PropertyParser(..), cascade, cascade', TrivialPropertyParser(..), Element(..), Attribute(..) ) where @@ -12,10 +13,11 @@ import Data.CSS.Style.Selector.Specificity import Data.CSS.Style.Importance import Data.CSS.Style.Common import qualified Data.CSS.Style.Cascade as Cascade -import Data.CSS.Style.Cascade (PropertyParser(..), TrivialPropertyParser) +import Data.CSS.Style.Cascade (PropertyParser(..), TrivialPropertyParser, Props) import Data.CSS.Syntax.Tokens (Token) import Data.CSS.Syntax.StyleSheet (StyleSheet(..)) +import Data.HashMap.Strict (HashMap, lookupDefault) type QueryableStyleSheet parser = QueryableStyleSheet' (ImportanceSplitter ( PropertyExpander parser (OrderedRuleStore (InterpretedRuleStore StyleIndex)) @@ -35,15 +37,17 @@ instance (RuleStore s, PropertyParser p) => StyleSheet (QueryableStyleSheet' s p store = addStyleRule store' priority' $ styleRule' rule } -queryRules :: PropertyParser p => QueryableStyleSheet p -> Element -> [StyleRule'] -queryRules (QueryableStyleSheet' store' _ _) el = lookupRules store' el +--- Reexpose cascade methods +queryRules :: (PropertyParser p, RuleStore s) => + QueryableStyleSheet' s p -> Element -> HashMap Text [StyleRule'] +queryRules (QueryableStyleSheet' store' _ _) = Cascade.query store' --------- ----- Cascade --------- +cascade' :: PropertyParser p => [StyleRule'] -> Props -> p -> p +cascade' = Cascade.cascade -cascade :: PropertyParser p => QueryableStyleSheet p -> Element -> [(Text, [Token])] -> p -> p -cascade (QueryableStyleSheet' store' _ _) = Cascade.cascade store' +--- Facade for trivial cases +cascade :: PropertyParser p => QueryableStyleSheet p -> Element -> Props -> p -> p +cascade self el = cascade' $ lookupDefault [] "" $ queryRules self el --- Verify syntax during parsing, so invalid properties don't interfere with cascade. data PropertyExpander parser inner = PropertyExpander parser inner @@ -54,8 +58,8 @@ instance (PropertyParser parser, RuleStore inner) => RuleStore (PropertyExpander lookupRules (PropertyExpander _ inner') el = lookupRules inner' el expandRule :: PropertyParser t => t -> StyleRule' -> StyleRule' -expandRule parser' rule = rule {inner = StyleRule sel $ expandProperties parser' props} - where (StyleRule sel props) = inner rule +expandRule parser' rule = rule {inner = StyleRule sel (expandProperties parser' props) psuedo} + where (StyleRule sel props psuedo) = inner rule expandProperties :: PropertyParser t => t -> [(Text, [Token])] -> [(Text, [Token])] expandProperties parser' ((key, value):props) = shorthand parser' key value ++ expandProperties parser' props diff --git a/src/Data/CSS/Style/Cascade.hs b/src/Data/CSS/Style/Cascade.hs index 4ffa505..aa01f82 100644 --- a/src/Data/CSS/Style/Cascade.hs +++ b/src/Data/CSS/Style/Cascade.hs @@ -1,5 +1,6 @@ module Data.CSS.Style.Cascade( - cascade, TrivialPropertyParser(..), PropertyParser(..) + query, cascade, + TrivialPropertyParser(..), PropertyParser(..), Props ) where import Data.CSS.Style.Common @@ -29,9 +30,15 @@ instance PropertyParser TrivialPropertyParser where type Props = [(Text, [Token])] -cascade :: (PropertyParser p, RuleStore s) => s -> Element -> Props -> p -> p -cascade self el overrides base = dispatch base (inherit base) $ - toList $ cascadeRules overrides $ lookupRules self el +--- The query step exposes the available psuedoelements to the caller. + +query :: RuleStore s => s -> Element -> HashMap Text [StyleRule'] +query self el = Prelude.foldr yield empty $ lookupRules self el + where yield rule store = insertWith (++) (psuedoElement rule) [rule] store + +cascade :: PropertyParser p => [StyleRule'] -> Props -> p -> p +cascade styles overrides base = + dispatch base (inherit base) $ toList $ cascadeRules overrides styles cascadeRules :: Props -> [StyleRule'] -> HashMap Text [Token] cascadeRules overrides rules = cascadeProperties overrides $ concat $ Prelude.map properties rules diff --git a/src/Data/CSS/Style/Common.hs b/src/Data/CSS/Style/Common.hs index d6a15a3..ad6b3d8 100644 --- a/src/Data/CSS/Style/Common.hs +++ b/src/Data/CSS/Style/Common.hs @@ -1,5 +1,5 @@ module Data.CSS.Style.Common( - RuleStore(..), StyleRule'(..), selector, properties, styleRule', + RuleStore(..), StyleRule'(..), selector, properties, psuedoElement, styleRule', Element(..), Attribute(..), -- Re-exports Text(..), StyleRule(..), Selector(..), SimpleSelector(..), PropertyTest(..) @@ -42,6 +42,8 @@ instance Show StyleRule' where show a = show $ inner a instance Ord StyleRule' where compare x y = rank x `compare` rank y selector :: StyleRule' -> Selector -selector rule | StyleRule sel _ <- inner rule = sel +selector rule | StyleRule sel _ _ <- inner rule = sel properties :: StyleRule' -> [(Text, [Data.CSS.Syntax.Tokens.Token])] -properties rule | StyleRule _ props <- inner rule = props +properties rule | StyleRule _ props _ <- inner rule = props +psuedoElement :: StyleRule' -> Text +psuedoElement rule | StyleRule _ _ psuedo <- inner rule = psuedo diff --git a/src/Data/CSS/Style/Importance.hs b/src/Data/CSS/Style/Importance.hs index 04ced87..b9508e4 100644 --- a/src/Data/CSS/Style/Importance.hs +++ b/src/Data/CSS/Style/Importance.hs @@ -27,6 +27,6 @@ instance RuleStore inner => RuleStore (ImportanceSplitter inner) where ) priority $ buildRule important where (unimportant, important) = splitProperties props - (StyleRule sel props) = inner rule - buildRule x = rule {inner = StyleRule sel x} + (StyleRule sel props psuedo) = inner rule + buildRule x = rule {inner = StyleRule sel x psuedo} lookupRules (ImportanceSplitter self) el = lookupRules self el diff --git a/src/Data/CSS/Style/Selector/Index.hs b/src/Data/CSS/Style/Selector/Index.hs index 49d08a5..006606c 100644 --- a/src/Data/CSS/Style/Selector/Index.hs +++ b/src/Data/CSS/Style/Selector/Index.hs @@ -83,7 +83,6 @@ instance Hashable SimpleSelector where seed `hashWithSalt` (3::Int) `hashWithSalt` unpack prop `hashWithSalt` test hashWithSalt seed (Psuedoclass p args) = seed `hashWithSalt` (4::Int) `hashWithSalt` p `hashWithSalt` serialize args - hashWithSalt seed (Psuedoelement p) = seed `hashWithSalt` (5::Int) `hashWithSalt` p instance Hashable PropertyTest where hashWithSalt seed Exists = seed `hashWithSalt` (0::Int) diff --git a/src/Data/CSS/Style/Selector/Interpret.hs b/src/Data/CSS/Style/Selector/Interpret.hs index 4b2f116..1942158 100644 --- a/src/Data/CSS/Style/Selector/Interpret.hs +++ b/src/Data/CSS/Style/Selector/Interpret.hs @@ -38,8 +38,6 @@ lowerInner (Property prop test:s) = (tag, (prop, compileAttrTest test):attrs) -- psuedos, TODO handle argumented psuedoclasses. lowerInner (Psuedoclass c _:s) = (tag, ("", hasWord $ unpack c):attrs) where (tag, attrs) = lowerInner s -lowerInner (Psuedoelement t:s) = - (tag, ("", hasWord (':' : unpack t)):attrs) where (tag, attrs) = lowerInner s lowerInner [] = (Nothing, []) compileAttrTest :: PropertyTest -> String -> Bool diff --git a/src/Data/CSS/Style/Selector/Specificity.hs b/src/Data/CSS/Style/Selector/Specificity.hs index 25aeb18..9b3a667 100644 --- a/src/Data/CSS/Style/Selector/Specificity.hs +++ b/src/Data/CSS/Style/Selector/Specificity.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Data.CSS.Style.Selector.Specificity( OrderedRuleStore(..) ) where @@ -7,16 +8,16 @@ import Data.CSS.Style.Common import Data.List type Vec = (Int, Int, Int) -computeSpecificity :: Selector -> Vec -computeSpecificity (Element sel) = computeSpecificity' sel -computeSpecificity (Child upSel sel) = computeSpecificity upSel `add` computeSpecificity' sel -computeSpecificity (Descendant upSel sel) = computeSpecificity upSel `add` computeSpecificity' sel -computeSpecificity (Adjacent upSel sel) = computeSpecificity upSel `add` computeSpecificity' sel -computeSpecificity (Sibling upSel sel) = computeSpecificity upSel `add` computeSpecificity' sel +computeSpecificity :: Text -> Selector -> Vec +computeSpecificity "" (Element sel) = computeSpecificity' sel +computeSpecificity "" (Child upSel sel) = computeSpecificity "" upSel `add` computeSpecificity' sel +computeSpecificity "" (Descendant upSel sel) = computeSpecificity "" upSel `add` computeSpecificity' sel +computeSpecificity "" (Adjacent upSel sel) = computeSpecificity "" upSel `add` computeSpecificity' sel +computeSpecificity "" (Sibling upSel sel) = computeSpecificity "" upSel `add` computeSpecificity' sel +computeSpecificity _ _ = (0, 0, 1) -- psuedoelements count as a tag. computeSpecificity' :: [SimpleSelector] -> Vec computeSpecificity' (Tag _:sel) = computeSpecificity' sel `add` (0, 0, 1) -computeSpecificity' (Psuedoelement _:sel) = computeSpecificity' sel `add` (0, 0, 1) computeSpecificity' (Class _:sel) = computeSpecificity' sel `add` (0, 1, 0) computeSpecificity' (Psuedoclass _ _:sel) = computeSpecificity' sel `add` (0, 1, 0) computeSpecificity' (Property _ _:sel) = computeSpecificity' sel `add` (0, 1, 0) @@ -32,7 +33,7 @@ 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 $ selector rule, count) + rank = (priority, computeSpecificity (psuedoElement rule) $ selector rule, count) } ) (count + 1) lookupRules (OrderedRuleStore self _) el = sort $ lookupRules self el diff --git a/src/Data/CSS/Syntax/Selector.hs b/src/Data/CSS/Syntax/Selector.hs index 0079c20..b4daf62 100644 --- a/src/Data/CSS/Syntax/Selector.hs +++ b/src/Data/CSS/Syntax/Selector.hs @@ -14,7 +14,7 @@ data Selector = Element [SimpleSelector] | Adjacent Selector [SimpleSelector] | Sibling Selector [SimpleSelector] deriving (Show, Eq) data SimpleSelector = Tag Text | Id Text | Class Text | Property Text PropertyTest | - Psuedoclass Text [Token] | Psuedoelement Text + Psuedoclass Text [Token] deriving (Show, Eq) data PropertyTest = Exists | Equals Text | Suffix Text | Prefix Text | Substring Text | Include Text | Dash Text @@ -41,7 +41,6 @@ parseSelector (Delim '.':Ident class_:tokens) = parseSelector' (Class class_) to parseSelector (LeftSquareBracket:Ident prop:tokens) = concatP appendPropertySel parsePropertySel parseSelector tokens where appendPropertySel test selector = Property prop test : selector -parseSelector (Colon:Colon:Ident p:ts) = parseSelector' (Psuedoelement p) ts parseSelector (Colon:Ident p:ts) = parseSelector' (Psuedoclass p []) ts parseSelector (Colon:Function fn:tokens) = concatP appendPseudo scanBlock parseSelector tokens diff --git a/src/Data/CSS/Syntax/StyleSheet.hs b/src/Data/CSS/Syntax/StyleSheet.hs index 557e4fc..341916c 100644 --- a/src/Data/CSS/Syntax/StyleSheet.hs +++ b/src/Data/CSS/Syntax/StyleSheet.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Data.CSS.Syntax.StyleSheet ( parse, parse', TrivialStyleSheet(..), StyleSheet(..), skipAtRule, @@ -22,12 +23,12 @@ class StyleSheet s where addAtRule :: s -> Text -> [Token] -> (s, [Token]) addAtRule self _ tokens = (self, skipAtRule tokens) -addRules :: StyleSheet ss => ss -> ([Selector], [(Text, [Token])]) -> ss -addRules self (selector:selectors, properties) = addRules self' (selectors, properties) - where self' = addRule self $ StyleRule selector properties +addRules :: StyleSheet ss => ss -> ([Selector], ([(Text, [Token])], Text)) -> ss +addRules self (selector:selectors, val@(props, psuedoel)) = addRules self' (selectors, val) + where self' = addRule self $ StyleRule selector props psuedoel addRules self ([], _) = self -data StyleRule = StyleRule Selector [(Text, [Token])] deriving (Show, Eq) +data StyleRule = StyleRule Selector [(Text, [Token])] Text deriving (Show, Eq) data TrivialStyleSheet = TrivialStyleSheet [StyleRule] deriving (Show, Eq) instance StyleSheet TrivialStyleSheet where @@ -56,12 +57,17 @@ parse' stylesheet tokens = parse' (addRules stylesheet rule) tokens' -------- ---- Property parsing -------- -parseProperties :: Parser [(Text, [Token])] -parseProperties (LeftCurlyBracket:tokens) = parseProperties' tokens +parseProperties :: Parser ([(Text, [Token])], Text) +parseProperties (LeftCurlyBracket:tokens) = noPsuedoel $ parseProperties' tokens parseProperties (Whitespace:tokens) = parseProperties tokens +parseProperties (Colon:Colon:Ident n:tokens) = ((val, n), tokens') + where ((val, _), tokens') = parseProperties tokens -- This error recovery is a bit overly conservative, but it's simple. -parseProperties (_:tokens) = ([], skipAtRule tokens) -parseProperties [] = ([], []) +parseProperties (_:tokens) = noPsuedoel ([], skipAtRule tokens) +parseProperties [] = noPsuedoel ([], []) + +noPsuedoel :: (x, y) -> ((x, Text), y) +noPsuedoel (val, tokens) = ((val, ""), tokens) parseProperties' :: Parser [(Text, [Token])] parseProperties' (Whitespace:tokens) = parseProperties' tokens diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 886c953..25f1931 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -52,7 +52,7 @@ library -- Modules included in this library but not exported. other-modules: Data.CSS.Syntax.StylishUtil, - Data.CSS.Style.Importance, Data.CSS.Style.Common, + Data.CSS.Style.Importance, Data.CSS.Style.Common, Data.CSS.Style.Cascade, Data.CSS.Style.Selector.Index, Data.CSS.Style.Selector.Interpret, Data.CSS.Style.Selector.Specificity -- LANGUAGE extensions used by modules in this package. diff --git a/test/Test.hs b/test/Test.hs index 81ac26f..5e405bb 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -40,48 +40,48 @@ spec = do StyleRule (Element [Tag "bedroom"]) [ ("drapes", [Ident "blue"]), ("carpet", [Ident "wool", Ident "shag"]) - ]] + ] ""] parse emptyStyle " bathroom{tile :1in white;drapes :pink}" `shouldBe` TrivialStyleSheet [ StyleRule (Element [Tag "bathroom"]) [ ("tile", [Dimension "1" (NVInteger 1) "in", Ident "white"]), ("drapes", [Ident "pink"]) - ]] + ] ""] it "Parses selectors" $ do parse emptyStyle ".class {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Element [Class "class"]) [] + StyleRule (Element [Class "class"]) [] "" ] parse emptyStyle "*.class {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Element [Class "class"]) [] + StyleRule (Element [Class "class"]) [] "" ] parse emptyStyle "#id {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Element [Id "id"]) [] + StyleRule (Element [Id "id"]) [] "" ] parse emptyStyle "[attr] {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Element [Property "attr" Exists]) [] + StyleRule (Element [Property "attr" Exists]) [] "" ] parse emptyStyle "a , b {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Element [Tag "b"]) [], - StyleRule (Element [Tag "a"]) [] + StyleRule (Element [Tag "b"]) [] "", + StyleRule (Element [Tag "a"]) [] "" ] parse emptyStyle "a b {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Descendant (Element [Tag "a"]) [Tag "b"]) [] + StyleRule (Descendant (Element [Tag "a"]) [Tag "b"]) [] "" ] parse emptyStyle "a > b {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Child (Element [Tag "a"]) [Tag "b"]) [] + StyleRule (Child (Element [Tag "a"]) [Tag "b"]) [] "" ] parse emptyStyle "a ~ b {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Sibling (Element [Tag "a"]) [Tag "b"]) [] + StyleRule (Sibling (Element [Tag "a"]) [Tag "b"]) [] "" ] parse emptyStyle "a + b {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Adjacent (Element [Tag "a"]) [Tag "b"]) [] + StyleRule (Adjacent (Element [Tag "a"]) [Tag "b"]) [] "" ] parse emptyStyle "a::before {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Element [Tag "a", Psuedoelement "before"]) [] + StyleRule (Element [Tag "a"]) [] "before" ] parse emptyStyle "a:before {}" `shouldBe` TrivialStyleSheet [ - StyleRule (Element [Tag "a", Psuedoclass "before" []]) [] + StyleRule (Element [Tag "a", Psuedoclass "before" []]) [] "" ] describe "Style Index" $ do it "Retrieves appropriate styles" $ do @@ -105,17 +105,17 @@ spec = do rulesForElement index element `shouldBe` [sampleRule] rulesForElement index element2 `shouldBe` [] - let rule1 = StyleRule (Element [Class "external"]) [("color", [Ident "green"])] + let rule1 = StyleRule (Element [Class "external"]) [("color", [Ident "green"])] "" let index1 = addStyleRule styleIndex 0 $ styleRule' rule1 rulesForElement index1 element `shouldBe` [rule1] rulesForElement index1 element2 `shouldBe` [] - let rule2 = StyleRule (Element [Id "mysite"]) [("color", [Ident "green"])] + let rule2 = StyleRule (Element [Id "mysite"]) [("color", [Ident "green"])] "" let index2 = addStyleRule styleIndex 0 $ styleRule' rule2 rulesForElement index2 element `shouldBe` [rule2] rulesForElement index2 element2 `shouldBe` [] - let rule3 = StyleRule (Element [Property "href" $ Prefix "https://"]) [("color", [Ident "green"])] + let rule3 = StyleRule (Element [Property "href" $ Prefix "https://"]) [("color", [Ident "green"])] "" let index3 = addStyleRule styleIndex 0 $ styleRule' rule3 rulesForElement index3 element `shouldBe` [rule3] rulesForElement index3 element2 `shouldBe` [] @@ -282,16 +282,16 @@ spec = do it "does not regress" $ do parse emptyStyle "output: {content: 'Output'; pitch: high}" `shouldBe` TrivialStyleSheet [ - StyleRule (Element [Tag "output"]) [] + StyleRule (Element [Tag "output"]) [] "" ] -- Turned out to just be incorrect parsing parse emptyStyle "input, output {content: attr(value)}" `shouldBe` TrivialStyleSheet [ StyleRule (Element [Tag "output"]) [ ("content", [Function "attr", Ident "value", RightParen]) - ], + ] "", StyleRule (Element [Tag "input"]) [ ("content", [Function "attr", Ident "value", RightParen]) - ] + ] "" ] it "paren balancing" $ do scanValue [RightParen] `shouldBe` ([], [RightParen]) @@ -309,4 +309,4 @@ emptyStyle = TrivialStyleSheet [] linkStyle :: TrivialStyleSheet linkStyle = TrivialStyleSheet [sampleRule] sampleRule :: StyleRule -sampleRule = StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] +sampleRule = StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] "" -- 2.30.2