7 files changed, 78 insertions(+), 55 deletions(-)

M src/Data/CSS/Style.hs
M src/Data/CSS/Style/Cascade.hs
M src/Data/CSS/Style/Common.hs
M src/Data/CSS/Style/Importance.hs
M src/Data/CSS/Style/Selector/Interpret.hs
M src/Data/CSS/Style/Selector/Specificity.hs
M src/Data/CSS/Syntax/StyleSheet.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 _ [] = []

@@ 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

@@ 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

@@ 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

@@ 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
 
 --------

@@ 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)
 
 ---

@@ 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