packages feed

stylist (empty) → 1.0.0.0

raw patch · 16 files changed

+1209/−0 lines, 16 filesdep +QuickCheckdep +basedep +css-syntaxsetup-changed

Dependencies added: QuickCheck, base, css-syntax, hashable, hspec, network-uri, text, unordered-containers

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for stylist++## 0.0.1  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2019 Adrian Cochrane++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,23 @@+# Haskell Stylist+Generic CSS style engine for Haskell, intended to aid the development of new browser engines.++Stylish Haskell implements CSS selection and cascade (but not inheritance) independant of the CSS at-rules and properties understood by the caller. It is intended to ease the development of new browser engines, independant of their output targets.++For more interesting projects see: https://github.io/alcinnz/browser-engine-ganarchy/++## Versioning+The second major number indicates that more of CSS has been implemented within the existing API. Until then the error recovery rules will ensure as yet invalid CSS won't have any effect.++The first major number indicates any other change to the API, and might break your code.++## API+To parse a CSS stylesheet call `Data.CSS.Syntax.StyleSheet.parse` which returns a variant of the passed in `StyleSheet`. `StyleSheet` is a typeclass specifying methods for parsing at-rules (`parseAtRule`), storing parsed style rules (`addRule`), and optionally setting the stylesheet's priority (`setPriority`).++If these ultimately call down into a `Data.CSS.Syntax.Style.QueryableStyleSheet` you can call `queryRules` to find all matching style rules organized by psuedoelement. Once you have these style rules (typically by specifying a psuedoelement) you can call `cascade'` to resolve them into any instance of `PropertyParser`. To query rules not targetting a psuedoelement, you can either lookup the "" psuedoelement or use the `cascade` shorthand.++`PropertyParser` allows to declaratively (via Haskell pattern matching) specify how to parse CSS properties, and how they're impacted by CSS inheritance. It has four methods: `longhand` and `shorthand` specify how to parse CSS properties, whilst `temp` and `inherit` specifies what the default values should be.++## Contributing+You can contributed code or register "issues" to Haskell Stylist by contacting me (Adrian Cochrane) via [mastodon](https://floss.social/@alcinnz/) or [email](mailto:adrian@openwork.nz). Or you can sign up for an account on the NZ OSS GitLab.++If you're contributing code you can link me to where you're hosting your git fork, or send [a patch file](https://git-send-email.io/). Or if you simply to ask for more features or fixes don't hesitate to contact me!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/CSS/Style.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.Style(+        QueryableStyleSheet, QueryableStyleSheet'(..), queryableStyleSheet,+        queryRules,+        PropertyParser(..), cascade, cascade', VarParser(..),+        TrivialPropertyParser(..),+        Element(..), Attribute(..)+    ) where++import Data.CSS.Style.Selector.Index+import Data.CSS.Style.Selector.Interpret+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, Props)++import Data.CSS.Syntax.Tokens (Token(..))+import Data.CSS.Syntax.StyleSheet (StyleSheet(..))+import Data.HashMap.Strict (HashMap, lookupDefault, fromList)+import Data.Text (isPrefixOf)+import Data.List (elemIndex)++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+    setPriority v self = self {priority = v}+    addRule self@(QueryableStyleSheet' store' _ priority') rule = self {+            store = addStyleRule store' priority' $ styleRule' rule+        }++--- Reexpose cascade methods+queryRules :: (PropertyParser p, RuleStore s) =>+    QueryableStyleSheet' s p -> Element -> HashMap Text [StyleRule']+queryRules (QueryableStyleSheet' store' _ _) = Cascade.query store'++cascade' :: PropertyParser p => [StyleRule'] -> Props -> p -> p+cascade' = Cascade.cascade++--- 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+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 :: PropertyParser t => t -> StyleRule' -> StyleRule'+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+expandProperties _ [] = []++--------+---- var()+--------+data VarParser a = VarParser {vars :: Props, innerParser :: a}++instance PropertyParser p => PropertyParser (VarParser p) where+    temp = VarParser [] temp+    inherit (VarParser vars' self) = VarParser vars' $ inherit self++    shorthand self name' value+        | Function "var" `elem` value || "--" `isPrefixOf` name' = [(name', value)] -- Fail during inheritance...+        | otherwise = shorthand (innerParser self) name' value+    longhand parent' self@(VarParser vars' inner') name' value+        | Function "var" `elem` value = resolveVars value (fromList vars') >>= longhand parent' self name'+        | otherwise = VarParser vars' <$> longhand (innerParser parent') inner' name' value++    getVars = vars+    setVars v self = self {vars = v}++resolveVars :: [Token] -> HashMap Text [Token] -> Maybe [Token]+resolveVars (Function "var":Ident var:RightParen:toks) ctxt = (lookupDefault [] var ctxt ++) <$> resolveVars toks ctxt+resolveVars (Function "var":Ident var:Comma:toks) ctxt+    | Just i <- RightParen `elemIndex` toks, (fallback, RightParen:toks') <- i `splitAt` toks =+        (lookupDefault fallback var ctxt ++) <$> resolveVars toks' ctxt+resolveVars (Function "var":_) _ = Nothing+resolveVars (tok:toks) ctxt = (tok:) <$> resolveVars toks ctxt+resolveVars [] _ = Just []
+ src/Data/CSS/Style/Cascade.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.Style.Cascade(+        query, cascade,+        TrivialPropertyParser(..), PropertyParser(..), Props+    ) where++import Data.CSS.Style.Common+import Data.CSS.Syntax.Tokens++-- TODO do performance tests to decide beside between strict/lazy,+--      or is another Map implementation better?+import Data.HashMap.Strict+import Data.Text (unpack, pack, isPrefixOf)++class PropertyParser a where+    temp :: a+    inherit :: a -> a+    inherit = id++    shorthand :: a -> Text -> [Token] -> [(Text, [Token])]+    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++    getVars :: a -> Props+    getVars _ = []+    setVars :: Props -> a -> a+    setVars _ = id++data TrivialPropertyParser = TrivialPropertyParser (HashMap String [Token])+instance PropertyParser TrivialPropertyParser where+    temp = TrivialPropertyParser empty+    longhand _ (TrivialPropertyParser self) key value =+        Just $ TrivialPropertyParser $ insert (unpack key) value self++type Props = [(Text, [Token])]++--------+---- Query/Psuedo-elements+--------++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) [resolveAttr rule el] store++--------+---- Cascade/Inheritance+--------++cascade :: PropertyParser p => [StyleRule'] -> Props -> p -> p+cascade styles overrides base =+    dispatch base (inherit base) $ toList $ cascadeRules (getVars base ++ overrides) styles++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, dispatch' :: PropertyParser p => p -> p -> Props -> p+dispatch base child props = dispatch' base (setVars vars child) props+    where vars = Prelude.filter (\(n, _) -> isPrefixOf "--" n) props+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++--------+---- attr()+--------+resolveAttr :: StyleRule' -> Element -> StyleRule'+resolveAttr self el = self {+        inner = StyleRule sel [(n, resolveAttr' v $ attrs2Dict el) | (n, v) <- attrs] psuedo+    } where StyleRule sel attrs psuedo = inner self++attrs2Dict :: Element -> HashMap Text String+attrs2Dict el = fromList [(a, b) | Attribute a b <- attributes el]++resolveAttr' :: [Token] -> HashMap Text String  -> [Token]+resolveAttr' (Function "attr":Ident attr:RightParen:toks) attrs =+    String (pack $ lookupDefault "" attr attrs) : resolveAttr' toks attrs+resolveAttr' (tok:toks) attrs = tok : resolveAttr' toks attrs+resolveAttr' [] _ = []
+ src/Data/CSS/Style/Common.hs view
@@ -0,0 +1,49 @@+module Data.CSS.Style.Common(+        RuleStore(..), StyleRule'(..), selector, properties, psuedoElement, styleRule',+        Element(..), Attribute(..),+        -- Re-exports+        Text(..), StyleRule(..), Selector(..), SimpleSelector(..), PropertyTest(..)+    ) where++import Data.CSS.Syntax.StyleSheet+import Data.CSS.Syntax.Selector+import Data.CSS.Syntax.Tokens+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 deriving (Eq, Ord)++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' :: StyleRule -> StyleRule'+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 :: StyleRule' -> Selector+selector rule | StyleRule sel _ _ <- inner rule = sel+properties :: StyleRule' -> [(Text, [Data.CSS.Syntax.Tokens.Token])]+properties rule | StyleRule _ props _ <- inner rule = props+psuedoElement :: StyleRule' -> Text+psuedoElement rule | StyleRule _ _ psuedo <- inner rule = psuedo
+ src/Data/CSS/Style/Importance.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.Style.Importance (+        ImportanceSplitter(..)+    ) where++import Data.CSS.Syntax.Tokens+import Data.CSS.Style.Common++type Property = (Text, [Token])+splitProperties :: [Property] -> ([Property], [Property])+splitProperties (prop@(key, value):rest)+        | (Ident "important":Delim '!':value') <- reverse value =+            (unimportant, (key, reverse value'):important)+        | otherwise = (prop:unimportant, important)+    where (unimportant, important) = splitProperties rest+splitProperties [] = ([], [])++--- NOTE: Prorities are defined with lower numbers being more important,+---     so negate to be consistant with other priority sources.+--- This API decision started out being accidental, but I find it more intuitive.+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 unimportant+            ) priority $ buildRule important+        where+            (unimportant, important) = splitProperties props+            (StyleRule sel props psuedo) = inner rule+            buildRule x = rule {inner = StyleRule sel x psuedo}+    lookupRules (ImportanceSplitter self) el = lookupRules self el
+ src/Data/CSS/Style/Selector/Index.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.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 Data.CSS.Style.Common++import Data.Hashable+import Data.Text (unpack, pack)+import Data.CSS.Syntax.Tokens (serialize) -- for easy hashing++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 :: Selector -> [SimpleSelector]+simpleSelector (Element s) = s+simpleSelector (Child _ s) = s+simpleSelector (Descendant _ s) = s+simpleSelector (Adjacent _ s) = s+simpleSelector (Sibling _ s) = s++addRuleForSelector :: StyleIndex -> StyleRule' -> [SimpleSelector] -> StyleIndex+addRuleForSelector self@(StyleIndex index _) rule sel+  | Just key <- selectorKey sel = self {+        indexed = insert key (rule : lookup' key index) index+    }+  | otherwise = self {unindexed = rule : unindexed self}++selectorKey :: [SimpleSelector] -> Maybe SimpleSelector+selectorKey (tok@(Tag _) : _) = Just tok+selectorKey (tok@(Id _) : _) = Just tok+selectorKey (tok@(Class _) : _) = Just tok+selectorKey (Property prop _ : _) = Just $ Property prop Exists+selectorKey (_ : tokens) = selectorKey tokens+selectorKey [] = Nothing++----++testsForAttributes :: [Attribute] -> [SimpleSelector]+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 elName _:attrs) =+    Property elName 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 i) = seed `hashWithSalt` (1::Int) `hashWithSalt` unpack i+    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+    hashWithSalt seed (Psuedoclass p args) =+        seed `hashWithSalt` (4::Int) `hashWithSalt` p `hashWithSalt` serialize args++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
+ src/Data/CSS/Style/Selector/Interpret.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.Style.Selector.Interpret(+        compile, SelectorFunc,+        InterpretedRuleStore(..)+    ) where++import Data.CSS.Style.Common++import Data.Text (unpack)+import Data.List+import Data.Maybe++type SelectorFunc = Element -> Bool+type AttrsFunc = [Attribute] -> Bool++compile :: Selector -> SelectorFunc+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 :: [SimpleSelector] -> SelectorFunc+compileInner sel = compileInner' $ lowerInner sel+compileInner' :: (Maybe Text, [(Text, String -> Bool)]) -> SelectorFunc+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 ((tag, test):attrs) = testAttr tag test $ compileAttrs attrs+compileAttrs [] = matched++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+-- psuedos, TODO handle argumented psuedoclasses.+lowerInner (Psuedoclass c _:s) =+        (tag, ("", hasWord $ unpack c):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+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 :: [(Text, b)] -> [(Text, b)]+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 :: (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 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++--------+---- 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
+ src/Data/CSS/Style/Selector/Specificity.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.Style.Selector.Specificity(+        OrderedRuleStore(..)+    ) where++import Data.CSS.Syntax.Selector+import Data.CSS.Style.Common+import Data.List++type Vec = (Int, Int, Int)+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' (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)+computeSpecificity' (Id _:sel) = computeSpecificity' sel `add` (1, 0, 0)+computeSpecificity' [] = (0, 0, 0)++add :: Vec -> Vec -> Vec+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 (psuedoElement rule) $ selector rule, count)+            }+        ) (count + 1)+    lookupRules (OrderedRuleStore self _) el = sort $ lookupRules self el
+ src/Data/CSS/Syntax/Selector.hs view
@@ -0,0 +1,91 @@+module Data.CSS.Syntax.Selector(+        Selector(..), SimpleSelector(..), PropertyTest(..),+        parseSelectors+    ) where++import Data.CSS.Syntax.Tokens+import Data.CSS.Syntax.StylishUtil++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 |+    Psuedoclass Text [Token]+    deriving (Show, Eq)+data PropertyTest = Exists | Equals Text | Suffix Text | Prefix Text | Substring Text |+    Include Text | Dash Text+    deriving (Show, Eq)++parseSelectors :: Parser [Selector]+parseSelectors tokens = concatP (:) parseCompound parseSelectorsTail $ skipSpace tokens+parseSelectorsTail :: Parser [Selector]+parseSelectorsTail (Comma:tokens) = parseSelectors tokens+parseSelectorsTail tokens = ([], tokens)+parseCompound :: Parser Selector+parseCompound tokens = parseCombinators (Element selector) tokens'+    where (selector, tokens') = parseSelector tokens++parseSelector' :: SimpleSelector -> Parser [SimpleSelector]+parseSelector' op tokens = (op:selector, tokens')+    where (selector, tokens') = parseSelector tokens++parseSelector :: Parser [SimpleSelector]+parseSelector (Delim '*':tokens) = parseSelector tokens+parseSelector (Ident tag:tokens) = parseSelector' (Tag tag) tokens+parseSelector (Hash _ i:tokens) = parseSelector' (Id i) 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 (Colon:Ident p:ts) = parseSelector' (Psuedoclass p []) ts+parseSelector (Colon:Function fn:tokens) =+        concatP appendPseudo scanBlock parseSelector tokens+    where appendPseudo args selector = Psuedoclass fn args : selector+parseSelector tokens = ([], tokens)++parseCombinators' :: Selector -> Parser Selector+parseCombinators' selector tokens = parseCombinators selector' tokens'+    where (selector', tokens') = parseCombinator selector tokens+parseCombinators :: Selector -> Parser Selector+parseCombinators selector (Whitespace:tokens) = parseCombinators' selector tokens+parseCombinators selector tokens@(Delim _:_) = parseCombinators' selector tokens+parseCombinators selector tokens = (selector, tokens)++parseCombinator' :: (Selector -> [SimpleSelector] -> Selector)+                    -> Selector -> Parser Selector+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 :: Parser PropertyTest+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 :: (Text -> PropertyTest) -> Parser PropertyTest+parsePropertyVal wrapper (Ident val:RightSquareBracket:tokens) = (wrapper val, tokens)+parsePropertyVal wrapper (String val:RightSquareBracket:tokens) = (wrapper val, tokens)+parsePropertyVal _ tokens = (Exists, skipBlock tokens)
+ src/Data/CSS/Syntax/StyleSheet.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.Syntax.StyleSheet (+        parse, parse', parseForURL, TrivialStyleSheet(..),+        StyleSheet(..), skipAtRule,+        StyleRule(..),+        -- For parsing at-rules, HTML "style" attribute, etc.+        parseProperties, parseProperties',+        -- for testing+        scanValue+    ) where++import Data.CSS.Syntax.Tokens+import Data.CSS.Syntax.Selector+import Data.CSS.Syntax.StylishUtil++import Data.Text.Internal (Text(..))+import Data.Text (pack, unpack)+import Network.URI (parseRelativeReference, relativeTo, uriToString, URI(..))++--------+---- Output type class+--------+class StyleSheet s where+    setPriority :: Int -> s -> s+    setPriority _ = id+    addRule :: s -> StyleRule -> s+    addAtRule :: s -> Text -> [Token] -> (s, [Token])+    addAtRule self _ tokens = (self, skipAtRule tokens)++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])] Text 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++parseForURL :: StyleSheet s => s -> URI -> Text -> s+parseForURL stylesheet base source = parse' stylesheet $ rewriteURLs $ tokenize source+    where+        rewriteURLs (Url text:toks)+            | Just url <- parseRelativeReference $ unpack text =+                Url (pack $ uriToString id (relativeTo url base) "") : rewriteURLs toks+            | otherwise = Function "url" : RightParen : rewriteURLs toks+        rewriteURLs (tok:toks) = tok : rewriteURLs toks+        rewriteURLs [] = []++parse' :: StyleSheet t => t -> [Token] -> t+-- 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 :: 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) = 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+parseProperties' (Ident name:tokens)+    | Colon:tokens' <- skipSpace tokens =+        concatP appendProp scanValue parseProperties' tokens'+    where appendProp value props = (name, value):props+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 (Function _: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 :: Parser [Token]+scanValue (Semicolon:tokens) = ([], tokens)+scanValue (Whitespace:tokens) = scanValue tokens++scanValue tokens@(LeftCurlyBracket:_) = scanInner tokens scanValue+scanValue tokens@(LeftParen:_) = scanInner tokens scanValue+scanValue tokens@(Function _:_) = scanInner tokens scanValue+scanValue tokens@(LeftSquareBracket:_) = 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 :: [Token] -> [Token]+skipValue tokens = snd $ scanValue tokens
+ src/Data/CSS/Syntax/StylishUtil.hs view
@@ -0,0 +1,45 @@+module Data.CSS.Syntax.StylishUtil(+        concatP, capture, skipSpace,+        scanBlock, skipBlock, scanInner,+        Parser+    ) where++import Data.CSS.Syntax.Tokens++type Parser x = [Token] -> (x, [Token])+concatP :: (a -> b -> c) -> Parser a -> Parser b -> Parser c+concatP join left right tokens = (join x y, remainder)+    where+        (x, tokens') = left tokens+        (y, remainder) = right tokens'++capture :: Parser [Token] -> Parser [Token]+capture cb (token:tokens) = (token:captured, tokens')+   where (captured, tokens') = cb tokens+capture _ [] = ([], [])++skipSpace :: [Token] -> [Token]+skipSpace (Whitespace:tokens) = skipSpace tokens+skipSpace tokens = tokens++scanBlock :: Parser [Token]+-- 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 tokens@(LeftCurlyBracket:_) = scanInner tokens scanBlock+scanBlock tokens@(LeftParen:_) = scanInner tokens scanBlock+scanBlock tokens@(Function _:_) = scanInner tokens scanBlock+scanBlock tokens@(LeftSquareBracket:_) = scanInner tokens scanBlock++scanBlock tokens = capture scanBlock tokens++skipBlock :: [Token] -> [Token]+skipBlock tokens = snd $ scanBlock tokens++scanInner :: [Token] -> Parser [Token] -> ([Token], [Token])+scanInner (token:tokens) cb = concatP gather scanBlock cb tokens+    where gather x y = token : x ++ y+scanInner [] _ = error "Expected a token to capture."
+ stylist.cabal view
@@ -0,0 +1,88 @@+-- Initial stylish-haskell.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                stylist++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- https://wiki.haskell.org/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             1.0.0.0++-- A short (one-line) description of the package.+synopsis:            Apply CSS styles to a document tree.++-- A longer description of the package.+description:         Reusable CSS engine allowing you to parse CSS stylesheets and to query the style properties for a given element.+                        It covers CSS parsing, selection, cascade, and inheritance, whilst allowing you to declaratively define supported properties and at-rules.+                        The hope is that this would be useful for implementing new browser engines, web development tools, and UI frameworks.++-- The license under which the package is released.+license:             MIT++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Adrian Cochrane++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          alcinnz@lavabit.com++-- A copyright notice.+copyright:           Adrian Cochrane copyright 2019++category:            Language++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+extra-source-files:  ChangeLog.md, README.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10++source-repository head+    type: git+    location: https://git.nzoss.org.nz/alcinnz/stylish-haskell.git++library+  -- Modules exported by the library.+  exposed-modules:     Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style+  +  -- 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.Cascade,+                       Data.CSS.Style.Selector.Index, Data.CSS.Style.Selector.Interpret, Data.CSS.Style.Selector.Specificity+  +  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:    +  +  -- Other library packages from which modules are imported.+  build-depends:       base >=4.9 && <4.10, css-syntax >=0.1 && <0.2, text,+                        unordered-containers >= 0.2 && <0.3, hashable,+                        network-uri >= 2.6 && <2.7+  +  -- Directories containing source files.+  hs-source-dirs:      src+  +  -- Base language which the package is written in.+  default-language:    Haskell2010++  ghc-options: -Wall+  +test-suite test-stylist+  hs-source-dirs:       src test+  default-language:     Haskell2010+  type:     exitcode-stdio-1.0+  main-is:              Test.hs+  other-modules:        Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style+  build-depends:       base >=4.9 && <4.10, css-syntax >=0.1 && <0.2, text,+                        unordered-containers >= 0.2 && <0.3, hashable,+                        network-uri >= 2.6 && <2.7, hspec, QuickCheck+  ghc-options: -Wall
+ test/Test.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Test.Hspec+import Data.HashMap.Strict++import Data.CSS.Syntax.Tokens+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++spec :: Spec+spec = do+    describe "Canary" $ do+        it "Test framework works" $ do+            True `shouldBe` True+    describe "Parsing" $ do+        it "Ignores @rules" $ do+            parse emptyStyle "@encoding 'utf-8';" `shouldBe` emptyStyle+            parse emptyStyle "  @encoding 'utf-8';" `shouldBe` emptyStyle+            parse emptyStyle "@encoding 'utf-8';  " `shouldBe` emptyStyle+            parse emptyStyle "@media print { a:link {color: green;} }" `shouldBe` emptyStyle+            parse emptyStyle "  @media print { a:link {color: green;} }" `shouldBe` emptyStyle+            parse emptyStyle "@media print { a:link {color: green;} }  " `shouldBe` emptyStyle++            parse emptyStyle "@encoding 'utf-8'; a {color:green}" `shouldBe` linkStyle+            parse emptyStyle "a {color:green}@encoding 'utf-8';" `shouldBe` linkStyle+            parse emptyStyle "@media print{a{color:black;}}a {color:green}" `shouldBe` linkStyle+            parse emptyStyle "a {color:green} @media print {a{color:black;}}" `shouldBe` linkStyle+        it "Parses style rules" $ do+            -- Syntax examples from "Head First HTML & CSS with XHTML"+            parse emptyStyle "bedroom { drapes: blue; carpet: wool shag; }" `shouldBe` TrivialStyleSheet [+                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"]) [] ""+                ]+            parse emptyStyle "*.class {}" `shouldBe` TrivialStyleSheet [+                    StyleRule (Element [Class "class"]) [] ""+                ]+            parse emptyStyle "#id {}" `shouldBe` TrivialStyleSheet [+                    StyleRule (Element [Id "id"]) [] ""+                ]+            parse emptyStyle "[attr] {}" `shouldBe` TrivialStyleSheet [+                    StyleRule (Element [Property "attr" Exists]) [] ""+                ]+            parse emptyStyle "a , b {}" `shouldBe` TrivialStyleSheet [+                    StyleRule (Element [Tag "b"]) [] "",+                    StyleRule (Element [Tag "a"]) [] ""+                ]+            parse emptyStyle "a b {}" `shouldBe` TrivialStyleSheet [+                    StyleRule (Descendant (Element [Tag "a"]) [Tag "b"]) [] ""+                ]+            parse emptyStyle "a > b {}" `shouldBe` TrivialStyleSheet [+                    StyleRule (Child (Element [Tag "a"]) [Tag "b"]) [] ""+                ]+            parse emptyStyle "a ~ b {}" `shouldBe` TrivialStyleSheet [+                    StyleRule (Sibling (Element [Tag "a"]) [Tag "b"]) [] ""+                ]+            parse emptyStyle "a + b {}" `shouldBe` TrivialStyleSheet [+                    StyleRule (Adjacent (Element [Tag "a"]) [Tag "b"]) [] ""+                ]+            parse emptyStyle "a::before {}"+                `shouldBe` TrivialStyleSheet [+                    StyleRule (Element [Tag "a"]) [] "before"+                ]+            parse emptyStyle "a:before {}"+                `shouldBe` TrivialStyleSheet [+                    StyleRule (Element [Tag "a", Psuedoclass "before" []]) [] ""+                ]+    describe "Style Index" $ do+        it "Retrieves appropriate styles" $ do+            let index = addStyleRule styleIndex 0 $ styleRule' sampleRule+            let element = ElementNode {+                name = "a",+                parent = Nothing,+                previous = Nothing,+                attributes = [+                    Attribute "class" "external",+                    Attribute "href" "https://adrian.geek.nz/",+                    Attribute "id" "mysite"+                ]+            }+            let element2 = ElementNode {+                name = "b",+                parent = Just element,+                previous = Just element, -- Invalid tree, oh well.+                attributes = []+            }+            rulesForElement index element `shouldBe` [sampleRule]+            rulesForElement index element2 `shouldBe` []++            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 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 index3 = addStyleRule styleIndex 0 $ styleRule' rule3+            rulesForElement index3 element `shouldBe` [rule3]+            rulesForElement index3 element2 `shouldBe` []+    describe "Selector Compiler" $ do+        it "Correctly evaluates selectors" $ do+            let parentEl = ElementNode {+                name = "a",+                parent = Nothing,+                previous = Nothing,+                attributes = [+                    Attribute "class" "external secure link",+                    Attribute "href" "https://adrian.geek.nz/index.html",+                    Attribute "id" "mysite",+                    Attribute "lang" "en-US"+                ]+            }+            let sibling = ElementNode {+                name = "img",+                parent = Just parentEl,+                previous = Nothing,+                attributes = []+            }+            let child = ElementNode {+                name = "b",+                parent = Just parentEl,+                previous = Just sibling,+                attributes = []+            }++            let selector1 = compile (Element [Tag "a"])+            selector1 parentEl `shouldBe` True+            selector1 sibling `shouldBe` False+            selector1 child `shouldBe` False++            let selector2 = compile (Element [Class "external"])+            selector2 parentEl `shouldBe` True+            selector2 sibling `shouldBe` False+            selector2 child `shouldBe` False++            let selector3 = compile (Element [Id "mysite"])+            selector3 parentEl `shouldBe` True+            selector3 sibling `shouldBe` False+            selector3 child `shouldBe` False++            let selector4 = compile (Element [Property "lang" Exists])+            selector4 parentEl `shouldBe` True+            selector4 sibling `shouldBe` False+            selector4 child `shouldBe` False++            let selector5 = compile (Element [Property "class" $ Include "secure"])+            selector5 parentEl `shouldBe` True+            selector5 sibling `shouldBe` False+            selector5 child `shouldBe` False++            let selector6 = compile (Element [Property "href" $ Prefix "https://"])+            selector6 parentEl `shouldBe` True+            selector6 sibling `shouldBe` False+            selector6 child `shouldBe` False++            let selector7 = compile (Element [Property "href" $ Suffix ".html"])+            selector7 parentEl `shouldBe` True+            selector7 sibling `shouldBe` False+            selector7 child `shouldBe` False++            let selector8 = compile (Element [Property "href" $ Substring ".geek.nz"])+            selector8 parentEl `shouldBe` True+            selector8 sibling `shouldBe` False+            selector8 child `shouldBe` False++            let selector9 = compile (Element [Property "lang" $ Dash "en"])+            selector9 parentEl `shouldBe` True+            selector9 sibling `shouldBe` False+            selector9 child `shouldBe` False++            let selectorA = compile (Element [Property "lang" $ Dash "en-US"])+            selectorA parentEl `shouldBe` True+            selectorA sibling `shouldBe` False+            selectorA child `shouldBe` False++            let selectorB = compile (Element [Property "lang" $ Dash "en-UK"])+            selectorB parentEl `shouldBe` False+            selectorB sibling `shouldBe` False+            selectorB child `shouldBe` False++            -- TODO These could be tested better.+            let selectorC = compile $ Child (Element [Tag "a"]) [Tag "b"]+            selectorC parentEl `shouldBe` False+            selectorC sibling `shouldBe` False+            selectorC child `shouldBe` True++            let selectorD = compile $ Descendant (Element [Tag "a"]) [Tag "b"]+            selectorD parentEl `shouldBe` False+            selectorD sibling `shouldBe` False+            selectorD child `shouldBe` True++            let selectorE = compile $ Sibling (Element [Tag "img"]) [Tag "b"]+            selectorE parentEl `shouldBe` False+            selectorE sibling `shouldBe` False+            selectorE child `shouldBe` True++            let selectorF = compile $ Adjacent (Element [Tag "img"]) [Tag "b"]+            selectorF parentEl `shouldBe` False+            selectorF sibling `shouldBe` False+            selectorF child `shouldBe` True++    describe "Style resolution" $ do+        it "respects selector specificity" $ do+            let el = ElementNode {+                name = "a",+                parent = Nothing,+                previous = Nothing,+                attributes = [Attribute "class" "link"]+            }+            let rules = parse queryable "a.link {color: green} a {color: red}"+            let TrivialPropertyParser style = cascade rules el [] temp::TrivialPropertyParser+            style ! "color" `shouldBe` [Ident "green"]+        it "respects syntax order" $ do+            let el = ElementNode {+                name = "a",+                parent = Nothing,+                previous = Nothing,+                attributes = [Attribute "class" "link"]+            }+            let rules = parse queryable "a {color: red; color: green}"+            let TrivialPropertyParser style = cascade rules el [] temp::TrivialPropertyParser+            style ! "color" `shouldBe` [Ident "green"]++            let rules2 = parse queryable "a {color: red} a {color: green}"+            let TrivialPropertyParser style2 = cascade rules2 el [] temp::TrivialPropertyParser+            style2 ! "color" `shouldBe` [Ident "green"]+        it "respects stylesheet precedence" $ do+            let el = ElementNode {+                name = "a",+                parent = Nothing,+                previous = Nothing,+                attributes = [Attribute "class" "link"]+            }+            let rules = parse (queryable {priority = 1}) "a {color: green}"+            let rules2 = parse (rules {priority = 2}) "a {color: red}" :: QueryableStyleSheet TrivialPropertyParser+            let TrivialPropertyParser style = cascade rules2 el [] temp::TrivialPropertyParser+            style ! "color" `shouldBe` [Ident "green"]++            let el' = ElementNode {+                name = "a",+                parent = Nothing,+                previous = Nothing,+                attributes = [Attribute "class" "link"]+            }+            let rules' = parse (queryable {priority = 1}) "a {color: red}"+            let rules2' = parse (rules' {priority = 2}) "a {color: green !important}" :: QueryableStyleSheet TrivialPropertyParser+            let TrivialPropertyParser style' = cascade rules2' el' [] temp::TrivialPropertyParser+            style' ! "color" `shouldBe` [Ident "green"]+        it "respects overrides" $ do+            let el = ElementNode {+                name = "a",+                parent = Nothing,+                previous = Nothing,+                attributes = [Attribute "class" "link"]+            }+            let rules = parse queryable "a {color: red;}"+            let TrivialPropertyParser style = cascade rules el [("color", [Ident "green"])] temp::TrivialPropertyParser+            style ! "color" `shouldBe` [Ident "green"]+    describe "Parser freezes" $ do+        it "does not regress" $ do+            parse emptyStyle "output: {content: 'Output'; pitch: high}"+                `shouldBe` TrivialStyleSheet [+                    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])+            scanValue [LeftParen] `shouldBe` ([LeftParen], [])+            scanValue [Function "fn", LeftParen] `shouldBe` ([Function "fn", LeftParen], [])+            scanValue [Function "fn", Ident "arg", LeftParen] `shouldBe`+                ([Function "fn", Ident "arg", LeftParen], [])++styleIndex :: StyleIndex+styleIndex = new+queryable :: QueryableStyleSheet TrivialPropertyParser+queryable = queryableStyleSheet+emptyStyle :: TrivialStyleSheet+emptyStyle = TrivialStyleSheet []+linkStyle :: TrivialStyleSheet+linkStyle = TrivialStyleSheet [sampleRule]+sampleRule :: StyleRule+sampleRule = StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""