From 86efaacd022a01aa470b1363b07689f866d99a14 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 21 Apr 2020 20:27:41 +1200
Subject: [PATCH] Correct legacy :before/:after syntax.

---
 src/Data/CSS/Preprocessor/PsuedoClasses.hs | 66 +++++++++++++++++++++-
 1 file changed, 63 insertions(+), 3 deletions(-)

diff --git a/src/Data/CSS/Preprocessor/PsuedoClasses.hs b/src/Data/CSS/Preprocessor/PsuedoClasses.hs
index d6c99c4..416d1cc 100644
--- a/src/Data/CSS/Preprocessor/PsuedoClasses.hs
+++ b/src/Data/CSS/Preprocessor/PsuedoClasses.hs
@@ -1,17 +1,23 @@
 {-# LANGUAGE OverloadedStrings #-}
 -- | Lowers psuedoclasses to rawer syntactic forms.
-module Data.CSS.Preprocessor.PsuedoClasses(LowerPsuedoClasses(..)) where
+module Data.CSS.Preprocessor.PsuedoClasses(LowerPsuedoClasses(..),
+    psuedoClassesFilter, addRewrite, addRewrite', addPsuedoEl, htmlPsuedoFilter) where
 
 import Data.CSS.Syntax.StyleSheet
 import Data.CSS.Syntax.Selector
 import Data.CSS.Syntax.Tokens
 
-import Data.Text
+import Data.Text as Txt
 import Data.HashMap.Lazy as HM
+import Data.Function ((&))
 
+--------
+---- core
+--------
 data LowerPsuedoClasses s = LowerPsuedoClasses {
     inner :: s,
-    rewriteRules :: HashMap Text [Token]
+    rewriteRules :: HashMap Text [Token],
+    psuedoEls :: [Text]
 }
 
 instance StyleSheet s => StyleSheet (LowerPsuedoClasses s) where
@@ -21,9 +27,21 @@ instance StyleSheet s => StyleSheet (LowerPsuedoClasses s) where
         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 { rewriteRules = rewrites } (StyleRule sel props pseudoel) =
     StyleRule (lowerSelector rewrites sel) props pseudoel
 
+extractPseudoEl :: [Text] -> Selector -> Maybe Text
+extractPseudoEl ps (Element sel)
+    | (pseudo:_) <- [p | Psuedoclass p [] <- sel, p `elem` ps] = Just pseudo
+    | otherwise = Nothing
+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
+
 lowerSelector :: HashMap Text [Token] -> Selector -> Selector
 lowerSelector rewrites (Element sel') = Element $ lowerSelector' rewrites sel'
 lowerSelector rewrites (Child p sel') = Child p $ lowerSelector' rewrites sel'
@@ -39,3 +57,45 @@ lowerSelector' rewrites (Psuedoclass name [arg]:sels)
         Psuedoclass "where" [if a == Ident "_" then arg else a | a <- value] : lowerSelector' rewrites sels
 lowerSelector' rewrites (sel:sels) = sel : lowerSelector' rewrites sels
 lowerSelector' _ [] = []
+
+--------
+---- constructors
+--------
+psuedoClassesFilter :: StyleSheet s => s -> LowerPsuedoClasses s
+psuedoClassesFilter s = LowerPsuedoClasses s HM.empty ["before", "after"]
+
+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 }
+
+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"
-- 
2.30.2