11 files changed, 79 insertions(+), 63 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/Index.hs
M src/Data/CSS/Style/Selector/Interpret.hs
M src/Data/CSS/Style/Selector/Specificity.hs
M src/Data/CSS/Syntax/Selector.hs
M src/Data/CSS/Syntax/StyleSheet.hs
M stylish-haskell.cabal
M test/Test.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

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

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

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

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

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

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

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

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

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

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