~alcinnz/haskell-stylist

ref: a862da9315b5f44d11d5f060ca3f61c2c8451255 haskell-stylist/src/Data/CSS/Preprocessor/PsuedoClasses.hs -rw-r--r-- 5.6 KiB
a862da93 — Adrian Cochrane Test basics of counter substitution. 4 years ago
                                                                                
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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
{-# LANGUAGE OverloadedStrings #-}
-- | Lowers psuedoclasses to rawer syntactic forms.
module Data.CSS.Preprocessor.PsuedoClasses(LowerPsuedoClasses(..),
    psuedoClassesFilter, htmlPsuedoFilter,
    addRewrite, addRewrite', addPsuedoEl, addNamespace) where

import Data.CSS.Syntax.StyleSheet
import Data.CSS.Syntax.Selector
import Data.CSS.Syntax.Tokens

import Data.Text as Txt
import Data.Maybe (fromMaybe, listToMaybe)
import Data.HashMap.Lazy as HM
import Data.Function ((&))

--------
---- core
--------
data LowerPsuedoClasses s = LowerPsuedoClasses {
    inner :: s,
    rewriteRules :: HashMap Text [Token],
    psuedoEls :: [Text],
    namespaces :: HashMap Text 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 "namespace" (Ident ns:toks) | (Url url:toks') <- skipSpace toks =
        (addNamespace ns url self, toks')
    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 { namespaces = ns, rewriteRules = rewrites } (StyleRule sel props pseudoel) =
    StyleRule (lowerSelector ns rewrites sel) props pseudoel

extractPseudoEl :: [Text] -> Selector -> Maybe Text
extractPseudoEl ps (Element sel) = extractPseudoEl' ps sel
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
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 ns rewrites (Element sel') = Element $ lowerSelector' ns rewrites sel'
lowerSelector ns rewrites (Child p sel') =
    Child (lowerSelector ns rewrites p) $ lowerSelector' ns rewrites sel'
lowerSelector ns rewrites (Descendant p sel') =
    Descendant (lowerSelector ns rewrites p) $ lowerSelector' ns rewrites sel'
lowerSelector ns rewrites (Adjacent sib sel') =
    Adjacent (lowerSelector ns rewrites sib) $ lowerSelector' ns rewrites 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' 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 (sel:sels) = sel : lowerSelector' ns rewrites sels
lowerSelector' _ _ [] = []

--------
---- constructors
--------
psuedoClassesFilter :: StyleSheet s => s -> LowerPsuedoClasses s
psuedoClassesFilter s = LowerPsuedoClasses s HM.empty ["before", "after"] HM.empty

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 }

addNamespace :: Text -> Text -> LowerPsuedoClasses s -> LowerPsuedoClasses s
addNamespace ns uri self = self { namespaces = insert ns uri $ namespaces 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"