~alcinnz/haskell-stylist

ref: 62083a71501b9a9051924abf451e8f810b890363 haskell-stylist/src/Data/CSS/Style/Selector/Index.hs -rw-r--r-- 4.3 KiB
62083a71 — Adrian Cochrane Add hook for callers to run their own tests against attributes. 3 years ago
                                                                                
c1fca3d5 Adrian Cochrane
186cbffa Adrian Cochrane
c1fca3d5 Adrian Cochrane
e5b85906 Adrian Cochrane
c1fca3d5 Adrian Cochrane
186cbffa Adrian Cochrane
c1fca3d5 Adrian Cochrane
186cbffa Adrian Cochrane
c1fca3d5 Adrian Cochrane
ccae6742 Adrian Cochrane
c1fca3d5 Adrian Cochrane
ccae6742 Adrian Cochrane
c1fca3d5 Adrian Cochrane
e8c6873f Adrian Cochrane
c1fca3d5 Adrian Cochrane
ccae6742 Adrian Cochrane
e8c6873f Adrian Cochrane
5ff74dcf Adrian Cochrane
e5b85906 Adrian Cochrane
e8c6873f Adrian Cochrane
c1fca3d5 Adrian Cochrane
ccae6742 Adrian Cochrane
c1fca3d5 Adrian Cochrane
edfaf74d Adrian Cochrane
c1fca3d5 Adrian Cochrane
5ff74dcf Adrian Cochrane
edfaf74d Adrian Cochrane
c1fca3d5 Adrian Cochrane
5ff74dcf Adrian Cochrane
edfaf74d Adrian Cochrane
5ff74dcf Adrian Cochrane
c1fca3d5 Adrian Cochrane
ccae6742 Adrian Cochrane
c1fca3d5 Adrian Cochrane
5ff74dcf Adrian Cochrane
e5b85906 Adrian Cochrane
5ff74dcf Adrian Cochrane
c1fca3d5 Adrian Cochrane
62083a71 Adrian Cochrane
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
{-# LANGUAGE OverloadedStrings #-}
-- | Fast lookup & storage for style rules.
-- INTERNAL MODULE.
module Data.CSS.Style.Selector.Index (
        StyleIndex(..),
        rulesForElement
    ) where

-- TODO do performance tests to decide beside between strict/lazy.
import Data.HashMap.Strict
import Data.List (nub)
import Data.CSS.Style.Common

import Data.Hashable
import Data.Text (unpack, pack)
import Data.CSS.Syntax.Tokens (serialize) -- for easy hashing

-- | Fast lookup & storage for style rules.
data StyleIndex = StyleIndex {
    indexed :: HashMap SimpleSelector [StyleRule'],
    unindexed :: [StyleRule']
}

lookup' :: SimpleSelector -> HashMap SimpleSelector [a] -> [a]
lookup' = lookupDefault []

instance RuleStore StyleIndex where
    new = StyleIndex {indexed = empty, unindexed = []}
    addStyleRule self _ rule | [] == properties rule = self
        | otherwise = addRuleForSelector self rule $ simpleSelector $ selector rule
    lookupRules self element = nub $ Prelude.foldr (++) [] rules
        where
            get key = lookup' key index
            index = indexed self
            rules = unindexed self : Prelude.map get (testsForElement element)

-- | LEGACY TESTING API.
rulesForElement :: StyleIndex -> Element -> [StyleRule] -- For testing
rulesForElement self element = Prelude.map inner $ lookupRules self element

---

simpleSelector :: Selector -> [SimpleSelector]
simpleSelector (Element s) = s
simpleSelector (Child _ s) = s
simpleSelector (Descendant _ s) = s
simpleSelector (Adjacent _ s) = s
simpleSelector (Sibling _ s) = s

addRuleForSelector :: StyleIndex -> StyleRule' -> [SimpleSelector] -> StyleIndex
addRuleForSelector self@(StyleIndex index _) rule sel
  | Just key <- selectorKey sel = self {
        indexed = insert key (rule : lookup' key index) index
    }
  | otherwise = self {unindexed = rule : unindexed self}

selectorKey :: [SimpleSelector] -> Maybe SimpleSelector
selectorKey (tok@(Tag _) : _) = Just tok
selectorKey (tok@(Id _) : _) = Just tok
selectorKey (tok@(Class _) : _) = Just tok
selectorKey (Property _ prop _ : _) = Just $ Property Nothing prop Exists
selectorKey (_ : tokens) = selectorKey tokens
selectorKey [] = Nothing

----

testsForAttributes :: [Attribute] -> [SimpleSelector]
testsForElement :: Element -> [SimpleSelector]
testsForElement element =
    (Tag $ name element) : (testsForAttributes $ attributes element)
testsForAttributes (Attribute "class" _ value:attrs) =
    (Prelude.map (\s -> Class $ pack s) $ words value) ++
        (Property Nothing "class" Exists : testsForAttributes attrs)
testsForAttributes (Attribute "id" _ value:attrs) =
    (Prelude.map (\s -> Id $ pack s) $ words value) ++
        (Property Nothing "id" Exists : testsForAttributes attrs)
testsForAttributes (Attribute elName _ _:attrs) =
    Property Nothing elName Exists : testsForAttributes attrs
testsForAttributes [] = []

-- Implement hashable for SimpleSelector here because it proved challenging to automatically derive it.
instance Hashable SimpleSelector where
    hashWithSalt seed (Tag tag) = seed `hashWithSalt` (0::Int) `hashWithSalt` unpack tag
    hashWithSalt seed (Id i) = seed `hashWithSalt` (1::Int) `hashWithSalt` unpack i
    hashWithSalt seed (Class class_) = seed `hashWithSalt` (2::Int) `hashWithSalt` unpack class_
    hashWithSalt seed (Property ns prop test) =
        seed `hashWithSalt` (3::Int) `hashWithSalt` unpack <$> ns `hashWithSalt` unpack prop `hashWithSalt` test
    hashWithSalt seed (Psuedoclass p args) =
        seed `hashWithSalt` (4::Int) `hashWithSalt` p `hashWithSalt` serialize args
    hashWithSalt seed (Namespace ns) = seed `hashWithSalt` (5::Int) `hashWithSalt` unpack ns

instance Hashable PropertyTest where
    hashWithSalt seed Exists = seed `hashWithSalt` (0::Int)
    hashWithSalt seed (Equals val) = seed `hashWithSalt` (1::Int) `hashWithSalt` unpack val
    hashWithSalt seed (Suffix val) = seed `hashWithSalt` (2::Int) `hashWithSalt` unpack val
    hashWithSalt seed (Prefix val) = seed `hashWithSalt` (3::Int) `hashWithSalt` unpack val
    hashWithSalt seed (Substring val) = seed `hashWithSalt` (4::Int) `hashWithSalt` unpack val
    hashWithSalt seed (Include val) = seed `hashWithSalt` (5::Int) `hashWithSalt` unpack val
    hashWithSalt seed (Dash val) = seed `hashWithSalt` (6::Int) `hashWithSalt` unpack val
    hashWithSalt seed (Callback _) = seed `hashWithSalt` (7::Int)