From 51a99e75c443072f5e11bcdd4d2200ba8736ebc7 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Thu, 31 Dec 2020 17:30:01 +1300
Subject: [PATCH] Allow callers to define psuedoclasses via callback.

---
 src/Data/CSS/Preprocessor/PsuedoClasses.hs | 32 +++++++++++++++-------
 1 file changed, 22 insertions(+), 10 deletions(-)

diff --git a/src/Data/CSS/Preprocessor/PsuedoClasses.hs b/src/Data/CSS/Preprocessor/PsuedoClasses.hs
index 4ed2a9e..8ac7433 100644
--- a/src/Data/CSS/Preprocessor/PsuedoClasses.hs
+++ b/src/Data/CSS/Preprocessor/PsuedoClasses.hs
@@ -2,7 +2,7 @@
 -- | Lowers psuedoclasses to rawer syntactic forms.
 module Data.CSS.Preprocessor.PsuedoClasses(LowerPsuedoClasses(..),
     psuedoClassesFilter, htmlPsuedoFilter,
-    addRewrite, addRewrite', addPsuedoEl, addNamespace) where
+    addRewrite, addRewrite', addPsuedoEl, addNamespace, addTest, PropertyTest) where
 
 import Data.CSS.Syntax.StyleSheet
 import Data.CSS.Syntax.Selector
@@ -16,9 +16,10 @@ import Data.Function ((&))
 --------
 ---- core
 --------
+type RewriteMap = HashMap Text ([Token] -> [SimpleSelector])
 data LowerPsuedoClasses s = LowerPsuedoClasses {
     inner :: s,
-    rewriteRules :: HashMap Text [Token],
+    rewriteRules :: RewriteMap,
     psuedoEls :: [Text],
     namespaces :: HashMap Text Text
 }
@@ -48,7 +49,7 @@ 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 :: HashMap Text Text -> RewriteMap -> 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'
@@ -59,14 +60,11 @@ lowerSelector ns rewrites (Adjacent sib 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' :: HashMap Text Text -> RewriteMap -> [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 (Psuedoclass name args:sels)
+    | Just value <- name `HM.lookup` rewrites = value args ++ lowerSelector' ns rewrites sels
 lowerSelector' ns rewrites (sel:sels) = sel : lowerSelector' ns rewrites sels
 lowerSelector' _ _ [] = []
 
@@ -82,7 +80,21 @@ 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 }
+addRewrite' name sel self =
+    addTest' name (\args -> [Psuedoclass "where" $ spliceArgs sel args]) self
+  where
+    spliceArgs [] [] = []
+    spliceArgs (Ident "_":toks) (arg:args) = arg : spliceArgs toks args
+    spliceArgs (tok:toks) args = tok : spliceArgs toks args
+    spliceArgs _ _ = [Ident "\tfail"]
+
+addTest :: Text -> Maybe Text -> Text -> PropertyFunc -> LowerPsuedoClasses s -> LowerPsuedoClasses s
+addTest name ns attr test self = addTest' name (noArg [Property ns attr $ Callback test]) self
+    where
+        noArg sel [] = sel
+        noArg _ _ = [Psuedoclass " fail" []]
+addTest' :: Text -> ([Token] -> [SimpleSelector]) -> LowerPsuedoClasses s -> LowerPsuedoClasses s
+addTest' 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 }
-- 
2.30.2