~alcinnz/haskell-stylist

ref: 086da474d2729c627d0472e9f2e64e48a3968d0a haskell-stylist/src/Data/CSS/Style/Selector/Interpret.hs -rw-r--r-- 7.2 KiB
086da474 — Adrian Cochrane Rewrite trivial cases of :where & :is. 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
{-# 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 | Fail | Recursive Bool [Selector] | Nth Bool Integer Integer

-- | 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, String -> Bool)]) -> SelectorFunc
compileInner' ((Tagname tag:tests), attrs) = testTag tag $ 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' ([], attrs) = testAttrs (compileAttrs $ sortAttrs attrs) matched
compileAttrs :: [(Text, String -> Bool)] -> AttrsFunc
compileAttrs ((tag, test):attrs) = testAttr tag test $ compileAttrs attrs
compileAttrs [] = matched

lowerInner :: [SimpleSelector] -> ([IL], [(Text, String -> Bool)])
lowerInner (Tag tag:sel) = (Tagname tag:tests, attrs) where (tests, attrs) = lowerInner sel
lowerInner (Id i:s) = (tests, ("id", hasWord $ unpack i):attrs) where (tests, attrs) = lowerInner s
lowerInner (Class c:s) = (tests, ("class", hasWord $ unpack c):attrs) where (tests, attrs) = lowerInner s
lowerInner (Property prop test:s) = (tests, (prop, 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 c []:s) =
    (tests, ("", 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, b)] -> [(Text, b)]
sortAttrs = sortBy compareAttrs where compareAttrs x y = fst x `compare` fst y

--------
---- Runtime
--------
testTag :: Text -> SelectorFunc -> SelectorFunc
testTag tag success el | name el == tag = 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

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]
--------
---- 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