From 00ed62a198671f24b6c02825f5a58725297478cd Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 15 Jul 2019 15:39:09 +1200 Subject: [PATCH] Code cleanliness fixes. --- src/Data/CSS/Style.hs | 32 ++++++++-------- src/Data/CSS/Style/Cascade.hs | 23 +++++++----- src/Data/CSS/Style/Common.hs | 9 +++-- src/Data/CSS/Style/Importance.hs | 10 ++--- src/Data/CSS/Style/Selector/Interpret.hs | 43 +++++++++++++--------- src/Data/CSS/Style/Selector/Specificity.hs | 8 ++-- src/Data/CSS/Syntax/StyleSheet.hs | 8 +++- 7 files changed, 78 insertions(+), 55 deletions(-) diff --git a/src/Data/CSS/Style.hs b/src/Data/CSS/Style.hs index 333a72b..a59bbd2 100644 --- a/src/Data/CSS/Style.hs +++ b/src/Data/CSS/Style.hs @@ -1,5 +1,5 @@ module Data.CSS.Style( - QueryableStyleSheet(..), QueryableStyleSheet'(..), queryableStyleSheet, + QueryableStyleSheet, QueryableStyleSheet'(..), queryableStyleSheet, queryRules, PropertyParser(..), cascade, TrivialPropertyParser(..), @@ -14,9 +14,6 @@ import Data.CSS.Style.Common import qualified Data.CSS.Style.Cascade as Cascade import Data.CSS.Style.Cascade (PropertyParser(..), TrivialPropertyParser) --- TODO do performance tests to decide beside between strict/lazy, --- or is another Map implementation better? -import Data.HashMap.Strict import Data.CSS.Syntax.Tokens (Token) import Data.CSS.Syntax.StyleSheet (StyleSheet(..)) @@ -34,29 +31,32 @@ queryableStyleSheet :: PropertyParser p => QueryableStyleSheet p queryableStyleSheet = QueryableStyleSheet' {store = new, parser = temp, priority = 0} instance (RuleStore s, PropertyParser p) => StyleSheet (QueryableStyleSheet' s p) where - addRule self@(QueryableStyleSheet' store _ priority) rule = self { - store = addStyleRule store priority $ styleRule' rule + addRule self@(QueryableStyleSheet' store' _ priority') rule = self { + store = addStyleRule store' priority' $ styleRule' rule } -queryRules (QueryableStyleSheet' store _ _) el = lookupRules store el +queryRules :: PropertyParser p => QueryableStyleSheet p -> Element -> [StyleRule'] +queryRules (QueryableStyleSheet' store' _ _) el = lookupRules store' el -------- ---- Cascade -------- cascade :: PropertyParser p => QueryableStyleSheet p -> Element -> [(Text, [Token])] -> p -> p -cascade (QueryableStyleSheet' store _ _) = Cascade.cascade store +cascade (QueryableStyleSheet' store' _ _) = Cascade.cascade store' --- Verify syntax during parsing, so invalid properties don't interfere with cascade. data PropertyExpander parser inner = PropertyExpander parser inner instance (PropertyParser parser, RuleStore inner) => RuleStore (PropertyExpander parser inner) where new = PropertyExpander temp new - addStyleRule (PropertyExpander parser inner) priority rule = - PropertyExpander parser $ addStyleRule inner priority $ expandRule parser rule - lookupRules (PropertyExpander _ inner) el = lookupRules inner el - -expandRule parser rule = rule {inner = StyleRule selector $ expandProperties parser properties} - where (StyleRule selector properties) = inner rule -expandProperties parser ((name, value):props) = - shorthand parser name value ++ expandProperties parser props + addStyleRule (PropertyExpander parser' inner') priority' rule = + PropertyExpander parser' $ addStyleRule inner' priority' $ expandRule parser' rule + 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 +expandProperties :: PropertyParser t => t -> [(Text, [Token])] -> [(Text, [Token])] +expandProperties parser' ((key, value):props) = + shorthand parser' key value ++ expandProperties parser' props expandProperties _ [] = [] diff --git a/src/Data/CSS/Style/Cascade.hs b/src/Data/CSS/Style/Cascade.hs index 19e6b36..4ffa505 100644 --- a/src/Data/CSS/Style/Cascade.hs +++ b/src/Data/CSS/Style/Cascade.hs @@ -10,16 +10,13 @@ import Data.CSS.Syntax.Tokens import Data.HashMap.Strict import Data.Text (unpack) -cascadeRules overrides rules = cascadeProperties overrides $ concat $ Prelude.map properties rules -cascadeProperties overrides props = fromList (props ++ overrides) - class PropertyParser a where temp :: a inherit :: a -> a inherit = id shorthand :: a -> Text -> [Token] -> [(Text, [Token])] - shorthand self name value | Just _ <- longhand self self name value = [(name, value)] + shorthand self key value | Just _ <- longhand self self key value = [(key, value)] | otherwise = [] -- longhand parent self name value longhand :: a -> a -> Text -> [Token] -> Maybe a @@ -30,11 +27,19 @@ instance PropertyParser TrivialPropertyParser where longhand _ (TrivialPropertyParser self) key value = Just $ TrivialPropertyParser $ insert (unpack key) value self -cascade :: (PropertyParser p, RuleStore s) => s -> Element -> [(Text, [Token])] -> p -> p -cascade self el overrides parent = dispatch parent (inherit parent) $ +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 -dispatch parent child ((name, value):props) - | Just child' <- longhand parent child name value = dispatch parent child' props - | otherwise = dispatch parent child props +cascadeRules :: Props -> [StyleRule'] -> HashMap Text [Token] +cascadeRules overrides rules = cascadeProperties overrides $ concat $ Prelude.map properties rules +cascadeProperties :: Props -> Props -> HashMap Text [Token] +cascadeProperties overrides props = fromList (props ++ overrides) + +dispatch :: PropertyParser p => p -> p -> Props -> p +dispatch base child ((key, value):props) + | Just child' <- longhand base child key value = dispatch base child' props + | otherwise = dispatch base child props dispatch _ child [] = child diff --git a/src/Data/CSS/Style/Common.hs b/src/Data/CSS/Style/Common.hs index 5ba50bb..d6a15a3 100644 --- a/src/Data/CSS/Style/Common.hs +++ b/src/Data/CSS/Style/Common.hs @@ -7,7 +7,7 @@ module Data.CSS.Style.Common( import Data.CSS.Syntax.StyleSheet import Data.CSS.Syntax.Selector - +import Data.CSS.Syntax.Tokens import Data.Text.Internal (Text(..)) data Element = ElementNode { @@ -29,6 +29,7 @@ data StyleRule' = StyleRule' { compiledSelector :: SelectorFunc, rank :: (Int, (Int, Int, Int), Int) -- This reads ugly, but oh well. } +styleRule' :: StyleRule -> StyleRule' styleRule' rule = StyleRule' { inner = rule, compiledSelector = \_ -> True, @@ -40,5 +41,7 @@ instance Eq StyleRule' where instance Show StyleRule' where show a = show $ inner a instance Ord StyleRule' where compare x y = rank x `compare` rank y -selector rule | StyleRule selector _ <- inner rule = selector -properties rule | StyleRule _ properties <- inner rule = properties +selector :: StyleRule' -> Selector +selector rule | StyleRule sel _ <- inner rule = sel +properties :: StyleRule' -> [(Text, [Data.CSS.Syntax.Tokens.Token])] +properties rule | StyleRule _ props <- inner rule = props diff --git a/src/Data/CSS/Style/Importance.hs b/src/Data/CSS/Style/Importance.hs index f63aac1..04ced87 100644 --- a/src/Data/CSS/Style/Importance.hs +++ b/src/Data/CSS/Style/Importance.hs @@ -8,9 +8,9 @@ import Data.CSS.Style.Common type Property = (Text, [Token]) splitProperties :: [Property] -> ([Property], [Property]) -splitProperties (prop@(name, value):rest) +splitProperties (prop@(key, value):rest) | (Ident "important":Delim '!':value') <- reverse value = - (unimportant, (name, reverse value'):important) + (unimportant, (key, reverse value'):important) | otherwise = (prop:unimportant, important) where (unimportant, important) = splitProperties rest splitProperties [] = ([], []) @@ -26,7 +26,7 @@ instance RuleStore inner => RuleStore (ImportanceSplitter inner) where addStyleRule self (negate priority) $ buildRule unimportant ) priority $ buildRule important where - (unimportant, important) = splitProperties properties - (StyleRule selector properties) = inner rule - buildRule properties = rule {inner = StyleRule selector properties} + (unimportant, important) = splitProperties props + (StyleRule sel props) = inner rule + buildRule x = rule {inner = StyleRule sel x} lookupRules (ImportanceSplitter self) el = lookupRules self el diff --git a/src/Data/CSS/Style/Selector/Interpret.hs b/src/Data/CSS/Style/Selector/Interpret.hs index 55c7e3a..a44524b 100644 --- a/src/Data/CSS/Style/Selector/Interpret.hs +++ b/src/Data/CSS/Style/Selector/Interpret.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Data.CSS.Style.Selector.Interpret( - compile, SelectorFunc(..), + compile, SelectorFunc, InterpretedRuleStore(..) ) where @@ -14,27 +14,30 @@ type SelectorFunc = Element -> Bool type AttrsFunc = [Attribute] -> Bool compile :: Selector -> SelectorFunc -compile (Element selector) = compileInner selector -compile (Child upSelector selector) = direct parent (compile upSelector) $ compileInner selector +compile (Element sel) = compileInner sel +compile (Child upSel sel) = direct parent (compile upSel) $ compileInner sel compile (Descendant up sel) = indirect parent (compile up) $ compileInner sel compile (Adjacent up sel) = direct previous (compile up) $ compileInner sel compile (Sibling up sel) = indirect previous (compile up) $ compileInner sel -compileInner selector = compileInner' $ lowerInner selector +compileInner :: [SimpleSelector] -> SelectorFunc +compileInner sel = compileInner' $ lowerInner sel compileInner' :: (Maybe Text, [(Text, String -> Bool)]) -> SelectorFunc -compileInner' (Just tag, attributes) = testTag tag $ testAttrs (compileAttrs $ sortAttrs attributes) matched -compileInner' (Nothing, attributes) = testAttrs (compileAttrs $ sortAttrs attributes) matched +compileInner' (Just tag, attrs) = testTag tag $ testAttrs (compileAttrs $ sortAttrs attrs) matched +compileInner' (Nothing, attrs) = testAttrs (compileAttrs $ sortAttrs attrs) matched compileAttrs :: [(Text, String -> Bool)] -> AttrsFunc -compileAttrs ((name, test):attrs) = testAttr name test $ compileAttrs attrs +compileAttrs ((tag, test):attrs) = testAttr tag test $ compileAttrs attrs compileAttrs [] = matched -lowerInner (Tag tag:selector) = (Just tag, snd $ lowerInner selector) -lowerInner (Id id:s) = (tag, ("id", hasWord $ unpack id):tail) where (tag, tail) = lowerInner s -lowerInner (Class c:s) = (tag, ("class", hasWord $ unpack c):tail) where (tag, tail) = lowerInner s -lowerInner (Property name test:s) = (tag, (name, compileAttrTest test):tail) - where (tag, tail) = lowerInner s +lowerInner :: [SimpleSelector] -> (Maybe Text, [(Text, String -> Bool)]) +lowerInner (Tag tag:sel) = (Just tag, snd $ lowerInner sel) +lowerInner (Id i:s) = (tag, ("id", hasWord $ unpack i):attrs) where (tag, attrs) = lowerInner s +lowerInner (Class c:s) = (tag, ("class", hasWord $ unpack c):attrs) where (tag, attrs) = lowerInner s +lowerInner (Property prop test:s) = (tag, (prop, compileAttrTest test):attrs) + where (tag, attrs) = lowerInner s lowerInner [] = (Nothing, []) +compileAttrTest :: PropertyTest -> String -> Bool compileAttrTest Exists = matched compileAttrTest (Equals val) = (== (unpack val)) compileAttrTest (Suffix val) = isSuffixOf $ unpack val @@ -43,6 +46,7 @@ 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 -------- @@ -54,25 +58,28 @@ testTag tag success el | name el == tag = success el testAttrs :: AttrsFunc -> SelectorFunc -> SelectorFunc testAttrs attrsTest success el | attrsTest $ attributes el = success el | otherwise = False -direct traverser upTest test el - | Just parent <- traverser el = test el && upTest parent +direct :: (Element -> Maybe Element) -> SelectorFunc -> SelectorFunc -> SelectorFunc +direct traverser upTest test el | Just up <- traverser el = test el && upTest up | otherwise = False indirect :: (Element -> Maybe Element) -> SelectorFunc -> SelectorFunc -> SelectorFunc 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 name value : attrs') - | name < expected = testAttr expected test next attrs' - | name > expected = False - | name == expected && test value = next 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 +hasWord :: String -> String -> Bool hasWord expected value = expected `elem` words value +hasLang :: [Char] -> [Char] -> Bool hasLang expected value = expected == value || isPrefixOf (expected ++ "-") value -------- diff --git a/src/Data/CSS/Style/Selector/Specificity.hs b/src/Data/CSS/Style/Selector/Specificity.hs index d1dfd5e..bc25f4b 100644 --- a/src/Data/CSS/Style/Selector/Specificity.hs +++ b/src/Data/CSS/Style/Selector/Specificity.hs @@ -6,20 +6,22 @@ import Data.CSS.Syntax.Selector import Data.CSS.Style.Common import Data.List -computeSpecificity :: Selector -> (Int, Int, Int) -computeSpecificity (Element selector) = computeSpecificity' selector +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' :: [SimpleSelector] -> Vec computeSpecificity' (Tag _:sel) = computeSpecificity' sel `add` (0, 0, 1) computeSpecificity' (Class _:sel) = computeSpecificity' sel `add` (0, 1, 0) computeSpecificity' (Property _ _:sel) = computeSpecificity' sel `add` (0, 1, 0) computeSpecificity' (Id _:sel) = computeSpecificity' sel `add` (1, 0, 0) computeSpecificity' [] = (0, 0, 0) -add :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int) +add :: Vec -> Vec -> Vec add (a, b, c) (x, y, z) = (a + x, b + y, c + z) --- diff --git a/src/Data/CSS/Syntax/StyleSheet.hs b/src/Data/CSS/Syntax/StyleSheet.hs index 9da707c..557e4fc 100644 --- a/src/Data/CSS/Syntax/StyleSheet.hs +++ b/src/Data/CSS/Syntax/StyleSheet.hs @@ -22,6 +22,7 @@ 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 self ([], _) = self @@ -38,6 +39,7 @@ instance StyleSheet TrivialStyleSheet where parse :: StyleSheet s => s -> Text -> s parse stylesheet source = parse' stylesheet $ tokenize source +parse' :: StyleSheet t => t -> [Token] -> t -- Things to skip. parse' stylesheet (Whitespace:tokens) = parse' stylesheet tokens parse' stylesheet (CDO:tokens) = parse' stylesheet tokens @@ -54,17 +56,19 @@ parse' stylesheet tokens = parse' (addRules stylesheet rule) tokens' -------- ---- Property parsing -------- +parseProperties :: Parser [(Text, [Token])] parseProperties (LeftCurlyBracket:tokens) = parseProperties' tokens parseProperties (Whitespace:tokens) = parseProperties tokens -- This error recovery is a bit overly conservative, but it's simple. parseProperties (_:tokens) = ([], skipAtRule tokens) parseProperties [] = ([], []) +parseProperties' :: Parser [(Text, [Token])] parseProperties' (Whitespace:tokens) = parseProperties' tokens parseProperties' (Ident name:tokens) | Colon:tokens' <- skipSpace tokens = concatP appendProp scanValue parseProperties' tokens' - where appendProp value tail = (name, value):tail + where appendProp value props = (name, value):props parseProperties' (RightCurlyBracket:tokens) = ([], tokens) parseProperties' [] = ([], []) parseProperties' tokens = parseProperties' (skipValue tokens) @@ -87,6 +91,7 @@ skipAtRule (RightSquareBracket:tokens) = RightSquareBracket:tokens skipAtRule (_:tokens) = skipAtRule tokens skipAtRule [] = [] +scanValue :: Parser [Token] scanValue (Semicolon:tokens) = ([], tokens) scanValue (Whitespace:tokens) = scanValue tokens @@ -101,4 +106,5 @@ scanValue (RightSquareBracket:tokens) = ([], RightSquareBracket:tokens) scanValue tokens = capture scanValue tokens +skipValue :: [Token] -> [Token] skipValue tokens = snd $ scanValue tokens -- 2.30.2