From d5d20109987fcd3fb7befff090b95cd1b8c2bdef Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 7 Aug 2019 13:23:11 +1200
Subject: [PATCH] Implement var() via a PropertyParser decorator.

---
 src/Data/CSS/Style.hs         | 36 ++++++++++++++++++++++++++++++++---
 src/Data/CSS/Style/Cascade.hs |  7 ++++---
 2 files changed, 37 insertions(+), 6 deletions(-)

diff --git a/src/Data/CSS/Style.hs b/src/Data/CSS/Style.hs
index a2d513a..de85895 100644
--- a/src/Data/CSS/Style.hs
+++ b/src/Data/CSS/Style.hs
@@ -2,7 +2,7 @@
 module Data.CSS.Style(
         QueryableStyleSheet, QueryableStyleSheet'(..), queryableStyleSheet,
         queryRules,
-        PropertyParser(..), cascade, cascade',
+        PropertyParser(..), cascade, cascade', VarParser(..),
         TrivialPropertyParser(..),
         Element(..), Attribute(..)
     ) where
@@ -15,9 +15,11 @@ 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.Tokens (Token(..))
 import Data.CSS.Syntax.StyleSheet (StyleSheet(..))
-import Data.HashMap.Strict (HashMap, lookupDefault)
+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))
@@ -65,3 +67,31 @@ 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 []
diff --git a/src/Data/CSS/Style/Cascade.hs b/src/Data/CSS/Style/Cascade.hs
index 6d3b42c..f4ef0a7 100644
--- a/src/Data/CSS/Style/Cascade.hs
+++ b/src/Data/CSS/Style/Cascade.hs
@@ -10,7 +10,7 @@ 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)
+import Data.Text (unpack, pack, isPrefixOf)
 
 class PropertyParser a where
     temp :: a
@@ -58,7 +58,8 @@ 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 props child) props
+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
@@ -76,7 +77,7 @@ 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:LeftParen:toks) attrs =
+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' [] _ = []
-- 
2.30.2