~alcinnz/haskell-stylist

ref: e3beef67bcef116271da14637b376e084fe02bfc haskell-stylist/src/Data/CSS/Style/Selector/Interpret.hs -rw-r--r-- 8.4 KiB
e3beef67 — Adrian Cochrane Add new style tree traversals. 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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
{-# LANGUAGE OverloadedStrings #-}
-- | Evaluates CSS selectors over an element.
-- INTERNAL MODULE.
module Data.CSS.Style.Selector.Interpret(
        compile, SelectorFunc,
        InterpretedRuleStore(..)
    ) where

import Data.CSS.Style.Common

import Data.Text (unpack)
import Data.List
import Data.Maybe
import Data.Bits (xor)

-- For pseudoclasses
import Data.CSS.Syntax.Selector (parseSelectors)
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))

-- | A compiled(?) CSS selector.
type SelectorFunc = Element -> Bool
type AttrsFunc = [Attribute] -> Bool
-- Mostly here for the sake of pseudoclasses.
data IL = Tagname Text | NS Text | Fail | Recursive Bool [Selector] | Nth Bool Integer Integer | Root

-- | Converts a parsed CSS selector into a callable function.
compile :: Selector -> SelectorFunc
compile (Element sel) = compileInner sel
compile (Child upSel sel) = direct parent (compile upSel) $ compileInner sel
compile (Descendant up sel) = indirect parent (compile up) $ compileInner sel
compile (Adjacent up sel) = direct previous (compile up) $ compileInner sel
compile (Sibling up sel) = indirect previous (compile up) $ compileInner sel

compileInner :: [SimpleSelector] -> SelectorFunc
compileInner sel = compileInner' $ lowerInner sel
compileInner' :: ([IL], [(Text, Maybe Text, String -> Bool)]) -> SelectorFunc
compileInner' (Tagname tag:tests, attrs) = testTag tag $ compileInner' (tests, attrs)
compileInner' (NS ns:tests, attrs) = testNS ns $ compileInner' (tests, attrs)
compileInner' (Fail:_, _) = \_ -> False
compileInner' (Recursive negate' sels:tests, attrs) =
    recursiveSelect negate' (map compile sels) $ compileInner' (tests, attrs)
compileInner' (Nth ofType n 0:tests, attrs) =
    nthChild ofType (fromInteger n) $ compileInner' (tests, attrs)
compileInner' (Nth ofType a b:tests, attrs) =
    nthChild' ofType (fromInteger a) (fromInteger b) $ compileInner' (tests, attrs)
compileInner' (Root:tests, attrs) = testRoot $ compileInner' (tests, attrs)
compileInner' ([], attrs) = testAttrs (compileAttrs $ sortAttrs attrs) matched
compileAttrs :: [(Text, Maybe Text, String -> Bool)] -> AttrsFunc
compileAttrs ((tag, Nothing, test):attrs) = testAttr tag test $ compileAttrs attrs
compileAttrs ((tag, Just ns, test):attrs) = testAttrNS ns tag test $ compileAttrs attrs
compileAttrs [] = matched

lowerInner :: [SimpleSelector] -> ([IL], [(Text, Maybe Text, String -> Bool)])
lowerInner (Namespace ns:sel) = (NS ns:tests, attrs) where (tests, attrs) = lowerInner sel
lowerInner (Tag tag:sel) = (Tagname tag:tests, attrs) where (tests, attrs) = lowerInner sel
lowerInner (Id i:s) = (tests, ("id", Nothing, hasWord $ unpack i):attrs) where (tests, attrs) = lowerInner s
lowerInner (Class c:s) = (tests, ("class", Nothing, hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s
lowerInner (Property ns prop test:s) = (tests, (prop, ns, compileAttrTest test):attrs)
    where (tests, attrs) = lowerInner s
-- psuedos, TODO handle argumented psuedoclasses.
lowerInner (Psuedoclass c args:s)
    | c `elem` ["is", "where"], (sels, []) <- parseSelectors args =
        (Recursive False sels:tests, attrs) where (tests, attrs) = lowerInner s
lowerInner (Psuedoclass "not" args:s) | (sels, []) <- parseSelectors args =
    (Recursive True sels:tests, attrs) where (tests, attrs) = lowerInner s
lowerInner (Psuedoclass "nth-child" args:s) =
    (parseNth False (filter (== Whitespace) args):tests, attrs) where (tests, attrs) = lowerInner s
lowerInner (Psuedoclass "nth-of-type" args:s) =
    (parseNth True (filter (== Whitespace) args):tests, attrs) where (tests, attrs) = lowerInner s
lowerInner (Psuedoclass "root" []:s) = (Root:tests, attrs) where (tests, attrs) = lowerInner s
lowerInner (Psuedoclass c []:s) =
    (tests, ("", Nothing, hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s
lowerInner (Psuedoclass _ _:_) = ([Fail], [])
lowerInner [] = ([], [])

compileAttrTest :: PropertyTest -> String -> Bool
compileAttrTest Exists = matched
compileAttrTest (Equals val) = (== (unpack val))
compileAttrTest (Suffix val) = isSuffixOf $ unpack val
compileAttrTest (Prefix val) = isPrefixOf $ unpack val
compileAttrTest (Substring val) = isInfixOf $ unpack val
compileAttrTest (Include val) = hasWord $ unpack val
compileAttrTest (Dash val) = hasLang $ unpack val

sortAttrs :: [(Text, Maybe Text, b)] -> [(Text, Maybe Text, b)]
sortAttrs = sortBy compareAttrs where compareAttrs (x, x', _) (y, y', _) = (x, x') `compare` (y, y')

--------
---- Runtime
--------
testTag :: Text -> SelectorFunc -> SelectorFunc
testTag tag success el | name el == tag = success el
    | otherwise = False
testNS :: Text -> SelectorFunc -> SelectorFunc
testNS ns success el | namespace el == ns = success el
    | otherwise = False
testAttrs :: AttrsFunc -> SelectorFunc -> SelectorFunc
testAttrs attrsTest success el | attrsTest $ attributes el = success el
    | otherwise = False
direct :: (Element -> Maybe Element) -> SelectorFunc -> SelectorFunc -> SelectorFunc
direct traverser upTest test el | Just up <- traverser el = test el && upTest up
    | otherwise = False
indirect :: (Element -> Maybe Element) -> SelectorFunc -> SelectorFunc -> SelectorFunc
indirect traverser upTest test el | Nothing <- traverser el = False
    | not $ test el = False
    | upTest (fromJust $ traverser el) = True
    | otherwise = indirect traverser upTest test $ fromJust $ traverser el
matched :: t -> Bool
matched _ = True

testAttr :: Text -> (String -> Bool) -> AttrsFunc -> AttrsFunc
testAttr expected test next attrs@(Attribute attr _ value : attrs')
    | attr < expected = testAttr expected test next attrs'
    | attr > expected = False
    | attr == expected && test value = next attrs
    | otherwise = False
testAttr _ _ _ [] = False
testAttrNS :: Text -> Text -> (String -> Bool) -> AttrsFunc -> AttrsFunc
testAttrNS expectedNS expected test next attrs@(Attribute attr ns value : attrs')
    | (attr, ns) < (expected, expectedNS) = testAttrNS expectedNS expected test next attrs'
    | (attr, ns) > (expected, expectedNS) = False
    | (attr, ns) == (expected, expectedNS) && test value = next attrs
    | otherwise = False
testAttrNS _ _ _ _ [] = False

hasWord :: String -> String -> Bool
hasWord expected value = expected `elem` words value
hasLang :: [Char] -> [Char] -> Bool
hasLang expected value = expected == value || isPrefixOf (expected ++ "-") value

--- Pseudoclasses
recursiveSelect :: Bool -> [SelectorFunc] -> SelectorFunc -> SelectorFunc
recursiveSelect negate' sels success el | negate' `xor` any ($ el) sels = success el
    | otherwise = False

parseNth :: Bool -> [Token] -> IL
parseNth ofType [Ident "odd"] = Nth ofType 2 1
parseNth ofType [Ident "even"] = Nth ofType 2 0
parseNth x [Dimension _ (NVInteger a) "n", Number _ (NVInteger b)] = Nth x a b
parseNth x [Number _ (NVInteger b), Dimension _ (NVInteger a) "n"] = Nth x a b
parseNth x [Dimension _ (NVInteger a) "n", Delim '+', Number _ (NVInteger b)] = Nth x a b
parseNth x [Number _ (NVInteger b), Delim '+', Dimension _ (NVInteger a) "n"] = Nth x a b
parseNth x [Dimension _ (NVInteger a) "n", Delim '-', Number _ (NVInteger b)] = Nth x a $ negate b
parseNth x [Number _ (NVInteger b), Delim '-', Dimension _ (NVInteger a) "n"] = Nth x a $ negate b
parseNth _ _ = Fail

nthChild :: Bool -> Int -> (Element -> Bool) -> Element -> Bool
nthChild ofType n success el | countPrev ofType el == n = success el
    | otherwise = False
nthChild' :: Bool -> Int -> Int -> (Element -> Bool) -> Element -> Bool
nthChild' ofType a b success el | countPrev ofType el `rem` a == b = success el
    | otherwise = False
countPrev :: Bool -> Element -> Int
countPrev ofType el =
    length [el' | el' <- maybeStar previous el, name el == name el' || not ofType]
maybeStar :: (t -> Maybe t) -> t -> [t]
maybeStar cb x | Just y <- cb x = x : maybeStar cb y
    | otherwise = [x]

testRoot :: (Element -> Bool) -> Element -> Bool
testRoot cb el | Just _ <- parent el = cb el
    | otherwise = False
--------
---- RuleStore wrapper
--------
-- | Compiles & fully evaluates CSS selectors.
data InterpretedRuleStore inner = InterpretedRuleStore inner
instance RuleStore inner => RuleStore (InterpretedRuleStore inner) where
    new = InterpretedRuleStore new
    addStyleRule (InterpretedRuleStore self) priority rule =
        InterpretedRuleStore $ addStyleRule self priority $ rule {
            compiledSelector = compile $ selector rule
        }
    lookupRules (InterpretedRuleStore self) el = filter call $ lookupRules self el
        where call (StyleRule' _ test _) = test el