From e65bf5632729f04b25cf9c304f3434b9052c2358 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 1 May 2023 17:07:33 +1200
Subject: [PATCH] Adjust cascade shorthand to feed pseudoelements to the
 property parsers, now that Stylist Traits provides the APIs for it.

---
 src/Data/CSS/Style.hs         | 16 ++++++++++++++--
 src/Data/CSS/Style/Cascade.hs | 12 +++++++++---
 2 files changed, 23 insertions(+), 5 deletions(-)

diff --git a/src/Data/CSS/Style.hs b/src/Data/CSS/Style.hs
index a19bf5d..047d7e7 100644
--- a/src/Data/CSS/Style.hs
+++ b/src/Data/CSS/Style.hs
@@ -23,8 +23,10 @@ import Data.CSS.Syntax.StyleSheet (StyleSheet(..), skipAtRule)
 import Data.CSS.Syntax.AtLayer as AtLayer
 
 import Data.HashMap.Strict (HashMap, lookupDefault, fromList)
+import qualified Data.HashMap.Strict as HM
 import Data.Text (isPrefixOf)
 import Data.List (elemIndex)
+import Data.Maybe (fromMaybe)
 
 -- | A parsed CSS stylesheet from which you can query styles to match an element.
 type QueryableStyleSheet parser = QueryableStyleSheet' (ImportanceSplitter (
@@ -79,9 +81,19 @@ queryRules (QueryableStyleSheet' store' _ _ _ _) = Cascade.query store'
 cascade' :: PropertyParser p => [StyleRule'] -> Props -> p -> p
 cascade' = Cascade.cascade
 
--- | Facade over `queryRules` & `cascade'` for simple cases you don't care about psuedoelements.
+-- | Facade over `queryRules` & `cascade'`.
+-- Instead of exposing pseudoelements to callers it exposes pseudoelements to
+-- the `PropertyParser` implementation.
 cascade :: PropertyParser p => QueryableStyleSheet p -> Element -> Props -> p -> p
-cascade self el = cascade' $ lookupDefault [] "" $ queryRules self el
+cascade self el props style = HM.foldlWithKey' applyPseudoEl (cascade' (
+        lookupDefault [] "" rules) props style) rules
+  where
+    rules = queryRules self el
+    applyPseudoEl :: PropertyParser p => p -> Text -> [StyleRule'] -> p
+    applyPseudoEl self' "" _ = self'
+    applyPseudoEl self' pseudo props' = pseudoEl self' pseudo cb
+        where cb parent' base' = Cascade.cascadeWithParent props' [] parent' $
+                                    fromMaybe (inherit parent') base'
 
 --- Verify syntax during parsing, so invalid properties don't interfere with cascade.
 data PropertyExpander parser inner = PropertyExpander parser inner
diff --git a/src/Data/CSS/Style/Cascade.hs b/src/Data/CSS/Style/Cascade.hs
index 93a7ac1..3c64279 100644
--- a/src/Data/CSS/Style/Cascade.hs
+++ b/src/Data/CSS/Style/Cascade.hs
@@ -2,7 +2,7 @@
 -- | Applies CSS selection, cascade, & inheritance.
 -- INTERNAL MODULE.
 module Data.CSS.Style.Cascade(
-        query, cascade,
+        query, cascade, cascadeWithParent,
         TrivialPropertyParser(..), PropertyParser(..), Props
     ) where
 
@@ -41,15 +41,21 @@ query self el = Prelude.foldr yield empty $ lookupRules self el
 cascade :: PropertyParser p => [StyleRule'] -> Props -> p -> p
 cascade styles overrides base =
     construct base $ HML.toList $ cascadeRules (getVars base ++ overrides) styles
+-- | Variant of `cascade` which allows configuring base styles seperate from parent.
+cascadeWithParent :: PropertyParser p => [StyleRule'] -> Props -> p -> p -> p
+cascadeWithParent styles overrides parent' base = constructWithParent parent' 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 = HML.fromList (props ++ overrides)
 
+constructWithParent :: PropertyParser p => p -> p -> Props -> p
+constructWithParent parent' base props = dispatch parent' child props
+    where child = setVars [item | item@(n, _) <- props, isPrefixOf "--" n] base
 construct :: PropertyParser p => p -> Props -> p
-construct base props = dispatch base child props
-    where child = setVars [item | item@(n, _) <- props, isPrefixOf "--" n] $ inherit base
+construct base props = constructWithParent base (inherit base) props
 dispatch :: PropertyParser p => p -> p -> Props -> p
 dispatch base child ((key, value):props)
     | Just child' <- longhand base child key value = dispatch base child' props
-- 
2.30.2