From af343c17aff209814fad0bbc9918eb2fda049ee7 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 12 Jul 2019 15:26:24 +1200 Subject: [PATCH] Switch to new namespace for consistency with other modules like css-syntax. --- src/Data/CSS/Style.hs | 3 +- src/Data/CSS/Style/Selector/Specificity.hs | 2 +- src/Data/CSS/Syntax/Selector.hs | 2 +- src/Data/CSS/Syntax/StyleSheet.hs | 2 +- src/Data/CSS/Syntax/StylishUtil.hs | 2 +- src/Stylish/Element.hs | 13 --- src/Stylish/Parse.hs | 98 ---------------------- src/Stylish/Parse/Selector.hs | 75 ----------------- src/Stylish/Parse/Utils.hs | 34 -------- src/Stylish/Style.hs | 25 ------ src/Stylish/Style/Selector.hs | 80 ------------------ src/Stylish/Style/Selector/Common.hs | 31 ------- src/Stylish/Style/Selector/Importance.hs | 30 ------- src/Stylish/Style/Selector/Index.hs | 89 -------------------- src/Stylish/Style/Selector/Interpret.hs | 92 -------------------- src/Stylish/Style/Selector/Specificity.hs | 36 -------- stylish-haskell.cabal | 4 +- test/Test.hs | 13 +-- 18 files changed, 15 insertions(+), 616 deletions(-) delete mode 100644 src/Stylish/Element.hs delete mode 100644 src/Stylish/Parse.hs delete mode 100644 src/Stylish/Parse/Selector.hs delete mode 100644 src/Stylish/Parse/Utils.hs delete mode 100644 src/Stylish/Style.hs delete mode 100644 src/Stylish/Style/Selector.hs delete mode 100644 src/Stylish/Style/Selector/Common.hs delete mode 100644 src/Stylish/Style/Selector/Importance.hs delete mode 100644 src/Stylish/Style/Selector/Index.hs delete mode 100644 src/Stylish/Style/Selector/Interpret.hs delete mode 100644 src/Stylish/Style/Selector/Specificity.hs diff --git a/src/Data/CSS/Style.hs b/src/Data/CSS/Style.hs index 238ca67..b9b87e8 100644 --- a/src/Data/CSS/Style.hs +++ b/src/Data/CSS/Style.hs @@ -9,6 +9,7 @@ import Data.CSS.Style.Selector.Interpret import Data.CSS.Style.Selector.Specificity import Data.CSS.Style.Importance import Data.CSS.Style.Common +import Data.CSS.Syntax.StyleSheet (StyleSheet(..)) -- TODO do performance tests to decide beside between strict/lazy, -- or is another Map implementation better? @@ -58,7 +59,7 @@ class PropertyParser a where cascade :: PropertyParser p => QueryableStyleSheet p -> Element -> p -> p cascade self el parent = dispatch parent parent $ toList $ cascadeRules $ queryRules self el -dispatch parent child (name, value):props +dispatch parent child ((name, value):props) | Just child' <- longhand parent child name value = dispatch parent child' props | otherwise = dispatch parent child props diff --git a/src/Data/CSS/Style/Selector/Specificity.hs b/src/Data/CSS/Style/Selector/Specificity.hs index 5891b16..d1dfd5e 100644 --- a/src/Data/CSS/Style/Selector/Specificity.hs +++ b/src/Data/CSS/Style/Selector/Specificity.hs @@ -2,7 +2,7 @@ module Data.CSS.Style.Selector.Specificity( OrderedRuleStore(..) ) where -import Stylish.Parse.Selector +import Data.CSS.Syntax.Selector import Data.CSS.Style.Common import Data.List diff --git a/src/Data/CSS/Syntax/Selector.hs b/src/Data/CSS/Syntax/Selector.hs index f5bc392..9580f98 100644 --- a/src/Data/CSS/Syntax/Selector.hs +++ b/src/Data/CSS/Syntax/Selector.hs @@ -4,7 +4,7 @@ module Data.CSS.Syntax.Selector( ) where import Data.CSS.Syntax.Tokens -import Data.CSS.Syntax.StylishUtils +import Data.CSS.Syntax.StylishUtil import Data.Text.Internal (Text(..)) diff --git a/src/Data/CSS/Syntax/StyleSheet.hs b/src/Data/CSS/Syntax/StyleSheet.hs index ab800ec..84de2b2 100644 --- a/src/Data/CSS/Syntax/StyleSheet.hs +++ b/src/Data/CSS/Syntax/StyleSheet.hs @@ -6,7 +6,7 @@ module Data.CSS.Syntax.StyleSheet ( import Data.CSS.Syntax.Tokens import Data.CSS.Syntax.Selector -import Data.CSS.Syntax.StylishUtils +import Data.CSS.Syntax.StylishUtil import Data.Text.Internal (Text(..)) diff --git a/src/Data/CSS/Syntax/StylishUtil.hs b/src/Data/CSS/Syntax/StylishUtil.hs index 687abfe..3995f4f 100644 --- a/src/Data/CSS/Syntax/StylishUtil.hs +++ b/src/Data/CSS/Syntax/StylishUtil.hs @@ -1,4 +1,4 @@ -module Data.CSS.Syntax.StylishUtils( +module Data.CSS.Syntax.StylishUtil( concatP, capture, skipSpace, scanBlock, skipBlock, scanInner ) where diff --git a/src/Stylish/Element.hs b/src/Stylish/Element.hs deleted file mode 100644 index 2416455..0000000 --- a/src/Stylish/Element.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Stylish.Element( - Element(..), Attribute(..) - ) where - -import Data.Text.Internal (Text(..)) - -data Element = ElementNode { - parent :: Maybe Element, - previous :: Maybe Element, - name :: Text, - attributes :: [Attribute] -- in sorted order. -} -data Attribute = Attribute Text String diff --git a/src/Stylish/Parse.hs b/src/Stylish/Parse.hs deleted file mode 100644 index e13a9dd..0000000 --- a/src/Stylish/Parse.hs +++ /dev/null @@ -1,98 +0,0 @@ -module Stylish.Parse ( - parse, TrivialStyleSheet(..), - skipAtRule, - StyleSheet, addRule, addAtRule, - StyleRule(..), - Selector(..), SimpleSelector(..), PropertyTest(..) - ) where - -import Data.CSS.Syntax.Tokens -import Stylish.Parse.Selector -import Stylish.Parse.Utils - -import Data.Text.Internal (Text(..)) - --------- ----- Output type class --------- -class StyleSheet s where - addRule :: s -> StyleRule -> s - addAtRule :: s -> Text -> [Token] -> (s, [Token]) - addAtRule self _ tokens = (self, skipAtRule tokens) - -addRules self (selector:selectors, properties) = addRules self' (selectors, properties) - where self' = addRule self $ StyleRule selector properties -addRules self ([], _) = self - -data StyleRule = StyleRule Selector [(Text, [Token])] deriving (Show, Eq) - -data TrivialStyleSheet = TrivialStyleSheet [StyleRule] deriving (Show, Eq) -instance StyleSheet TrivialStyleSheet where - addRule (TrivialStyleSheet self) rule = TrivialStyleSheet $ rule:self - --------- ----- Basic parsing --------- -parse :: StyleSheet s => s -> Text -> s -parse stylesheet source = parse' stylesheet $ tokenize source - --- Things to skip. -parse' stylesheet (Whitespace:tokens) = parse' stylesheet tokens -parse' stylesheet (CDO:tokens) = parse' stylesheet tokens -parse' stylesheet (CDC:tokens) = parse' stylesheet tokens -parse' stylesheet (Comma:tokens) = parse' stylesheet tokens -- TODO issue warnings. - -parse' stylesheet [] = stylesheet - -parse' stylesheet (AtKeyword kind:tokens) = parse' stylesheet' tokens' - where (stylesheet', tokens') = addAtRule stylesheet kind tokens -parse' stylesheet tokens = parse' (addRules stylesheet rule) tokens' - where (rule, tokens') = concatP (,) parseSelectors parseProperties tokens - --------- ----- Property parsing --------- -parseProperties (LeftCurlyBracket:tokens) = parseProperties' tokens -parseProperties (Whitespace:tokens) = parseProperties tokens -parseProperties [] = ([], []) - -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 -parseProperties' (RightCurlyBracket:tokens) = ([], tokens) -parseProperties' [] = ([], []) -parseProperties' tokens = parseProperties' (skipValue tokens) - --------- ----- Skipping/Scanning utilities --------- -skipAtRule :: [Token] -> [Token] -skipAtRule (Semicolon:tokens) = tokens -skipAtRule (LeftCurlyBracket:tokens) = skipBlock tokens - -skipAtRule (LeftParen:tokens) = skipAtRule $ skipBlock tokens -skipAtRule (LeftSquareBracket:tokens) = skipAtRule $ skipBlock tokens --- To ensure parens are balanced, should already be handled. -skipAtRule (RightCurlyBracket:tokens) = RightCurlyBracket:tokens -skipAtRule (RightParen:tokens) = RightParen:tokens -skipAtRule (RightSquareBracket:tokens) = RightSquareBracket:tokens - -skipAtRule (_:tokens) = skipAtRule tokens -skipAtRule [] = [] - -scanValue (Semicolon:tokens) = ([], tokens) -scanValue (Whitespace:tokens) = scanValue tokens - -scanValue (LeftCurlyBracket:tokens) = scanInner tokens scanValue -scanValue (LeftParen:tokens) = scanInner tokens scanValue -scanValue (LeftSquareBracket:tokens) = scanInner tokens scanValue --- To ensure parens are balanced, should already be handled. -scanValue (RightCurlyBracket:tokens) = ([], RightCurlyBracket:tokens) -scanValue (RightParen:tokens) = ([], RightParen:tokens) -scanValue (RightSquareBracket:tokens) = ([], RightSquareBracket:tokens) - -scanValue tokens = capture scanValue tokens - -skipValue tokens = snd $ scanValue tokens diff --git a/src/Stylish/Parse/Selector.hs b/src/Stylish/Parse/Selector.hs deleted file mode 100644 index b27f7c2..0000000 --- a/src/Stylish/Parse/Selector.hs +++ /dev/null @@ -1,75 +0,0 @@ -module Stylish.Parse.Selector( - Selector(..), SimpleSelector(..), PropertyTest(..), - parseSelectors - ) where - -import Data.CSS.Syntax.Tokens -import Stylish.Parse.Utils - -import Data.Text.Internal (Text(..)) - --- type Selector = [SimpleSelector] -data Selector = Element [SimpleSelector] | - Child Selector [SimpleSelector] | Descendant Selector [SimpleSelector] | - Adjacent Selector [SimpleSelector] | Sibling Selector [SimpleSelector] - deriving (Show, Eq) -data SimpleSelector = Tag Text | Id Text | Class Text | Property Text PropertyTest - deriving (Show, Eq) -data PropertyTest = Exists | Equals Text | Suffix Text | Prefix Text | Substring Text | - Include Text | Dash Text - deriving (Show, Eq) - -parseSelectors :: [Token] -> ([Selector], [Token]) -parseSelectors tokens = concatP (:) parseCompound parseSelectorsTail $ skipSpace tokens -parseSelectorsTail (Comma:tokens) = parseSelectors tokens -parseSelectorsTail tokens = ([], tokens) -parseCompound tokens = parseCombinators (Element selector) tokens' - where (selector, tokens') = parseSelector tokens - -parseSelector' op tokens = (op:selector, tokens') - where (selector, tokens') = parseSelector tokens - -parseSelector (Delim '*':tokens) = parseSelector tokens -parseSelector (Ident tag:tokens) = parseSelector' (Tag tag) tokens -parseSelector (Hash _ id:tokens) = parseSelector' (Id id) tokens -parseSelector (Delim '.':Ident class_:tokens) = parseSelector' (Class class_) tokens -parseSelector (LeftSquareBracket:Ident prop:tokens) = - concatP appendPropertySel parsePropertySel parseSelector tokens - where appendPropertySel test selector = Property prop test : selector -parseSelector tokens = ([], tokens) - -parseCombinators' selector tokens = parseCombinators selector' tokens' - where (selector', tokens') = parseCombinator selector tokens -parseCombinators selector (Whitespace:tokens) = parseCombinators' selector tokens -parseCombinators selector tokens@(Delim c:_) = parseCombinators' selector tokens -parseCombinators selector tokens = (selector, tokens) - -parseCombinator' cb selector tokens = (cb selector selector', tokens') - where (selector', tokens') = parseSelector $ skipSpace tokens -parseCombinator :: Selector -> [Token] -> (Selector, [Token]) -parseCombinator selector (Whitespace:tokens) = parseCombinator selector tokens -parseCombinator selector (Delim '>':tokens) = parseCombinator' Child selector tokens -parseCombinator selector (Delim '~':tokens) = parseCombinator' Sibling selector tokens -parseCombinator selector (Delim '+':tokens) = parseCombinator' Adjacent selector tokens --- Take special care to avoid adding a trailing Descendant when not needed. -parseCombinator selector tokens@(LeftCurlyBracket:_) = (selector, tokens) -parseCombinator selector tokens@(RightCurlyBracket:_) = (selector, tokens) -parseCombinator selector tokens@(RightSquareBracket:_) = (selector, tokens) -parseCombinator selector tokens@(Comma:_) = (selector, tokens) - -parseCombinator selector tokens@(RightParen:_) = (selector, tokens) -parseCombinator selector [] = (selector, []) - -parseCombinator selector tokens = parseCombinator' Descendant selector tokens - -parsePropertySel (RightSquareBracket:tokens) = (Exists, tokens) -parsePropertySel (Delim '=':tokens) = parsePropertyVal (Equals) tokens -parsePropertySel (SuffixMatch:tokens) = parsePropertyVal (Suffix) tokens -parsePropertySel (PrefixMatch:tokens) = parsePropertyVal (Prefix) tokens -parsePropertySel (SubstringMatch:tokens) = parsePropertyVal (Substring) tokens -parsePropertySel (IncludeMatch:tokens) = parsePropertyVal (Include) tokens -parsePropertySel (DashMatch:tokens) = parsePropertyVal (Dash) tokens -parsePropertySel tokens = (Exists, skipBlock tokens) - -parsePropertyVal wrapper (Ident val:RightSquareBracket:tokens) = (wrapper val, tokens) -parsePropertyVal wrapper (String val:RightSquareBracket:tokens) = (wrapper val, tokens) diff --git a/src/Stylish/Parse/Utils.hs b/src/Stylish/Parse/Utils.hs deleted file mode 100644 index e5e39b8..0000000 --- a/src/Stylish/Parse/Utils.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Stylish.Parse.Utils( - concatP, capture, skipSpace, - scanBlock, skipBlock, scanInner - ) where - -import Data.CSS.Syntax.Tokens - -concatP join left right tokens = (join x y, remainder) - where - (x, tokens') = left tokens - (y, remainder) = right tokens' - -capture cb (token:tokens) = (token:captured, tokens') - where (captured, tokens') = cb tokens -capture _ [] = ([], []) - -skipSpace (Whitespace:tokens) = skipSpace tokens -skipSpace tokens = tokens - --- TODO assert closing tags are correct --- But what should the error recovery be? -scanBlock (RightCurlyBracket:tokens) = ([RightCurlyBracket], tokens) -scanBlock (RightParen:tokens) = ([RightParen], tokens) -scanBlock (RightSquareBracket:tokens) = ([RightSquareBracket], tokens) - -scanBlock (LeftCurlyBracket:tokens) = scanInner tokens scanBlock -scanBlock (LeftParen:tokens) = scanInner tokens scanBlock -scanBlock (LeftSquareBracket:tokens) = scanInner tokens scanBlock - -scanBlock tokens = capture scanBlock tokens - -skipBlock tokens = snd $ scanBlock tokens - -scanInner tokens cb = concatP (++) scanBlock cb tokens diff --git a/src/Stylish/Style.hs b/src/Stylish/Style.hs deleted file mode 100644 index a428813..0000000 --- a/src/Stylish/Style.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Stylish.Style( - style, - Style(..), - Element(..), - Attribute(..), - ) where - -style :: Style a => Stylist a -> Element -> a --- Stylist consists of internal types, implements StyleSheet. - -class Style s where - initial :: s - shorthand :: Text -> [Token] -> [(Text, [Token])] - shorthand name value - | Just _ <- longhand initial initial name value = (name, value) - | otherwise = [] - longhand :: s -> s -> Text -> [Token] -> Maybe s - -data Element = Element { - prev :: Maybe Element, - parent :: Maybe Element, - name :: Text, - attrs :: [Attribute] -} -data Attribute = Attr Text Text diff --git a/src/Stylish/Style/Selector.hs b/src/Stylish/Style/Selector.hs deleted file mode 100644 index 24cb5b5..0000000 --- a/src/Stylish/Style/Selector.hs +++ /dev/null @@ -1,80 +0,0 @@ -module Stylish.Style.Selector( - QueryableStyleSheet(..), queryableStyleSheet, - queryRules, - PropertyParser(..), cascade - ) where - -import Stylish.Style.Selector.Index -import Stylish.Style.Selector.Interpret -import Stylish.Style.Selector.Specificity -import Stylish.Style.Selector.Importance -import Stylish.Style.Selector.Common - -import Stylish.Parse (StyleSheet(..), StyleRule(..)) - --- TODO do performance tests to decide beside between strict/lazy, --- or is another Map implementation better? -import Data.HashMap.Strict -import Data.Text.Internal (Text(..)) -import Data.CSS.Syntax.Tokens - -type QueryableStyleSheet parser = QueryableStyleSheet' (ImportanceSplitter ( - PropertyExpander parser (OrderedRuleStore (InterpretedRuleStore StyleIndex)) - )) parser - -data QueryableStyleSheet' store parser = QueryableStyleSheet' { - store :: store, - parser :: parser, - priority :: Int -- author vs user agent vs user styles -} - -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 - } - -queryRules (QueryableStyleSheet' store _ _) el = lookupRules store el - --------- ----- Cascade --------- - -cascadeRules rules = cascadeProperties $ concat $ Prelude.map properties rules - -cascadeProperties ((name, value):props) = insert name value $ cascadeProperties props - --------- ----- Dispatch to property definitions --------- - -class PropertyParser a where - temp :: a - shorthand :: a -> Text -> [Token] -> [(Text, [Token])] - shorthand self name value | Just _ <- longhand self self name value = [(name, value)] - | otherwise = [] - -- longhand parent self name value - longhand :: a -> a -> Text -> [Token] -> Maybe a - -cascade :: PropertyParser p => QueryableStyleSheet p -> Element -> p -> p -cascade self el parent = dispatch parent parent $ toList $ cascadeRules $ queryRules self el - -dispatch parent child (name, value):props - | Just child' <- longhand parent child name value = dispatch parent child' props - | otherwise = dispatch parent child props - ---- 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 -expandProperties _ [] = [] diff --git a/src/Stylish/Style/Selector/Common.hs b/src/Stylish/Style/Selector/Common.hs deleted file mode 100644 index 8995523..0000000 --- a/src/Stylish/Style/Selector/Common.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Stylish.Style.Selector.Common( - RuleStore(..), StyleRule'(..), selector, properties, styleRule' - ) where - -import Stylish.Element -import Stylish.Parse - -class RuleStore a where - new :: a - addStyleRule :: a -> Int -> StyleRule' -> a - lookupRules :: a -> Element -> [StyleRule'] - -type SelectorFunc = Element -> Bool -data StyleRule' = StyleRule' { - inner :: StyleRule, - compiledSelector :: SelectorFunc, - rank :: (Int, (Int, Int, Int), Int) -- This reads ugly, but oh well. -} -styleRule' rule = StyleRule' { - inner = rule, - compiledSelector = \_ -> True, - rank = (0, (0, 0, 0), 0) -} - -instance Eq StyleRule' where - a == b = inner a == inner b -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 diff --git a/src/Stylish/Style/Selector/Importance.hs b/src/Stylish/Style/Selector/Importance.hs deleted file mode 100644 index bd49e21..0000000 --- a/src/Stylish/Style/Selector/Importance.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Stylish.Style.Selector.Importance ( - splitProperties, ImportanceSplitter(..) - ) where - -import Data.CSS.Syntax.Tokens -import Data.Text.Internal (Text(..)) -import Stylish.Parse (StyleRule(..)) -import Stylish.Style.Selector.Common - -type Property = (Text, [Token]) -splitProperties :: [Property] -> ([Property], [Property]) -splitProperties (prop@(name, value):rest) - | (Ident "important":Delim '!':value') <- reverse value = - (unimportant, (name, reverse value'):important) - | otherwise = (prop:unimportant, important) - where (unimportant, important) = splitProperties rest - -data ImportanceSplitter a = ImportanceSplitter a -instance RuleStore inner => RuleStore (ImportanceSplitter inner) where - new = ImportanceSplitter new - addStyleRule (ImportanceSplitter self) priority rule = - ImportanceSplitter $ addStyleRule ( - addStyleRule self (negate priority) $ buildRule important - ) priority $ buildRule unimportant - where - (important, unimportant) = splitProperties properties - (StyleRule selector properties) = inner rule - buildRule properties = rule {inner = StyleRule selector properties} - lookupRules (ImportanceSplitter self) el = lookupRules self el diff --git a/src/Stylish/Style/Selector/Index.hs b/src/Stylish/Style/Selector/Index.hs deleted file mode 100644 index 9b04d7b..0000000 --- a/src/Stylish/Style/Selector/Index.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Stylish.Style.Selector.Index ( - StyleIndex(..), - rulesForElement - ) where - --- TODO do performance tests to decide beside between strict/lazy. -import Data.HashMap.Strict -import Data.List (nub) -import Stylish.Parse -import Stylish.Element -import Stylish.Style.Selector.Common - -import Data.Hashable -import Data.Text (unpack, pack) -import Data.Text.Internal (Text(..)) - -data StyleIndex = StyleIndex { - indexed :: HashMap SimpleSelector [StyleRule'], - unindexed :: [StyleRule'] -} - -lookup' :: SimpleSelector -> HashMap SimpleSelector [a] -> [a] -lookup' = lookupDefault [] - -instance RuleStore StyleIndex where - new = StyleIndex {indexed = empty, unindexed = []} - addStyleRule self _ rule | [] == properties rule = self - | otherwise = addRuleForSelector self rule $ simpleSelector $ selector rule - lookupRules self element = nub $ Prelude.foldr (++) [] rules - where - get key = lookup' key index - index = indexed self - rules = unindexed self : Prelude.map get (testsForElement element) - -rulesForElement :: StyleIndex -> Element -> [StyleRule] -- For testing -rulesForElement self element = Prelude.map inner $ lookupRules self element - ---- - -simpleSelector (Element s) = s -simpleSelector (Child _ s) = s -simpleSelector (Descendant _ s) = s -simpleSelector (Adjacent _ s) = s -simpleSelector (Sibling _ s) = s - -addRuleForSelector self rule [] = self {unindexed = rule : unindexed self} -addRuleForSelector self rule selector = self { - indexed = insert key (rule : lookup' key index) index - } where - key = selectorKey selector - index = indexed self - -selectorKey (tok@(Tag _) : _) = tok -selectorKey (tok@(Id _) : _) = tok -selectorKey (tok@(Class _) : _) = tok -selectorKey (Property prop _ : _) = Property prop Exists - ----- - -testsForElement :: Element -> [SimpleSelector] -testsForElement element = - (Tag $ name element) : (testsForAttributes $ attributes element) -testsForAttributes (Attribute "class" value:attrs) = - (Prelude.map (\s -> Class $ pack s) $ words value) ++ - (Property "class" Exists : testsForAttributes attrs) -testsForAttributes (Attribute "id" value:attrs) = - (Prelude.map (\s -> Id $ pack s) $ words value) ++ - (Property "id" Exists : testsForAttributes attrs) -testsForAttributes (Attribute name _:attrs) = - Property name Exists : testsForAttributes attrs -testsForAttributes [] = [] - --- Implement hashable for SimpleSelector here because it proved challenging to automatically derive it. -instance Hashable SimpleSelector where - hashWithSalt seed (Tag tag) = seed `hashWithSalt` (0::Int) `hashWithSalt` unpack tag - hashWithSalt seed (Id id) = seed `hashWithSalt` (1::Int) `hashWithSalt` unpack id - hashWithSalt seed (Class class_) = seed `hashWithSalt` (2::Int) `hashWithSalt` unpack class_ - hashWithSalt seed (Property prop test) = - seed `hashWithSalt` (3::Int) `hashWithSalt` unpack prop `hashWithSalt` test - -instance Hashable PropertyTest where - hashWithSalt seed Exists = seed `hashWithSalt` (0::Int) - hashWithSalt seed (Equals val) = seed `hashWithSalt` (1::Int) `hashWithSalt` unpack val - hashWithSalt seed (Suffix val) = seed `hashWithSalt` (2::Int) `hashWithSalt` unpack val - hashWithSalt seed (Prefix val) = seed `hashWithSalt` (3::Int) `hashWithSalt` unpack val - hashWithSalt seed (Substring val) = seed `hashWithSalt` (4::Int) `hashWithSalt` unpack val - hashWithSalt seed (Include val) = seed `hashWithSalt` (5::Int) `hashWithSalt` unpack val - hashWithSalt seed (Dash val) = seed `hashWithSalt` (6::Int) `hashWithSalt` unpack val diff --git a/src/Stylish/Style/Selector/Interpret.hs b/src/Stylish/Style/Selector/Interpret.hs deleted file mode 100644 index 5b57c93..0000000 --- a/src/Stylish/Style/Selector/Interpret.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Stylish.Style.Selector.Interpret( - compile, SelectorFunc(..), - InterpretedRuleStore(..) - ) where - -import Stylish.Parse.Selector -import Stylish.Element -import Stylish.Style.Selector.Common - -import Data.Text.Internal (Text(..)) -import Data.Text (unpack) -import Data.List -import Data.Maybe - -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 (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' :: (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 -compileAttrs :: [(Text, String -> Bool)] -> AttrsFunc -compileAttrs ((name, test):attrs) = testAttr name 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 [] = (Nothing, []) - -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 - -sortAttrs = sortBy compareAttrs where compareAttrs x y = fst x `compare` fst y - --------- ----- Runtime --------- -testTag :: Text -> SelectorFunc -> SelectorFunc -testTag tag success el | name el == tag = success el - | otherwise = False -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 - | 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 _ = 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 - | otherwise = False -testAttr _ _ _ [] = False - -hasWord expected value = expected `elem` words value -hasLang expected value = expected == value || isPrefixOf (expected ++ "-") value - --------- ----- RuleStore wrapper --------- -data InterpretedRuleStore inner = InterpretedRuleStore inner -instance RuleStore inner => RuleStore (InterpretedRuleStore inner) where - new = InterpretedRuleStore new - addStyleRule (InterpretedRuleStore self) priority rule = - InterpretedRuleStore $ addStyleRule self priority $ rule { - compiledSelector = compile $ selector rule - } - lookupRules (InterpretedRuleStore self) el = filter call $ lookupRules self el - where call (StyleRule' _ test _) = test el diff --git a/src/Stylish/Style/Selector/Specificity.hs b/src/Stylish/Style/Selector/Specificity.hs deleted file mode 100644 index 9d93bae..0000000 --- a/src/Stylish/Style/Selector/Specificity.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Stylish.Style.Selector.Specificity( - OrderedRuleStore(..) - ) where - -import Stylish.Parse.Selector -import Stylish.Style.Selector.Common -import Data.List - -computeSpecificity :: Selector -> (Int, Int, Int) -computeSpecificity (Element selector) = computeSpecificity' selector -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' (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 (a, b, c) (x, y, z) = (a + x, b + y, c + z) - ---- - -data OrderedRuleStore inner = OrderedRuleStore inner Int - -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) - } - ) (count + 1) - lookupRules (OrderedRuleStore self _) el = sort $ lookupRules self el diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 691cc06..3f1080f 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -48,7 +48,7 @@ cabal-version: >=1.10 library -- Modules exported by the library. - -- exposed-modules: Stylish.Parse + -- exposed-modules: Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style -- Modules included in this library but not exported. -- other-modules: @@ -70,5 +70,5 @@ test-suite test-stylish default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Test.hs - other-modules: Stylish.Parse + other-modules: Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style build-depends: base >=4.9 && <4.10, css-syntax, text, unordered-containers, hashable, hspec, QuickCheck diff --git a/test/Test.hs b/test/Test.hs index ca6fa46..8642dd4 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -5,12 +5,13 @@ import Test.Hspec import Test.Hspec.QuickCheck import Data.CSS.Syntax.Tokens -import Stylish.Parse -import Stylish.Style.Selector.Index -import Stylish.Element -import Stylish.Style.Selector.Interpret -import Stylish.Style.Selector.Common -import Stylish.Style.Selector +import Data.CSS.Syntax.StyleSheet +import Data.CSS.Syntax.Selector + +import Data.CSS.Style.Common +import Data.CSS.Style.Selector.Index +import Data.CSS.Style.Selector.Interpret +import Data.CSS.Style main :: IO () main = hspec spec -- 2.30.2