stylist 1.0.0.0 → 1.1.0.0
raw patch · 7 files changed
+438/−32 lines, 7 filesdep +scientific
Dependencies added: scientific
Files
- README.md +5/−0
- src/Data/CSS/Preprocessor/Conditions.hs +173/−0
- src/Data/CSS/Preprocessor/Conditions/Expr.hs +80/−0
- src/Data/CSS/Style/Cascade.hs +7/−6
- src/Data/CSS/Syntax/StyleSheet.hs +14/−12
- stylist.cabal +6/−4
- test/Test.hs +153/−10
README.md view
@@ -21,3 +21,8 @@ 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!++### Building+1. Install `ghc` and `cabal-install`. (Debian package names listed here)+2. From within the git repository, run `cabal install`. This'll compile Stylist and all it's other dependencies.+3. Run `cabal test` after every change you make.
+ src/Data/CSS/Preprocessor/Conditions.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.Preprocessor.Conditions(+ ConditionalStyles(..), conditionalStyles,+ extractImports, resolveImports, loadImports, resolve,+ Datum(..)+ ) where++import qualified Data.CSS.Preprocessor.Conditions.Expr as Query+import Data.CSS.Preprocessor.Conditions.Expr (Datum(..))++import Data.CSS.Syntax.StyleSheet+import Data.CSS.Syntax.Selector+import Data.CSS.Syntax.Tokens(Token(..))+import Data.CSS.Style (PropertyParser(..))++import Data.Text.Internal (Text(..))+import Data.Text (unpack)+import Network.URI (URI(..), URIAuth(..), parseURI)++import Data.List++data ConditionalStyles p = ConditionalStyles {+ hostURL :: URI,+ mediaDocument :: String,+ rules :: [ConditionalRule p],+ propertyParser :: p+}++conditionalStyles :: PropertyParser p => URI -> String -> ConditionalStyles p+conditionalStyles uri mediaDocument' = ConditionalStyles uri mediaDocument' [] temp++data ConditionalRule p = Priority Int | StyleRule' StyleRule | AtRule Text [Token] |+ External Query.Expr URI | Internal Query.Expr (ConditionalStyles p)++addRule' :: ConditionalStyles p -> ConditionalRule p -> ConditionalStyles p+addRule' self rule = self {rules = rule : rules self}++hostUrlS :: ConditionalStyles p -> String+hostUrlS = show . hostURL++parseAtBlock :: StyleSheet t => t -> [Token] -> (t, [Token])+parseAtBlock self (LeftCurlyBracket:toks) =+ let (block, toks') = scanBlock toks in (parse' self block, toks')+parseAtBlock self (_:toks) = parseAtBlock self toks+parseAtBlock self [] = (self, [])++instance PropertyParser p => StyleSheet (ConditionalStyles p) where+ setPriority x self = addRule' self $ Priority x+ addRule self rule = addRule' self $ StyleRule' rule++ addAtRule self "document" (Whitespace:toks) = addAtRule self "document" toks+ addAtRule self "document" (Comma:toks) = addAtRule self "document" toks+ addAtRule self "document" (Url match:toks)+ | unpack match == hostUrlS self = parseAtBlock self toks+ | otherwise = addAtRule self "document" toks+ addAtRule self "document" (Function "url-prefix":String match:RightParen:toks)+ | unpack match `isPrefixOf` hostUrlS self = parseAtBlock self toks+ | otherwise = addAtRule self "document" toks+ addAtRule self "document" (Function "domain":String match:RightParen:toks)+ | unpack match == domain || ('.':unpack match) `isSuffixOf` domain =+ parseAtBlock self toks+ | otherwise = addAtRule self "document" toks+ where+ domain | Just auth <- uriAuthority $ hostURL self = uriRegName auth+ | otherwise = ""+ addAtRule self "document" (Function "media-document":String match:RightParen:toks)+ | unpack match == mediaDocument self = parseAtBlock self toks+ | otherwise = addAtRule self "document" toks+ -- TODO Support regexp() conditions, requires new dependency+ addAtRule self "document" tokens = (self, skipAtRule tokens)++ addAtRule self "media" toks+ | (cond, LeftCurlyBracket:block) <- Query.parse LeftCurlyBracket toks =+ let (block', toks') = scanBlock block in+ (addRule' self $ Internal cond $ parse' self {rules = []} block', toks')+ addAtRule self "media" tokens = (self, skipAtRule tokens)++ addAtRule self "import" (Whitespace:toks) = addAtRule self "import" toks+ addAtRule self "import" (Url src:toks) = parseAtImport self src toks+ addAtRule self "import" (String src:toks) = parseAtImport self src toks+ addAtRule self "import" tokens = (self, skipAtRule tokens)++ addAtRule self "supports" toks =+ let (cond, toks') = break (== LeftCurlyBracket) toks in+ if evalSupports (propertyParser self) cond+ then parseAtBlock self toks' else (self, skipAtRule toks')++ addAtRule self rule tokens = let (block, rest) = scanAtRule tokens in+ (addRule' self $ AtRule rule block, rest)+--------+---- @import/@media+--------+parseAtImport :: PropertyParser p => ConditionalStyles p -> Text ->+ [Token] -> (ConditionalStyles p, [Token])+parseAtImport self src toks+ | (cond, Semicolon:toks') <- Query.parse Semicolon toks, Just uri <- parseURI $ unpack src =+ (addRule' self $ External cond uri, toks')+parseAtImport self _ toks = (self, skipAtRule toks)++extractImports :: (Text -> Query.Datum) -> (Token -> Query.Datum) -> ConditionalStyles p -> [URI]+extractImports vars evalToken self =+ [uri | External cond uri <- rules self, Query.eval vars evalToken cond]++resolveImports :: ConditionalStyles p -> [(URI, ConditionalStyles p)] -> ConditionalStyles p+resolveImports self responses = self {rules = map resolveImport $ rules self}+ where+ resolveImport (External cond uri) | (body:_) <- [body | (uri', body) <- responses, uri' == uri] =+ Internal cond body+ resolveImport x = x++loadImports :: PropertyParser p => (URI -> IO Text) -> (Text -> Query.Datum) -> (Token -> Query.Datum) ->+ ConditionalStyles p -> [URI] -> IO (ConditionalStyles p)+loadImports loader vars evalToken self blocklist = do+ let imports = extractImports vars evalToken self+ imported <- loadAll [url | url <- imports, url `notElem` blocklist] Nothing+ return $ resolveImports self imported+ where+ loadAll urls Nothing = loadAll urls $ Just urls+ loadAll (url:urls) (Just blocklist') = do+ source <- loader url+ let parsed = parse self {rules = []} source+ styles <- loadImports loader vars evalToken parsed (blocklist ++ blocklist')+ rest <- loadAll urls $ Just blocklist'+ return ((url, styles):rest)+ loadAll [] _ = return []++resolve :: StyleSheet s => (Text -> Query.Datum) -> (Token -> Query.Datum) ->+ s -> ConditionalStyles p -> s+resolve v t styles self = resolve' v t (reverse $ rules self) styles+resolve' :: StyleSheet s => (Text -> Query.Datum) -> (Token -> Query.Datum) ->+ [ConditionalRule p] -> s -> s+resolve' v t (Priority x:rules') styles = resolve' v t rules' $ setPriority x styles+resolve' v t (StyleRule' rule:rules') styles = resolve' v t rules' $ addRule styles rule+resolve' v t (AtRule name block:rules') styles = resolve' v t rules' $ fst $ addAtRule styles name block+resolve' v t (Internal cond block:rules') styles | Query.eval v t cond =+ resolve' v t rules' $ resolve v t styles block+resolve' v t (_:rules') styles = resolve' v t rules' styles+resolve' _ _ [] styles = styles++--------+---- @supports+--------++evalSupports :: PropertyParser p => p -> [Token] -> Bool+evalSupports self (Whitespace:toks) = evalSupports self toks+evalSupports self (Ident "not":toks) = not $ evalSupports self toks+evalSupports self (LeftParen:toks) = let (block, toks') = scanBlock toks in+ evalSupportsOp toks' self $ supportsProperty block self+evalSupports self (Function "selector":toks) = let (block, toks') = scanBlock toks in+ evalSupportsOp toks' self $ supportsSelector block+evalSupports _ _ = False++evalSupportsOp :: PropertyParser p => [Token] -> p -> Bool -> Bool+evalSupportsOp (Whitespace:toks) self right = evalSupportsOp toks self right+evalSupportsOp (Ident "and":toks) self right = right && evalSupports self toks+evalSupportsOp (Ident "or":toks) self right = right || evalSupports self toks+evalSupportsOp [RightParen] _ ret = ret -- scanBlock captures closing paren+evalSupportsOp [] _ ret = ret+evalSupportsOp _ _ _ = False++supportsProperty :: PropertyParser p => [Token] -> p -> Bool+supportsProperty (Whitespace:toks) self = supportsProperty toks self+supportsProperty toks@(Ident "not":_) self = evalSupports self toks -- Special case fallback+supportsProperty (Ident key:toks) self+ | (Colon:value) <- skipSpace toks = -- "init"'s used to strip trailing RightParen+ shorthand self key (filter (/= Whitespace) $ init value) /= []+ | skipSpace toks `elem` [[RightParen], []] = shorthand self key [Ident "initial"] /= []+ | otherwise = False+supportsProperty toks self = evalSupports self toks -- Fallback to parenthesized expression.++supportsSelector :: [Token] -> Bool+supportsSelector toks = let (sels, toks') = parseSelectors toks in+ sels /= [] && (toks' == [] || toks' == [RightParen])
+ src/Data/CSS/Preprocessor/Conditions/Expr.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.CSS.Preprocessor.Conditions.Expr(+ Expr, Op(..), parse, parse', eval, Datum(..)+ ) where++import Data.CSS.Syntax.Tokens(Token(..))+import Data.Text.Internal (Text(..))+import Data.Text (stripPrefix)++type Expr = [Op]+data Op = And | Or | Not | Var Text | Tok Token | MkRatio | Func Text [Token]+ | Less | LessEq | Equal | Greater | GreaterEq deriving (Show, Eq)++parse :: Token -> [Token] -> (Expr, [Token])+parse end toks = let (toks', rest) = break (== end) toks in (parse' toks' [], rest)++--------+---- Shunting Yard parser+--------+parse' :: [Token] -> [(Op, Int)] -> Expr+parse' (Whitespace:toks) ops = parse' toks ops++parse' (Comma:toks) ops = pushOp toks Or 10 ops+parse' (Ident "not":toks) ops = pushOp toks Not 20 ops+parse' (Function "not":toks) ops = pushOp toks Not 0 ops+parse' (Ident "only":toks) ops = parse' toks ops+parse' (Ident "and":toks) ops = pushOp toks And 30 ops+parse' (Ident "or":toks) ops = pushOp toks Or 30 ops+parse' (Delim '<':Delim '=':toks) ops = pushOp toks LessEq 40 ops+parse' (Delim '<':toks) ops = pushOp toks Less 40 ops+parse' (Delim '>':Delim '=':toks) ops = pushOp toks GreaterEq 40 ops+parse' (Delim '>':toks) ops = pushOp toks Greater 40 ops+parse' (Colon:tok:toks) ops = Tok tok : pushOp toks Equal 40 ops+parse' (Delim '/':toks) ops = pushOp toks MkRatio 50 ops++parse' (LeftParen:toks) ops = pushOp toks (Var ")") 0 ops+parse' (RightParen:toks) ((Var ")", 0):ops) = parse' toks ops+parse' (RightParen:toks) ((Not, 0):ops) = Not : parse' toks ops -- Functional not syntax+parse' toks@(RightParen:_) ((op, _):ops) = op : parse' toks ops+parse' (RightParen:_) [] = [] -- Invalid!+parse' (Ident var:toks) ops@((peek, _):ops')+ -- First, fix up various range syntaxes.+ | peek `elem` [Less, LessEq, Greater, GreaterEq] = -- Chained conditions+ Var var : peek : Var var : parse' toks ops'+ | Just var' <- stripPrefix "max-" var = Var var' : pushOp toks LessEq 1000 ops+ | Just var' <- stripPrefix "min-" var = Var var' : pushOp toks GreaterEq 1000 ops+ | otherwise = Var var : parse' toks ops+parse' (tok:toks) ops = Tok tok : parse' toks ops+parse' [] ops = [op | (op, _) <- ops]++pushOp :: [Token] -> Op -> Int -> [(Op, Int)] -> Expr+pushOp toks op b ((peek, b'):ops') | b' >= b = peek : pushOp toks op b ops'+pushOp toks op b ops = parse' toks ((op, b):ops)++--------+---- Shunting Yard Evaluator+--------+data Datum = B Bool | N Float | Ratio Float Float deriving Eq++eval :: (Text -> Datum) -> (Token -> Datum) -> Expr -> Bool+eval = eval' []++eval' :: [Datum] -> (Text -> Datum) -> (Token -> Datum) -> Expr -> Bool+eval' (B y:B x:stack) v t (And:ops) = eval' (B (x && y):stack) v t ops+eval' (B y:B x:stack) v t (Or:ops) = eval' (B (x || y):stack) v t ops+eval' (B x:stack) v t (Not:ops) = eval' (B (not x):stack) v t ops+eval' stack v t (Var name:ops) = eval' (v name:stack) v t ops+-- Have tokens lower to variables, to make things easier for the callee.+eval' stack v t (Tok tok:ops) | t tok /= B False = eval' (t tok:stack) v t ops+eval' stack v t (Tok (Ident name):ops) = eval' (v name:stack) v t ops+-- TODO: How should I handle ratios?+eval' (N y:N x:stack) v t (MkRatio:ops) = eval' (Ratio x y:stack) v t ops+eval' (N y:N x:stack) v t (Less:ops) = eval' (B (x < y):stack) v t ops+eval' (N y:N x:stack) v t (LessEq:ops) = eval' (B (x <= y):stack) v t ops+eval' (y:x:stack) v t (Equal:ops) = eval' (B (x == y):stack) v t ops+eval' (N y:N x:stack) v t (Greater:ops) = eval' (B (x > y):stack) v t ops+eval' (N y:N x:stack) v t (GreaterEq:ops) = eval' (B (x >= y):stack) v t ops+eval' (B ret:_) _ _ [] = ret+eval' [] _ _ [] = True -- Special case+eval' _ _ _ _ = False -- Error handling fallback.
src/Data/CSS/Style/Cascade.hs view
@@ -50,20 +50,21 @@ cascade :: PropertyParser p => [StyleRule'] -> Props -> p -> p cascade styles overrides base =- dispatch base (inherit base) $ toList $ cascadeRules (getVars base ++ overrides) styles+ construct 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)+construct :: PropertyParser p => p -> Props -> p+construct base props = dispatch base child props+ where child = setVars [item | item@(n, _) <- props, isPrefixOf "--" n] $ inherit base+dispatch :: PropertyParser p => p -> p -> Props -> p+dispatch base child ((key, value):props) | Just child' <- longhand base child key value = dispatch base child' props | otherwise = dispatch base child props-dispatch' _ child [] = child+dispatch _ child [] = child -------- ---- attr()
src/Data/CSS/Syntax/StyleSheet.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Data.CSS.Syntax.StyleSheet ( parse, parse', parseForURL, TrivialStyleSheet(..),- StyleSheet(..), skipAtRule,+ StyleSheet(..), skipAtRule, scanAtRule, scanBlock, skipSpace, StyleRule(..), -- For parsing at-rules, HTML "style" attribute, etc. parseProperties, parseProperties',@@ -96,20 +96,22 @@ -------- ---- Skipping/Scanning utilities ---------skipAtRule :: [Token] -> [Token]-skipAtRule (Semicolon:tokens) = tokens-skipAtRule (LeftCurlyBracket:tokens) = skipBlock tokens+scanAtRule :: Parser [Token]+scanAtRule (Semicolon:tokens) = ([Semicolon], tokens)+scanAtRule tokens@(LeftCurlyBracket:_) = scanInner tokens $ \rest -> ([], rest) -skipAtRule (LeftParen:tokens) = skipAtRule $ skipBlock tokens-skipAtRule (Function _:tokens) = skipAtRule $ skipBlock tokens-skipAtRule (LeftSquareBracket:tokens) = skipAtRule $ skipBlock tokens+scanAtRule tokens@(LeftParen:_) = scanInner tokens scanValue+scanAtRule tokens@(Function _:_) = scanInner tokens scanValue+scanAtRule tokens@(LeftSquareBracket:_) = scanInner tokens scanValue -- To ensure parens are balanced, should already be handled.-skipAtRule (RightCurlyBracket:tokens) = RightCurlyBracket:tokens-skipAtRule (RightParen:tokens) = RightParen:tokens-skipAtRule (RightSquareBracket:tokens) = RightSquareBracket:tokens+scanAtRule (RightCurlyBracket:tokens) = ([], RightCurlyBracket:tokens)+scanAtRule (RightParen:tokens) = ([], RightParen:tokens)+scanAtRule (RightSquareBracket:tokens) = ([], RightSquareBracket:tokens) -skipAtRule (_:tokens) = skipAtRule tokens-skipAtRule [] = []+scanAtRule tokens = capture scanAtRule tokens++skipAtRule :: [Token] -> [Token]+skipAtRule tokens = snd $ scanAtRule tokens scanValue :: Parser [Token] scanValue (Semicolon:tokens) = ([], 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.0.0.0+version: 1.1.0.0 -- A short (one-line) description of the package. synopsis: Apply CSS styles to a document tree.@@ -53,12 +53,13 @@ library -- Modules exported by the library.- exposed-modules: Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style+ exposed-modules: Data.CSS.Syntax.StyleSheet, Data.CSS.Syntax.Selector, Data.CSS.Style, Data.CSS.Preprocessor.Conditions -- 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.Preprocessor.Conditions.Expr -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -84,5 +85,6 @@ 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+ network-uri >= 2.6 && <2.7, hspec, QuickCheck,+ scientific >= 0.3 && <1.0 ghc-options: -Wall
test/Test.hs view
@@ -3,9 +3,12 @@ import Test.Hspec import Data.HashMap.Strict+import Data.Maybe (fromJust)+import Network.URI+import Data.Scientific (toRealFloat) import Data.CSS.Syntax.Tokens-import Data.CSS.Syntax.StyleSheet+import Data.CSS.Syntax.StyleSheet (parse, StyleSheet(..), TrivialStyleSheet(..), scanAtRule, scanValue) import Data.CSS.Syntax.Selector import Data.CSS.Style.Common@@ -13,6 +16,9 @@ import Data.CSS.Style.Selector.Interpret import Data.CSS.Style +import Data.CSS.Preprocessor.Conditions+import Data.CSS.Preprocessor.Conditions.Expr (Datum(..), Op(..), parse', eval)+ main :: IO () main = hspec spec @@ -22,6 +28,11 @@ it "Test framework works" $ do True `shouldBe` True describe "Parsing" $ do+ it "Can scan @rules" $ do+ scanAtRule [Ident "utf-8", Semicolon, Ident "a"] `shouldBe` ([Ident "utf-8", Semicolon], [Ident "a"])+ scanAtRule [Ident "before", LeftCurlyBracket, Ident "inside", RightCurlyBracket, Ident "after"] `shouldBe` (+ [Ident "before", LeftCurlyBracket, Ident "inside", RightCurlyBracket],+ [Ident "after"]) it "Ignores @rules" $ do parse emptyStyle "@encoding 'utf-8';" `shouldBe` emptyStyle parse emptyStyle " @encoding 'utf-8';" `shouldBe` emptyStyle@@ -230,7 +241,7 @@ attributes = [Attribute "class" "link"] } let rules = parse queryable "a.link {color: green} a {color: red}"- let TrivialPropertyParser style = cascade rules el [] temp::TrivialPropertyParser+ let VarParser _ (TrivialPropertyParser style) = cascade rules el [] temp::(VarParser TrivialPropertyParser) style ! "color" `shouldBe` [Ident "green"] it "respects syntax order" $ do let el = ElementNode {@@ -240,11 +251,11 @@ attributes = [Attribute "class" "link"] } let rules = parse queryable "a {color: red; color: green}"- let TrivialPropertyParser style = cascade rules el [] temp::TrivialPropertyParser+ let VarParser _ (TrivialPropertyParser style) = cascade rules el [] temp::(VarParser TrivialPropertyParser) style ! "color" `shouldBe` [Ident "green"] let rules2 = parse queryable "a {color: red} a {color: green}"- let TrivialPropertyParser style2 = cascade rules2 el [] temp::TrivialPropertyParser+ let VarParser _ (TrivialPropertyParser style2) = cascade rules2 el [] temp::(VarParser TrivialPropertyParser) style2 ! "color" `shouldBe` [Ident "green"] it "respects stylesheet precedence" $ do let el = ElementNode {@@ -254,8 +265,8 @@ 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+ let rules2 = parse (rules {priority = 2}) "a {color: red}" :: QueryableStyleSheet (VarParser TrivialPropertyParser)+ let VarParser _ (TrivialPropertyParser style) = cascade rules2 el [] temp::(VarParser TrivialPropertyParser) style ! "color" `shouldBe` [Ident "green"] let el' = ElementNode {@@ -265,8 +276,8 @@ 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+ let rules2' = parse (rules' {priority = 2}) "a {color: green !important}" :: QueryableStyleSheet (VarParser TrivialPropertyParser)+ let VarParser _ (TrivialPropertyParser style') = cascade rules2' el' [] temp::(VarParser TrivialPropertyParser) style' ! "color" `shouldBe` [Ident "green"] it "respects overrides" $ do let el = ElementNode {@@ -276,7 +287,7 @@ attributes = [Attribute "class" "link"] } let rules = parse queryable "a {color: red;}"- let TrivialPropertyParser style = cascade rules el [("color", [Ident "green"])] temp::TrivialPropertyParser+ let VarParser _ (TrivialPropertyParser style) = cascade rules el [("color", [Ident "green"])] temp::(VarParser TrivialPropertyParser) style ! "color" `shouldBe` [Ident "green"] describe "Parser freezes" $ do it "does not regress" $ do@@ -300,13 +311,145 @@ scanValue [Function "fn", Ident "arg", LeftParen] `shouldBe` ([Function "fn", Ident "arg", LeftParen], []) + describe "CSS Variables" $ do+ it "are captured" $ do+ let parser = temp :: VarParser TrivialPropertyParser+ vars parser `shouldBe` []+ let parser1 = setVars [("--var", [Ident "value"])] parser+ vars parser1 `shouldBe` [("--var", [Ident "value"])]+ let parser2 = fromJust $ longhand parser parser1 "property" [Function "var", Ident "--var", RightParen]+ vars parser2 `shouldBe` [("--var", [Ident "value"])]+ let VarParser _ (TrivialPropertyParser style) = parser2+ style ! "property" `shouldBe` [Ident "value"]++ let el = ElementNode {+ name = "a",+ parent = Nothing,+ previous = Nothing,+ attributes = []+ }+ let rules = parse queryable "a {--var: value}"+ let VarParser v _ = cascade rules el [] temp+ v `shouldBe` [("--var", [Ident "value"])]+ it "applies within element" $ do+ let el = ElementNode {+ name = "a",+ parent = Nothing,+ previous = Nothing,+ attributes = []+ }+ let rules = parse queryable "a {--link: #f00; color: var(--link)}"+ let VarParser vars (TrivialPropertyParser style) = cascade rules el [] temp+ style ! "color" `shouldBe` [Hash HId "f00"]+ style ! "--link" `shouldBe` [Hash HId "f00"]+ vars `shouldBe` [("--link", [Hash HId "f00"])]+ it "inherits" $ do+ let parent = ElementNode {+ name = "a",+ parent = Nothing,+ previous = Nothing,+ attributes = []+ }+ let el = ElementNode {+ name = "b",+ parent = Just parent,+ previous = Nothing,+ attributes = []+ }+ let rules = parse queryable "a {--link: #f00} b {color: var(--link)}"+ let VarParser vars (TrivialPropertyParser style) = cascade rules el [] $ cascade rules parent [] temp+ vars `shouldBe` [("--link", [Hash HId "f00"])]+ style ! "color" `shouldBe` [Hash HId "f00"]+ describe "Conditional @rules" $ do+ it "handles normal rules" $ do+ let TrivialStyleSheet styles = resolve' $ parse conditional "a {color: green}"+ styles `shouldBe` [StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]++ let TrivialStyleSheet styles = resolve' $ parse conditional "@rule; a {color: green}"+ styles `shouldBe` [StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]++ let TrivialStyleSheet styles = resolve' $ parse conditional "a {color: green} @rule;"+ styles `shouldBe` [StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]++ let TrivialStyleSheet styles = resolve' $ parse conditional "a {color: green} @font {}"+ styles `shouldBe` [StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]++ let TrivialStyleSheet styles = resolve' $ parse conditional "@font {} a {color: green}"+ styles `shouldBe` [StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]+ it "handles @document" $ do+ let TrivialStyleSheet styles = resolve' $ parse conditional "@document url(about:blank) { a {color: green} }"+ styles `shouldBe` [StyleRule (Element []) [] "", StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]+ let TrivialStyleSheet styles = resolve' $ parse conditional "@document url(about:credits) { a {color: red} }"+ styles `shouldBe` []+ let TrivialStyleSheet styles = resolve' $ parse conditional "@document url-prefix('about:') { a {color: green} }"+ styles `shouldBe` [StyleRule (Element []) [] "", StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]+ let TrivialStyleSheet styles = resolve' $ parse conditional "@document url-prefix('https:') { a {color: red} }"+ styles `shouldBe` []+ let TrivialStyleSheet styles = resolve' $ parse conditional "@document media-document('test') { a {color: green} }"+ styles `shouldBe` [StyleRule (Element []) [] "", StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]+ let TrivialStyleSheet styles = resolve' $ parse conditional "@document media-document('other') { a {color: red} }"+ styles `shouldBe` []+ it "handles @media" $ do+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media test { a {color: green} }"+ styles `shouldBe` [StyleRule (Element []) [] "", StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media screen { a {color: red} }"+ styles `shouldBe` []++ let TrivialStyleSheet styles = resolve' $ parse conditional "@media test or screen { a {color: green} }"+ styles `shouldBe` [StyleRule (Element []) [] "", StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media test or test {a {color: green} }"+ styles `shouldBe` [StyleRule (Element []) [] "", StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media screen or screen {a {color: red} }"+ styles `shouldBe` []+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media screen or test {a {color: green} }"+ styles `shouldBe` [StyleRule (Element []) [] "", StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]++ let TrivialStyleSheet styles = resolve' $ parse conditional "@media test and screen { a {color: red} }"+ styles `shouldBe` []+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media test and test { a {color: green} }"+ styles `shouldBe` [StyleRule (Element []) [] "", StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media screen and screen { a {color: red} }"+ styles `shouldBe` []+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media screen and test {a {color: red} }"+ styles `shouldBe` []++ let TrivialStyleSheet styles = resolve' $ parse conditional "@media 2 < 3 { a {color: green} }"+ styles `shouldBe` [StyleRule (Element []) [] "", StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""]+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media 2 < 2 { a {color: red} }"+ styles `shouldBe` []+ let TrivialStyleSheet styles = resolve' $ parse conditional "@media 2 < 1 { a {color: red} }"+ styles `shouldBe` []+ it "handles @import" $ do+ let styles = parse conditional "@import url(about:style.css);"+ extractImports' styles `shouldBe` [URI "about:" Nothing "style.css" "" ""]+ let styles = parse conditional "@import 'about:style.css';"+ extractImports' styles `shouldBe` [URI "about:" Nothing "style.css" "" ""]++ let styles = parse conditional "@import url(about:style.css) test;"+ extractImports' styles `shouldBe` [URI "about:" Nothing "style.css" "" ""]+ let styles = parse conditional "@import url(about:style.css) screen;"+ extractImports' styles `shouldBe` []+ -- TODO @supports is harder to test+ styleIndex :: StyleIndex styleIndex = new-queryable :: QueryableStyleSheet TrivialPropertyParser+queryable :: QueryableStyleSheet (VarParser TrivialPropertyParser) queryable = queryableStyleSheet emptyStyle :: TrivialStyleSheet emptyStyle = TrivialStyleSheet []+conditional :: ConditionalStyles TrivialPropertyParser+conditional = conditionalStyles (fromJust $ parseURI "about:blank") "test" linkStyle :: TrivialStyleSheet linkStyle = TrivialStyleSheet [sampleRule] sampleRule :: StyleRule sampleRule = StyleRule (Element [Tag "a"]) [("color", [Ident "green"])] ""+resolve' = resolve (\var -> B (var == "test")) evalToken emptyStyle+ where+ evalToken (Number _ (NVInteger x)) = N $ fromInteger x+ evalToken (Number _ (NVNumber x)) = N $ toRealFloat x+ evalToken _ = B False+extractImports' = extractImports (\var -> B (var == "test")) evalToken+ where+ evalToken (Number _ (NVInteger x)) = N $ fromInteger x+ evalToken (Number _ (NVNumber x)) = N $ toRealFloat x+ evalToken _ = B False