1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
{-# LANGUAGE OverloadedStrings #-}
-- | Lowers psuedoclasses to rawer syntactic forms.
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 as Txt
import Data.HashMap.Lazy as HM
import Data.Function ((&))
--------
---- core
--------
data LowerPsuedoClasses s = LowerPsuedoClasses {
inner :: s,
rewriteRules :: HashMap Text [Token],
psuedoEls :: [Text]
}
instance StyleSheet s => StyleSheet (LowerPsuedoClasses s) where
setPriority p self = self { inner = setPriority p $ inner self }
addRule self rule = self { inner = addRule (inner self) $ lowerRule self rule }
addAtRule self name toks = let (inner', toks') = addAtRule (inner self) name toks
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'
lowerSelector rewrites (Descendant p sel') = Descendant p $ lowerSelector' rewrites sel'
lowerSelector rewrites (Adjacent sib sel') = Adjacent sib $ lowerSelector' rewrites sel'
lowerSelector rewrites (Sibling sib sel') = Sibling sib $ lowerSelector' rewrites sel'
lowerSelector' :: HashMap Text [Token] -> [SimpleSelector] -> [SimpleSelector]
lowerSelector' rewrites (Psuedoclass name []:sels)
| Just value <- name `HM.lookup` rewrites = Psuedoclass "where" value : lowerSelector' rewrites sels
lowerSelector' rewrites (Psuedoclass name [arg]:sels)
| Just value <- name `HM.lookup` rewrites =
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"