~alcinnz/haskell-stylist

ref: 86efaacd022a01aa470b1363b07689f866d99a14 haskell-stylist/src/Data/CSS/Preprocessor/PsuedoClasses.hs -rw-r--r-- 4.7 KiB
86efaacd — Adrian Cochrane Correct legacy :before/:after syntax. 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
{-# 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"