stylist 1.2.0.0 → 2.0.0.0
raw patch · 16 files changed
+609/−64 lines, 16 files
Files
- README.md +4/−2
- src/Data/CSS/Preprocessor/Assets.hs +48/−0
- src/Data/CSS/Preprocessor/PsuedoClasses.hs +116/−0
- src/Data/CSS/Preprocessor/Text.hs +213/−0
- src/Data/CSS/Style.hs +4/−1
- src/Data/CSS/Style/Cascade.hs +4/−3
- src/Data/CSS/Style/Common.hs +3/−1
- src/Data/CSS/Style/Selector/Index.hs +10/−9
- src/Data/CSS/Style/Selector/Interpret.hs +82/−17
- src/Data/CSS/Style/Selector/LowerWhere.hs +32/−0
- src/Data/CSS/Style/Selector/Specificity.hs +6/−2
- src/Data/CSS/StyleTree.hs +35/−0
- src/Data/CSS/Syntax/Selector.hs +7/−2
- src/Data/CSS/Syntax/StyleSheet.hs +1/−1
- stylist.cabal +8/−4
- test/Test.hs +36/−22
README.md view
@@ -18,9 +18,11 @@ `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.+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).. -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!+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 want to ask for more features or fixes don't hesitate to contact me!++Feel free to mirror this repo elsewhere! Just tell me about it so I can watch that mirror for contributions. ### Building 1. Install `ghc` and `cabal-install`. (Debian package names listed here)
+ src/Data/CSS/Preprocessor/Assets.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Utilities for rewriting URLs referenced via CSS properties.+module Data.CSS.Preprocessor.Assets(StyleAssets(..), URIRewriter(..)) where++-- TODO Unit test!+import Data.Text as Txt+import Network.URI+import qualified Data.CSS.Syntax.StyleSheet as CSS+import qualified Data.CSS.Syntax.Tokens as CSSTok+import Data.List (nub, elem)++-- | Extracts referenced URLs from specified properties.+data StyleAssets = StyleAssets {+ -- | The properties from which to extract URLs.+ filterProps :: [Txt.Text],+ -- | The extracted URLs.+ assets :: [URI]+}++instance CSS.StyleSheet StyleAssets where+ addRule self (CSS.StyleRule _ props _) =+ StyleAssets (filterProps self) $ nub (+ assets self ++ [uri | (prop, val) <- props,+ prop `elem` filterProps self,+ CSSTok.Url text <- val,+ Just uri <- [parseAbsoluteURI $ Txt.unpack text]]+ )+++-- | Substitutes in given URLs into a property value.+rewritePropertyVal :: [(URI, URI)] -> [CSSTok.Token] -> [CSSTok.Token] +rewritePropertyVal rewrites (CSSTok.Url text:vals)+ | Just uri <- parseURIReference $ Txt.unpack text, Just rewrite <- uri `lookup` rewrites =+ CSSTok.Url (Txt.pack $ uriToString id rewrite "") : rewritePropertyVal rewrites vals+ | otherwise = CSSTok.Url "" : rewritePropertyVal rewrites vals+rewritePropertyVal rewrites (val:vals) = val:rewritePropertyVal rewrites vals+rewritePropertyVal _ [] = []++-- | Substitutes in given URLs into the inner stylesheet being parsed.+data URIRewriter s = URIRewriter [(URI, URI)] s+instance CSS.StyleSheet s => CSS.StyleSheet (URIRewriter s) where+ setPriority p (URIRewriter r s) = URIRewriter r $ CSS.setPriority p s+ addRule (URIRewriter r s) (CSS.StyleRule sel props psuedo) =+ URIRewriter r $ CSS.addRule s $ CSS.StyleRule sel [+ (prop, rewritePropertyVal r val) | (prop, val) <- props+ ] psuedo+ addAtRule (URIRewriter r s) name toks =+ let (self', toks') = CSS.addAtRule s name toks in (URIRewriter r self', toks')
+ src/Data/CSS/Preprocessor/PsuedoClasses.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Lowers psuedoclasses to rawer syntactic forms.+module Data.CSS.Preprocessor.PsuedoClasses(LowerPsuedoClasses(..),+ psuedoClassesFilter, htmlPsuedoFilter,+ addRewrite, addRewrite', addPsuedoEl, addNamespace) where++import Data.CSS.Syntax.StyleSheet+import Data.CSS.Syntax.Selector+import Data.CSS.Syntax.Tokens++import Data.Text as Txt+import Data.Maybe (fromMaybe, listToMaybe)+import Data.HashMap.Lazy as HM+import Data.Function ((&))++--------+---- core+--------+data LowerPsuedoClasses s = LowerPsuedoClasses {+ inner :: s,+ rewriteRules :: HashMap Text [Token],+ psuedoEls :: [Text],+ namespaces :: HashMap Text Text+}++instance StyleSheet s => StyleSheet (LowerPsuedoClasses s) where+ setPriority p self = self { inner = setPriority p $ inner self }+ addRule self rule = self { inner = addRule (inner self) $ lowerRule self rule }++ addAtRule self "namespace" (Ident ns:toks) | (Url url:toks') <- skipSpace toks =+ (addNamespace ns url self, toks')+ addAtRule self name toks = let (inner', toks') = addAtRule (inner self) name toks+ in (self { inner = inner' }, toks')++lowerRule :: LowerPsuedoClasses t -> StyleRule -> StyleRule+lowerRule self@(LowerPsuedoClasses { psuedoEls = psuedos }) (StyleRule sel props "")+ | Just pseudo <- extractPseudoEl psuedos sel =+ lowerRule (addRewrite' pseudo [] self) $ StyleRule sel props pseudo+lowerRule LowerPsuedoClasses { namespaces = ns, rewriteRules = rewrites } (StyleRule sel props pseudoel) =+ StyleRule (lowerSelector ns rewrites sel) props pseudoel++extractPseudoEl :: [Text] -> Selector -> Maybe Text+extractPseudoEl ps (Element sel) = extractPseudoEl' ps sel+extractPseudoEl ps (Child _ sel) = extractPseudoEl' ps sel+extractPseudoEl ps (Descendant _ sel) = extractPseudoEl' ps sel+extractPseudoEl ps (Adjacent _ sel) = extractPseudoEl' ps sel+extractPseudoEl ps (Sibling _ sel) = extractPseudoEl' ps sel+extractPseudoEl' :: [Text] -> [SimpleSelector] -> Maybe Text+extractPseudoEl' ps sel = listToMaybe [p | Psuedoclass p [] <- sel, p `elem` ps]++lowerSelector :: HashMap Text Text -> HashMap Text [Token] -> Selector -> Selector+lowerSelector ns rewrites (Element sel') = Element $ lowerSelector' ns rewrites sel'+lowerSelector ns rewrites (Child p sel') =+ Child (lowerSelector ns rewrites p) $ lowerSelector' ns rewrites sel'+lowerSelector ns rewrites (Descendant p sel') =+ Descendant (lowerSelector ns rewrites p) $ lowerSelector' ns rewrites sel'+lowerSelector ns rewrites (Adjacent sib sel') =+ Adjacent (lowerSelector ns rewrites sib) $ lowerSelector' ns rewrites sel'+lowerSelector ns rewrites (Sibling sib sel') =+ Sibling (lowerSelector ns rewrites sib) $ lowerSelector' ns rewrites sel'++lowerSelector' :: HashMap Text Text -> HashMap Text [Token] -> [SimpleSelector] -> [SimpleSelector]+lowerSelector' namespaces' rewrites (Namespace ns:sels) =+ Namespace (fromMaybe "about:invalid" $ HM.lookup ns namespaces') : lowerSelector' namespaces' rewrites sels+lowerSelector' ns rewrites (Psuedoclass name []:sels)+ | Just value <- name `HM.lookup` rewrites = Psuedoclass "where" value : lowerSelector' ns rewrites sels+lowerSelector' ns rewrites (Psuedoclass name [arg]:sels)+ | Just value <- name `HM.lookup` rewrites =+ Psuedoclass "where" [if a == Ident "_" then arg else a | a <- value] : lowerSelector' ns rewrites sels+lowerSelector' ns rewrites (sel:sels) = sel : lowerSelector' ns rewrites sels+lowerSelector' _ _ [] = []++--------+---- constructors+--------+psuedoClassesFilter :: StyleSheet s => s -> LowerPsuedoClasses s+psuedoClassesFilter s = LowerPsuedoClasses s HM.empty ["before", "after"] HM.empty++addPsuedoEl :: Text -> LowerPsuedoClasses s -> LowerPsuedoClasses s+addPsuedoEl ps self = self { psuedoEls = psuedoEls self ++ Txt.words ps }++addRewrite :: Text -> Text -> LowerPsuedoClasses s -> LowerPsuedoClasses s+addRewrite name sel self = addRewrite' name (tokenize sel) self+addRewrite' :: Text -> [Token] -> LowerPsuedoClasses s -> LowerPsuedoClasses s+addRewrite' name sel self = self { rewriteRules = insert name sel $ rewriteRules self }++addNamespace :: Text -> Text -> LowerPsuedoClasses s -> LowerPsuedoClasses s+addNamespace ns uri self = self { namespaces = insert ns uri $ namespaces self }++htmlPsuedoFilter :: StyleSheet s => s -> LowerPsuedoClasses s+htmlPsuedoFilter s = psuedoClassesFilter s &+ addRewrite "link" "[href]" &+ addRewrite "any-link" "[href]" &+ addRewrite "blank" "[value=''], :not([value])" &+ addRewrite "checked" "[checked]" &+ addRewrite "dir" "[dir=_], [dir=_] *" &+ addRewrite "disabled" "[disabled]" &+ addRewrite "enabled" ":not([disabled])" &+ addRewrite "first-child" ":nth-child(1)" &+ addRewrite "first-of-type" ":nth-of-type(1)" &+ addRewrite "indeterminate" "[indeterminate]" &+ addRewrite "lang" "[lang|=_], [lang|=_] *" &+ -- Not sure if I ever really want to support these, but might as well list them.+ -- Requires more data to be fed to the core CSS engine.+ addRewrite "last-child" ":nth-last-child(1)" &+ addRewrite "last-of-type" ":nth-last-of-type(1)" &+ addRewrite "only-child" ":nth-child(1):nth-last-child(1)" &+ addRewrite "only-of-type" ":nth-of-type(1):nth-last-of-type(1)" &+ -- No issue with remainder.+ addRewrite "optional" ":not([required])" &+ addRewrite "placeholder-shown" "[value=''][placeholder], [placeholder]:not([value])" &+ addRewrite "readonly" "[readonly], [disabled]" &+ addRewrite "read-write" ":not([readonly]):not([disabled])" &+ addRewrite "required" "[required]" &+ addRewrite "root" "html" &+ addRewrite "scope" "html"
+ src/Data/CSS/Preprocessor/Text.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Lowers certain CSS properties to plain text.+module Data.CSS.Preprocessor.Text(TextStyle, resolve) where++import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))+import Data.CSS.Style (PropertyParser(..))+import Data.CSS.StyleTree+import qualified Data.Text as Txt+import Data.Text (Text)++import Data.Maybe (fromMaybe)+import qualified Data.HashMap.Lazy as M+import Data.Function ((&))++import Data.Char (isSpace)++type Counters = [(Text, Integer)]+-- | `PropertyParser` decorator that parses & lowers certain CSS properties to plain text.+data TextStyle p = TextStyle {+ inner :: p,+ counterProps :: [(Text, [Token])],++ counterReset :: Counters,+ counterIncrement :: Counters,+ counterSet :: Counters,++ whiteSpaceCollapse :: Bool,+ newlineCollapse :: Bool+}++instance PropertyParser p => PropertyParser (TextStyle p) where+ temp = TextStyle {+ inner = temp,+ counterProps = [],+ counterReset = [],+ counterIncrement = [],+ counterSet = [],+ whiteSpaceCollapse = True,+ newlineCollapse = True+ }+ inherit parent = TextStyle {+ inner = inherit $ inner parent,+ counterProps = [],+ counterReset = [],+ counterIncrement = [],+ counterSet = [],+ whiteSpaceCollapse = whiteSpaceCollapse parent,+ newlineCollapse = newlineCollapse parent+ }++ shorthand _ key value+ | key `elem` ["counter-reset", "counter-increment", "counter-set"],+ Just _ <- parseCounters 0 value = [(key, value)]+ shorthand self "white-space" [Ident val]+ | val `elem` ["normal", "pre", "pre-wrap", "pre-line"] = [("white-space", [Ident val])]+ | otherwise = shorthand (inner self) "white-space" [Ident val]+ shorthand self key value = shorthand (inner self) key $ removeCounters value++ longhand _ self "counter-reset" value = (\v -> self {counterReset = v}) <$> parseCounters 0 value+ longhand _ self "counter-increment" value = (\v -> self {counterIncrement = v}) <$> parseCounters 1 value+ longhand _ self "counter-set" value = (\v -> self {counterSet = v}) <$> parseCounters 0 value++ longhand p self "white-space" [Ident "initial"] = setWhiteSpace p self True True "normal"+ longhand p self "white-space" [Ident "normal"] = setWhiteSpace p self True True "normal"+ longhand p self "white-space" [Ident "pre"] = setWhiteSpace p self False False "nowrap"+ longhand p self "white-space" [Ident "nowrap"] = setWhiteSpace p self True True "nowrap"+ longhand p self "white-space" [Ident "pre-wrap"] = setWhiteSpace p self False False "normal"+ longhand p self "white-space" [Ident "pre-line"] = setWhiteSpace p self True False "normal"++ -- Capture `content` properties & anything else using counter(s) functions.+ -- This is important in Rhapsode for the sake of navigational markers.+ longhand parent self key value+ | key == "content" || Function "counter" `elem` value || Function "counters" `elem` value =+ Just $ self { counterProps = insertList key value $ counterProps self }+ | otherwise = (\v -> self {inner = v}) <$> longhand (inner parent ) (inner self) key value++insertList :: Eq a => a -> b -> [(a, b)] -> [(a, b)]+insertList key value list | Nothing <- lookup key list = (key, value) : list+ | otherwise = [(k, if k == key then value else v) | (k, v) <- list]++removeCounters :: [Token] -> [Token]+removeCounters (Function "counter":Ident _:RightParen:toks) = String "" : removeCounters toks+removeCounters (Function "counters":Ident _:Comma:String _:toks) = String "" : removeCounters toks+removeCounters (tok:toks) = tok : removeCounters toks+removeCounters [] = []++setWhiteSpace :: PropertyParser p => TextStyle p -> TextStyle p -> Bool -> Bool -> Text -> Maybe (TextStyle p)+setWhiteSpace parent self collapse noNewlines lowered = Just $ self {+ inner = inner self `fromMaybe` longhand (inner parent) (inner self) "white-space" [Ident lowered],+ whiteSpaceCollapse = collapse,+ newlineCollapse = noNewlines+ }+parseCounters :: Integer -> [Token] -> Maybe [(Text, Integer)]+parseCounters _ [Ident "none"] = Just []+parseCounters _ [Ident "initial"] = Just []+parseCounters _ [] = Just []+parseCounters x (Ident counter : Number _ (NVInteger count') : toks) =+ (:) (counter, count') <$> parseCounters x toks+parseCounters x (Ident counter : toks) = (:) (counter, x) <$> parseCounters x toks+parseCounters _ _ = Nothing++-- | Returns inner `PropertyParser` with text properties applied.+resolve :: PropertyParser p => StyleTree (TextStyle p) -> StyleTree p+resolve = resolve' . collapseWS . applyCounters+resolve' :: PropertyParser p => StyleTree (TextStyle p) -> StyleTree p+resolve' = treeMap $ \TextStyle {inner = inner', counterProps = props} -> foldl resolveProp inner' props+resolveProp :: PropertyParser p => p -> (Text, [Token]) -> p+resolveProp sty (key, value) = sty `fromMaybe` longhand temp sty key value++--------+---- Counters+--------+type Context = M.HashMap Text [([Integer], Integer)]++inheritCounters :: Context -> Context -> Context+inheritCounters counterSource valueSource = M.intersectionWith cb valueSource counterSource -- indexed by name & el-path+ where cb val source = [counter | counter@(path, _) <- val, path `elem` [p | (p, _) <- source]]++instantiateCounter :: Context -> Path -> Text -> Integer -> Context+instantiateCounter counters path name val = M.insertWith appendCounter name [(path, val)] counters+ where+ appendCounter new (old@((_:oldPath), _):olds)+ | oldPath == tail path = new ++ olds+ | otherwise = new ++ (old:olds)+ appendCounter new [] = new+ appendCounter new (_:olds) = new ++ olds+instantiateCounters :: Path -> Counters -> Context -> Context+instantiateCounters path instruct counters = foldl cb counters instruct+ where cb counters' (name, value) = instantiateCounter counters' path name value++incrementCounter :: Context -> Path -> Text -> Integer -> Context+incrementCounter counters path name val = M.insertWith addCounter name [(path, val)] counters+ where+ addCounter ((_, new):_) ((path', old):rest) = (path', new + old):rest+ addCounter [] old = old+ addCounter new [] = new+incrementCounters :: Path -> Counters -> Context -> Context+incrementCounters path instruct counters = foldl cb counters instruct+ where cb counters' (name, value) = incrementCounter counters' path name value++setCounter :: Context -> Path -> Text -> Integer -> Context+setCounter counters path name val = M.insertWith setCounter' name [(path, val)] counters+ where+ setCounter' ((_, val'):_) ((path', _):rest) = (path', val'):rest+ setCounter' [] old = old+ setCounter' new [] = new+setCounters :: Path -> Counters -> Context -> Context+setCounters path instruct counters = foldl cb counters instruct+ where cb counters' (name, value) = setCounter counters' path name value+++renderCounters :: Context -> [Token] -> [Token]+renderCounters counters (Function "counter":Ident name:RightParen:toks)+ | Just ((_, count):_) <- name `M.lookup` counters =+ String (Txt.pack $ show count) : renderCounters counters toks+ | otherwise = renderCounters counters toks+renderCounters counters (Function "counters":Ident name:Comma:String sep:RightParen:toks)+ | Just counter <- name `M.lookup` counters = String (Txt.intercalate sep [+ Txt.pack $ show count | (_, count) <- reverse counter+ ]) : renderCounters counters toks+ | otherwise = renderCounters counters toks+renderCounters counters (tok:toks) = tok : renderCounters counters toks+renderCounters _ [] = []++applyCounters :: StyleTree (TextStyle p) -> StyleTree (TextStyle p)+applyCounters = treeOrder applyCounters0 M.empty+applyCounters0 :: Context -> Context -> Path -> TextStyle p -> (Context, TextStyle p)+applyCounters0 counterSource valueSource path node =+ let counters = inheritCounters counterSource valueSource &+ instantiateCounters path (counterReset node) &+ incrementCounters path (counterIncrement node) &+ setCounters path (counterSet node)+ in (counters, node {+ counterProps = [(k, renderCounters counters v) | (k, v) <- counterProps node]+ })++--------+---- white-space+--------+content :: TextStyle p -> [Token]+content = fromMaybe [] . lookup "content" . counterProps+setContent :: [Token] -> TextStyle p -> TextStyle p+setContent value self = self {+ counterProps = [(k, if k == "content" then value else v) | (k, v) <- counterProps self]+ }++collapseWS :: StyleTree (TextStyle p) -> StyleTree (TextStyle p)+collapseWS = treeOrder collapseWS0 True+collapseWS0 :: Bool -> Bool -> Path -> TextStyle p -> (Bool, TextStyle p)+collapseWS0 _ _ _ node@(TextStyle {whiteSpaceCollapse = False, newlineCollapse = False}) = (False, node)+collapseWS0 _ inSpace _ node@(TextStyle {+ whiteSpaceCollapse = wsCollapse,+ newlineCollapse = nlCollapse+ }) = (trailingSpace, setContent content' node)+ where (trailingSpace, content') = collapseWSToks inSpace wsCollapse nlCollapse $ content node++collapseWSToks :: Bool -> Bool -> Bool -> [Token] -> (Bool, [Token])+collapseWSToks stripStart wsCollapse nlCollapse (String txt:toks) =+ let (trailingSpace, str') = collapseWSStr stripStart wsCollapse nlCollapse $ Txt.unpack txt+ (trailingSpace', toks') = collapseWSToks trailingSpace wsCollapse nlCollapse toks+ in (trailingSpace', String (Txt.pack str'):toks')+collapseWSToks _ wsCollapse nlCollapse (tok:toks) =+ let (trailingSpace, toks') = collapseWSToks False wsCollapse nlCollapse toks+ in (trailingSpace, tok:toks')+collapseWSToks trailingWS _ _ [] = (trailingWS, [])++collapseWSStr, collapseWSStr' :: Bool -> Bool -> Bool -> String -> (Bool, String)+collapseWSStr _ wsCollapse False str@('\n':_) = collapseWSStr' True wsCollapse True str+collapseWSStr True True nlCollapse (ch:str) | isSpace ch = collapseWSStr True True nlCollapse str+collapseWSStr False True nlCollapse str@(ch:_) | isSpace ch = collapseWSStr' True True nlCollapse str+collapseWSStr _ wsCollapse nlCollapse str = collapseWSStr' False wsCollapse nlCollapse str+collapseWSStr' a b c (d:ds) = let (trailing, ds') = collapseWSStr a b c ds in (trailing, d:ds')+collapseWSStr' a _ _ [] = (a, [])
src/Data/CSS/Style.hs view
@@ -12,6 +12,7 @@ import Data.CSS.Style.Selector.Index import Data.CSS.Style.Selector.Interpret import Data.CSS.Style.Selector.Specificity+import Data.CSS.Style.Selector.LowerWhere import Data.CSS.Style.Importance import Data.CSS.Style.Common import qualified Data.CSS.Style.Cascade as Cascade@@ -25,7 +26,9 @@ -- | A parsed CSS stylesheet from which you can query styles to match an element. type QueryableStyleSheet parser = QueryableStyleSheet' (ImportanceSplitter (- PropertyExpander parser (OrderedRuleStore (InterpretedRuleStore StyleIndex))+ PropertyExpander parser (+ OrderedRuleStore (WhereLowerer (InterpretedRuleStore StyleIndex))+ ) )) parser -- | More generic version of `QueryableStyleSheet`.
src/Data/CSS/Style/Cascade.hs view
@@ -12,6 +12,7 @@ -- TODO do performance tests to decide beside between strict/lazy, -- or is another Map implementation better? import Data.HashMap.Strict+import qualified Data.HashMap.Lazy as HML import Data.Text (unpack, pack, isPrefixOf) -- | Defines how to parse CSS properties into an output "style" format.@@ -63,12 +64,12 @@ -- parsed to a value of the same `PropertyParser` type passed in & inheriting from it. cascade :: PropertyParser p => [StyleRule'] -> Props -> p -> p cascade styles overrides base =- construct base $ toList $ cascadeRules (getVars base ++ overrides) styles+ construct base $ HML.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)+cascadeProperties overrides props = HML.fromList (props ++ overrides) construct :: PropertyParser p => p -> Props -> p construct base props = dispatch base child props@@ -88,7 +89,7 @@ } where StyleRule sel attrs psuedo = inner self attrs2Dict :: Element -> HashMap Text String-attrs2Dict el = fromList [(a, b) | Attribute a b <- attributes el]+attrs2Dict el = fromList [(a, b) | Attribute a _ b <- attributes el] resolveAttr' :: [Token] -> HashMap Text String -> [Token] resolveAttr' (Function "attr":Ident attr:RightParen:toks) attrs =
src/Data/CSS/Style/Common.hs view
@@ -20,11 +20,13 @@ previous :: Maybe Element, -- | The element's name. name :: Text,+ -- | The element's namespace.+ namespace :: Text, -- | The element's attributes, in sorted order. attributes :: [Attribute] } -- | A key-value attribute.-data Attribute = Attribute Text String deriving (Eq, Ord)+data Attribute = Attribute Text Text String deriving (Eq, Ord) class RuleStore a where new :: a
src/Data/CSS/Style/Selector/Index.hs view
@@ -58,7 +58,7 @@ selectorKey (tok@(Tag _) : _) = Just tok selectorKey (tok@(Id _) : _) = Just tok selectorKey (tok@(Class _) : _) = Just tok-selectorKey (Property prop _ : _) = Just $ Property prop Exists+selectorKey (Property _ prop _ : _) = Just $ Property Nothing prop Exists selectorKey (_ : tokens) = selectorKey tokens selectorKey [] = Nothing @@ -68,14 +68,14 @@ testsForElement :: Element -> [SimpleSelector] testsForElement element = (Tag $ name element) : (testsForAttributes $ attributes element)-testsForAttributes (Attribute "class" value:attrs) =+testsForAttributes (Attribute "class" _ value:attrs) = (Prelude.map (\s -> Class $ pack s) $ words value) ++- (Property "class" Exists : testsForAttributes attrs)-testsForAttributes (Attribute "id" value:attrs) =+ (Property Nothing "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+ (Property Nothing "id" Exists : testsForAttributes attrs)+testsForAttributes (Attribute elName _ _:attrs) =+ Property Nothing elName Exists : testsForAttributes attrs testsForAttributes [] = [] -- Implement hashable for SimpleSelector here because it proved challenging to automatically derive it.@@ -83,10 +83,11 @@ 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 (Property ns prop test) =+ seed `hashWithSalt` (3::Int) `hashWithSalt` unpack <$> ns `hashWithSalt` unpack prop `hashWithSalt` test hashWithSalt seed (Psuedoclass p args) = seed `hashWithSalt` (4::Int) `hashWithSalt` p `hashWithSalt` serialize args+ hashWithSalt seed (Namespace ns) = seed `hashWithSalt` (5::Int) `hashWithSalt` unpack ns instance Hashable PropertyTest where hashWithSalt seed Exists = seed `hashWithSalt` (0::Int)
src/Data/CSS/Style/Selector/Interpret.hs view
@@ -11,10 +11,17 @@ import Data.Text (unpack) import Data.List import Data.Maybe+import Data.Bits (xor) +-- For pseudoclasses+import Data.CSS.Syntax.Selector (parseSelectors)+import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))+ -- | A compiled(?) CSS selector. type SelectorFunc = Element -> Bool type AttrsFunc = [Attribute] -> Bool+-- Mostly here for the sake of pseudoclasses.+data IL = Tagname Text | NS Text | Fail | Recursive Bool [Selector] | Nth Bool Integer Integer -- | Converts a parsed CSS selector into a callable function. compile :: Selector -> SelectorFunc@@ -26,23 +33,43 @@ 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+compileInner' :: ([IL], [(Text, Maybe Text, String -> Bool)]) -> SelectorFunc+compileInner' ((Tagname tag:tests), attrs) = testTag tag $ compileInner' (tests, attrs)+compileInner' ((NS ns:tests), attrs) = testNS ns $ compileInner' (tests, attrs)+compileInner' ((Fail:_), _) = \_ -> False+compileInner' ((Recursive negate' sels:tests), attrs) =+ recursiveSelect negate' (map compile sels) $ compileInner' (tests, attrs)+compileInner' ((Nth ofType n 0:tests), attrs) =+ nthChild ofType (fromInteger n) $ compileInner' (tests, attrs)+compileInner' ((Nth ofType a b:tests), attrs) =+ nthChild' ofType (fromInteger a) (fromInteger b) $ compileInner' (tests, attrs)+compileInner' ([], attrs) = testAttrs (compileAttrs $ sortAttrs attrs) matched+compileAttrs :: [(Text, Maybe Text, String -> Bool)] -> AttrsFunc+compileAttrs ((tag, Nothing, test):attrs) = testAttr tag test $ compileAttrs attrs+compileAttrs ((tag, Just ns, test):attrs) = testAttrNS ns 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+lowerInner :: [SimpleSelector] -> ([IL], [(Text, Maybe Text, String -> Bool)])+lowerInner (Namespace ns:sel) = (NS ns:tests, attrs) where (tests, attrs) = lowerInner sel+lowerInner (Tag tag:sel) = (Tagname tag:tests, attrs) where (tests, attrs) = lowerInner sel+lowerInner (Id i:s) = (tests, ("id", Nothing, hasWord $ unpack i):attrs) where (tests, attrs) = lowerInner s+lowerInner (Class c:s) = (tests, ("class", Nothing, hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s+lowerInner (Property ns prop test:s) = (tests, (prop, ns, compileAttrTest test):attrs)+ where (tests, attrs) = lowerInner s -- psuedos, TODO handle argumented psuedoclasses.-lowerInner (Psuedoclass c _:s) =- (tag, ("", hasWord $ unpack c):attrs) where (tag, attrs) = lowerInner s-lowerInner [] = (Nothing, [])+lowerInner (Psuedoclass c args:s)+ | c `elem` ["is", "where"], (sels, []) <- parseSelectors args =+ (Recursive False sels:tests, attrs) where (tests, attrs) = lowerInner s+lowerInner (Psuedoclass "not" args:s) | (sels, []) <- parseSelectors args =+ (Recursive True sels:tests, attrs) where (tests, attrs) = lowerInner s+lowerInner (Psuedoclass "nth-child" args:s) =+ (parseNth False (filter (== Whitespace) args):tests, attrs) where (tests, attrs) = lowerInner s+lowerInner (Psuedoclass "nth-of-type" args:s) =+ (parseNth True (filter (== Whitespace) args):tests, attrs) where (tests, attrs) = lowerInner s+lowerInner (Psuedoclass c []:s) =+ (tests, ("", Nothing, hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s+lowerInner (Psuedoclass _ _:_) = ([Fail], [])+lowerInner [] = ([], []) compileAttrTest :: PropertyTest -> String -> Bool compileAttrTest Exists = matched@@ -53,8 +80,8 @@ 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+sortAttrs :: [(Text, Maybe Text, b)] -> [(Text, Maybe Text, b)]+sortAttrs = sortBy compareAttrs where compareAttrs (x, x', _) (y, y', _) = (x, x') `compare` (y, y') -------- ---- Runtime@@ -62,6 +89,9 @@ testTag :: Text -> SelectorFunc -> SelectorFunc testTag tag success el | name el == tag = success el | otherwise = False+testNS :: Text -> SelectorFunc -> SelectorFunc+testNS ns success el | namespace el == ns = success el+ | otherwise = False testAttrs :: AttrsFunc -> SelectorFunc -> SelectorFunc testAttrs attrsTest success el | attrsTest $ attributes el = success el | otherwise = False@@ -77,18 +107,53 @@ matched _ = True testAttr :: Text -> (String -> Bool) -> AttrsFunc -> AttrsFunc-testAttr expected test next attrs@(Attribute attr value : 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+testAttrNS :: Text -> Text -> (String -> Bool) -> AttrsFunc -> AttrsFunc+testAttrNS expectedNS expected test next attrs@(Attribute attr ns value : attrs')+ | (attr, ns) < (expected, expectedNS) = testAttrNS expectedNS expected test next attrs'+ | (attr, ns) > (expected, expectedNS) = False+ | (attr, ns) == (expected, expectedNS) && test value = next attrs+ | otherwise = False+testAttrNS _ _ _ _ [] = False hasWord :: String -> String -> Bool hasWord expected value = expected `elem` words value hasLang :: [Char] -> [Char] -> Bool hasLang expected value = expected == value || isPrefixOf (expected ++ "-") value +--- Pseudoclasses+recursiveSelect :: Bool -> [SelectorFunc] -> SelectorFunc -> SelectorFunc+recursiveSelect negate' sels success el | negate' `xor` any ($ el) sels = success el+ | otherwise = False++parseNth :: Bool -> [Token] -> IL+parseNth ofType [Ident "odd"] = Nth ofType 2 1+parseNth ofType [Ident "even"] = Nth ofType 2 0+parseNth x [Dimension _ (NVInteger a) "n", Number _ (NVInteger b)] = Nth x a b+parseNth x [Number _ (NVInteger b), Dimension _ (NVInteger a) "n"] = Nth x a b+parseNth x [Dimension _ (NVInteger a) "n", Delim '+', Number _ (NVInteger b)] = Nth x a b+parseNth x [Number _ (NVInteger b), Delim '+', Dimension _ (NVInteger a) "n"] = Nth x a b+parseNth x [Dimension _ (NVInteger a) "n", Delim '-', Number _ (NVInteger b)] = Nth x a $ negate b+parseNth x [Number _ (NVInteger b), Delim '-', Dimension _ (NVInteger a) "n"] = Nth x a $ negate b+parseNth _ _ = Fail++nthChild :: Bool -> Int -> (Element -> Bool) -> Element -> Bool+nthChild ofType n success el | countPrev ofType el == n = success el+ | otherwise = False+nthChild' :: Bool -> Int -> Int -> (Element -> Bool) -> Element -> Bool+nthChild' ofType a b success el | countPrev ofType el `rem` a == b = success el+ | otherwise = False+countPrev :: Bool -> Element -> Int+countPrev ofType el =+ length [el' | el' <- maybeStar previous el, name el == name el' || not ofType]+maybeStar :: (t -> Maybe t) -> t -> [t]+maybeStar cb x | Just y <- cb x = x : maybeStar cb y+ | otherwise = [x] -------- ---- RuleStore wrapper --------
+ src/Data/CSS/Style/Selector/LowerWhere.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.Style.Selector.LowerWhere(+ WhereLowerer(..)+ ) where++import Data.CSS.Syntax.Selector+import Data.CSS.Style.Common++lowerSelector :: Selector -> Selector+lowerSelector (Element sel) = Element $ lowerSelector' sel+lowerSelector (Child sel x) = Child (lowerSelector sel) x+lowerSelector (Descendant sel x) = Descendant (lowerSelector sel) x+lowerSelector (Adjacent sel x) = Adjacent (lowerSelector sel) x+lowerSelector (Sibling sel x) = Sibling (lowerSelector sel) x++lowerSelector' :: [SimpleSelector] -> [SimpleSelector]+lowerSelector' (Psuedoclass c args:sel)+ | c `elem` ["is", "where"], ([Element arg'], []) <- parseSelectors args =+ arg' ++ lowerSelector' sel+lowerSelector' (test:tests) = test : lowerSelector' tests+lowerSelector' [] = []++data WhereLowerer s = WhereLowerer s++instance RuleStore s => RuleStore (WhereLowerer s) where+ new = WhereLowerer new+ addStyleRule (WhereLowerer self) priority rule =+ WhereLowerer $ addStyleRule self priority $ rule {+ inner = StyleRule (lowerSelector sel) props psuedo+ }+ where StyleRule sel props psuedo = inner rule+ lookupRules (WhereLowerer self) el = lookupRules self el
src/Data/CSS/Style/Selector/Specificity.hs view
@@ -16,13 +16,17 @@ 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 _ sel = computeSpecificity "" sel `add` (0, 0, 1) computeSpecificity' :: [SimpleSelector] -> Vec+computeSpecificity' (Namespace _:sel) = computeSpecificity' sel computeSpecificity' (Tag _:sel) = computeSpecificity' sel `add` (0, 0, 1) computeSpecificity' (Class _:sel) = computeSpecificity' sel `add` (0, 1, 0)+computeSpecificity' (Psuedoclass c args:sel)+ | c `elem` ["not", "is"], (sels, []) <- parseSelectors args =+ computeSpecificity' sel `add` maximum (map (computeSpecificity "") sels) computeSpecificity' (Psuedoclass _ _:sel) = computeSpecificity' sel `add` (0, 1, 0)-computeSpecificity' (Property _ _: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)
+ src/Data/CSS/StyleTree.hs view
@@ -0,0 +1,35 @@+-- | Abstracts away tree traversals.+-- Mostly used by callers including (soon) XML Conduit Stylist,+-- but also used internally for generating counter text.+module Data.CSS.StyleTree(StyleTree(..), treeOrder, treeOrder', Path, treeMap, treeFlatten) where++data StyleTree p = StyleTree {+ style :: p,+ children :: [StyleTree p]+}++type Path = [Integer]+treeOrder :: (c -> c -> Path -> p -> (c, p')) ->+ c -> StyleTree p -> StyleTree p'+treeOrder cb ctxt tree = StyleTree+ (snd $ cb ctxt ctxt [] $ style tree)+ (snd $ treeOrder' cb ctxt ctxt [0] $ children tree)+treeOrder' :: (c -> c -> Path -> p -> (c, p')) ->+ c -> c -> Path -> [StyleTree p] -> (c, [StyleTree p'])+treeOrder' cb prevContext context (num:path) (node:nodes) = (tailContext, StyleTree node' children' : nodes')+ where+ (selfContext, node') = cb prevContext context (num:path) $ style node+ (childContext, children') = treeOrder' cb selfContext selfContext (0:num:path) $ children node+ (tailContext, nodes') = treeOrder' cb selfContext childContext (num + 1:path) nodes+treeOrder' _ _ context _ [] = (context, [])+treeOrder' _ _ _ [] _ = error "Invalid path during tree traversal!"++treeMap :: (p -> p') -> StyleTree p -> StyleTree p'+treeMap cb = treeOrder (\_ _ _ p -> ((), cb p)) ()++treeFlatten :: StyleTree p -> [p]+treeFlatten = treeFlatten' . children+treeFlatten' :: [StyleTree p] -> [p]+treeFlatten' (StyleTree p []:ps) = p : treeFlatten' ps+treeFlatten' (StyleTree _ childs:sibs) = treeFlatten' childs ++ treeFlatten' sibs+treeFlatten' [] = []
src/Data/CSS/Syntax/Selector.hs view
@@ -19,9 +19,10 @@ deriving (Show, Eq) -- | An individual test comprising a CSS stylesheet. data SimpleSelector = Tag Text -- ^ Matches a tagname, e.g. "a"+ | Namespace Text | Id Text -- ^ Matches the "id" attribute, e.g. "#header" | Class Text -- ^ Matches the "class" attribute, e.g. ".ad"- | Property Text PropertyTest -- ^ Matches a specified property+ | Property (Maybe Text) Text PropertyTest -- ^ Matches a specified property | Psuedoclass Text [Token] -- ^ Matches psuedoclasses provided by the caller (via a nameless property). deriving (Show, Eq) -- | How should a property be matched.@@ -49,13 +50,17 @@ where (selector, tokens') = parseSelector tokens parseSelector :: Parser [SimpleSelector]+parseSelector (Ident ns:Delim '|':tokens) = parseSelector' (Namespace ns) tokens 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 ns:Delim '|':Ident prop:tokens) =+ concatP appendPropertySel parsePropertySel parseSelector tokens+ where appendPropertySel test selector = Property (Just ns) prop test : selector parseSelector (LeftSquareBracket:Ident prop:tokens) = concatP appendPropertySel parsePropertySel parseSelector tokens- where appendPropertySel test selector = Property prop test : selector+ where appendPropertySel test selector = Property Nothing prop test : selector parseSelector (Colon:Ident p:ts) = parseSelector' (Psuedoclass p []) ts parseSelector (Colon:Function fn:tokens) = concatP appendPseudo scanBlock parseSelector tokens
src/Data/CSS/Syntax/StyleSheet.hs view
@@ -77,7 +77,7 @@ parse' stylesheet [] = stylesheet parse' stylesheet (AtKeyword kind:tokens) = parse' stylesheet' tokens'- where (stylesheet', tokens') = addAtRule stylesheet kind tokens+ where (stylesheet', tokens') = addAtRule stylesheet kind $ skipSpace tokens parse' stylesheet tokens = parse' (addRules stylesheet rule) tokens' where (rule, tokens') = concatP (,) parseSelectors parseProperties tokens
stylist.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 1.2.0.0+version: 2.0.0.0 -- A short (one-line) description of the package. synopsis: Apply CSS styles to a document tree.@@ -49,16 +49,20 @@ source-repository head type: git- location: https://git.nzoss.org.nz/alcinnz/stylish-haskell.git+ location: https://git.adrian.geek.nz/haskell-stylist.git library -- Modules exported by the library.- exposed-modules: Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style, Data.CSS.Preprocessor.Conditions, Data.CSS.Preprocessor.Conditions.Expr+ exposed-modules: Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector,+ Data.CSS.Style, Data.CSS.StyleTree,+ Data.CSS.Preprocessor.Conditions, Data.CSS.Preprocessor.Conditions.Expr,+ Data.CSS.Preprocessor.Assets, Data.CSS.Preprocessor.Text, Data.CSS.Preprocessor.PsuedoClasses -- 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+ Data.CSS.Style.Selector.Index, Data.CSS.Style.Selector.Interpret,+ Data.CSS.Style.Selector.Specificity, Data.CSS.Style.Selector.LowerWhere -- LANGUAGE extensions used by modules in this package. -- other-extensions:
test/Test.hs view
@@ -68,7 +68,7 @@ StyleRule (Element [Id "id"]) [] "" ] parse emptyStyle "[attr] {}" `shouldBe` TrivialStyleSheet [- StyleRule (Element [Property "attr" Exists]) [] ""+ StyleRule (Element [Property Nothing "attr" Exists]) [] "" ] parse emptyStyle "a , b {}" `shouldBe` TrivialStyleSheet [ StyleRule (Element [Tag "b"]) [] "",@@ -99,16 +99,18 @@ let index = addStyleRule styleIndex 0 $ styleRule' sampleRule let element = ElementNode { name = "a",+ namespace = "", parent = Nothing, previous = Nothing, attributes = [- Attribute "class" "external",- Attribute "href" "https://adrian.geek.nz/",- Attribute "id" "mysite"+ Attribute "class" "" "external",+ Attribute "href" "" "https://adrian.geek.nz/",+ Attribute "id" "" "mysite" ] } let element2 = ElementNode { name = "b",+ namespace = "", parent = Just element, previous = Just element, -- Invalid tree, oh well. attributes = []@@ -126,7 +128,7 @@ 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 Nothing "href" $ Prefix "https://"]) [("color", [Ident "green"])] "" let index3 = addStyleRule styleIndex 0 $ styleRule' rule3 rulesForElement index3 element `shouldBe` [rule3] rulesForElement index3 element2 `shouldBe` []@@ -134,23 +136,26 @@ it "Correctly evaluates selectors" $ do let parentEl = ElementNode { name = "a",+ namespace = "", 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"+ 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",+ namespace = "", parent = Just parentEl, previous = Nothing, attributes = [] } let child = ElementNode { name = "b",+ namespace = "", parent = Just parentEl, previous = Just sibling, attributes = []@@ -171,42 +176,42 @@ selector3 sibling `shouldBe` False selector3 child `shouldBe` False - let selector4 = compile (Element [Property "lang" Exists])+ let selector4 = compile (Element [Property Nothing "lang" Exists]) selector4 parentEl `shouldBe` True selector4 sibling `shouldBe` False selector4 child `shouldBe` False - let selector5 = compile (Element [Property "class" $ Include "secure"])+ let selector5 = compile (Element [Property Nothing "class" $ Include "secure"]) selector5 parentEl `shouldBe` True selector5 sibling `shouldBe` False selector5 child `shouldBe` False - let selector6 = compile (Element [Property "href" $ Prefix "https://"])+ let selector6 = compile (Element [Property Nothing "href" $ Prefix "https://"]) selector6 parentEl `shouldBe` True selector6 sibling `shouldBe` False selector6 child `shouldBe` False - let selector7 = compile (Element [Property "href" $ Suffix ".html"])+ let selector7 = compile (Element [Property Nothing "href" $ Suffix ".html"]) selector7 parentEl `shouldBe` True selector7 sibling `shouldBe` False selector7 child `shouldBe` False - let selector8 = compile (Element [Property "href" $ Substring ".geek.nz"])+ let selector8 = compile (Element [Property Nothing "href" $ Substring ".geek.nz"]) selector8 parentEl `shouldBe` True selector8 sibling `shouldBe` False selector8 child `shouldBe` False - let selector9 = compile (Element [Property "lang" $ Dash "en"])+ let selector9 = compile (Element [Property Nothing "lang" $ Dash "en"]) selector9 parentEl `shouldBe` True selector9 sibling `shouldBe` False selector9 child `shouldBe` False - let selectorA = compile (Element [Property "lang" $ Dash "en-US"])+ let selectorA = compile (Element [Property Nothing "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"])+ let selectorB = compile (Element [Property Nothing "lang" $ Dash "en-UK"]) selectorB parentEl `shouldBe` False selectorB sibling `shouldBe` False selectorB child `shouldBe` False@@ -236,9 +241,10 @@ it "respects selector specificity" $ do let el = ElementNode { name = "a",+ namespace = "", parent = Nothing, previous = Nothing,- attributes = [Attribute "class" "link"]+ attributes = [Attribute "class" "" "link"] } let rules = parse queryable "a.link {color: green} a {color: red}" let VarParser _ (TrivialPropertyParser style) = cascade rules el [] temp::(VarParser TrivialPropertyParser)@@ -246,9 +252,10 @@ it "respects syntax order" $ do let el = ElementNode { name = "a",+ namespace = "", parent = Nothing, previous = Nothing,- attributes = [Attribute "class" "link"]+ attributes = [Attribute "class" "" "link"] } let rules = parse queryable "a {color: red; color: green}" let VarParser _ (TrivialPropertyParser style) = cascade rules el [] temp::(VarParser TrivialPropertyParser)@@ -260,9 +267,10 @@ it "respects stylesheet precedence" $ do let el = ElementNode { name = "a",+ namespace = "", parent = Nothing, previous = Nothing,- attributes = [Attribute "class" "link"]+ attributes = [Attribute "class" "" "link"] } let rules = parse (queryable {priority = 1}) "a {color: green}" let rules2 = parse (rules {priority = 2}) "a {color: red}" :: QueryableStyleSheet (VarParser TrivialPropertyParser)@@ -271,9 +279,10 @@ let el' = ElementNode { name = "a",+ namespace = "", parent = Nothing, previous = Nothing,- attributes = [Attribute "class" "link"]+ attributes = [Attribute "class" "" "link"] } let rules' = parse (queryable {priority = 1}) "a {color: red}" let rules2' = parse (rules' {priority = 2}) "a {color: green !important}" :: QueryableStyleSheet (VarParser TrivialPropertyParser)@@ -282,9 +291,10 @@ it "respects overrides" $ do let el = ElementNode { name = "a",+ namespace = "", parent = Nothing, previous = Nothing,- attributes = [Attribute "class" "link"]+ attributes = [Attribute "class" "" "link"] } let rules = parse queryable "a {color: red;}" let VarParser _ (TrivialPropertyParser style) = cascade rules el [("color", [Ident "green"])] temp::(VarParser TrivialPropertyParser)@@ -324,6 +334,7 @@ let el = ElementNode { name = "a",+ namespace = "", parent = Nothing, previous = Nothing, attributes = []@@ -334,6 +345,7 @@ it "applies within element" $ do let el = ElementNode { name = "a",+ namespace = "", parent = Nothing, previous = Nothing, attributes = []@@ -346,12 +358,14 @@ it "inherits" $ do let parent = ElementNode { name = "a",+ namespace = "", parent = Nothing, previous = Nothing, attributes = [] } let el = ElementNode { name = "b",+ namespace = "", parent = Just parent, previous = Nothing, attributes = []