{-# 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 {
    StyleIndex -> HashMap SimpleSelector [StyleRule']
indexed :: HashMap SimpleSelector [StyleRule'],
    StyleIndex -> [StyleRule']
unindexed :: [StyleRule']
}

lookup' :: SimpleSelector -> HashMap SimpleSelector [a] -> [a]
lookup' :: SimpleSelector -> HashMap SimpleSelector [a] -> [a]
lookup' = [a] -> SimpleSelector -> HashMap SimpleSelector [a] -> [a]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
lookupDefault []

instance RuleStore StyleIndex where
    new :: StyleIndex
new = StyleIndex :: HashMap SimpleSelector [StyleRule'] -> [StyleRule'] -> StyleIndex
StyleIndex {indexed :: HashMap SimpleSelector [StyleRule']
indexed = HashMap SimpleSelector [StyleRule']
forall k v. HashMap k v
empty, unindexed :: [StyleRule']
unindexed = []}
    addStyleRule :: StyleIndex -> [Int] -> StyleRule' -> StyleIndex
addStyleRule self :: StyleIndex
self _ rule :: StyleRule'
rule | [] [(Text, [Token])] -> [(Text, [Token])] -> Bool
forall a. Eq a => a -> a -> Bool
== StyleRule' -> [(Text, [Token])]
properties StyleRule'
rule = StyleIndex
self
        | Bool
otherwise = StyleIndex -> StyleRule' -> [SimpleSelector] -> StyleIndex
addRuleForSelector StyleIndex
self StyleRule'
rule ([SimpleSelector] -> StyleIndex) -> [SimpleSelector] -> StyleIndex
forall a b. (a -> b) -> a -> b
$ Selector -> [SimpleSelector]
simpleSelector (Selector -> [SimpleSelector]) -> Selector -> [SimpleSelector]
forall a b. (a -> b) -> a -> b
$ StyleRule' -> Selector
selector StyleRule'
rule
    lookupRules :: StyleIndex -> Element -> [StyleRule']
lookupRules self :: StyleIndex
self element :: Element
element = [StyleRule'] -> [StyleRule']
forall a. Eq a => [a] -> [a]
nub ([StyleRule'] -> [StyleRule']) -> [StyleRule'] -> [StyleRule']
forall a b. (a -> b) -> a -> b
$ ([StyleRule'] -> [StyleRule'] -> [StyleRule'])
-> [StyleRule'] -> [[StyleRule']] -> [StyleRule']
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Prelude.foldr [StyleRule'] -> [StyleRule'] -> [StyleRule']
forall a. [a] -> [a] -> [a]
(++) [] [[StyleRule']]
rules
        where
            get :: SimpleSelector -> [StyleRule']
get key :: SimpleSelector
key = SimpleSelector
-> HashMap SimpleSelector [StyleRule'] -> [StyleRule']
forall a. SimpleSelector -> HashMap SimpleSelector [a] -> [a]
lookup' SimpleSelector
key HashMap SimpleSelector [StyleRule']
index
            index :: HashMap SimpleSelector [StyleRule']
index = StyleIndex -> HashMap SimpleSelector [StyleRule']
indexed StyleIndex
self
            rules :: [[StyleRule']]
rules = StyleIndex -> [StyleRule']
unindexed StyleIndex
self [StyleRule'] -> [[StyleRule']] -> [[StyleRule']]
forall a. a -> [a] -> [a]
: (SimpleSelector -> [StyleRule'])
-> [SimpleSelector] -> [[StyleRule']]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map SimpleSelector -> [StyleRule']
get (Element -> [SimpleSelector]
testsForElement Element
element)

-- | LEGACY TESTING API.
rulesForElement :: StyleIndex -> Element -> [StyleRule] -- For testing
rulesForElement :: StyleIndex -> Element -> [StyleRule]
rulesForElement self :: StyleIndex
self element :: Element
element = (StyleRule' -> StyleRule) -> [StyleRule'] -> [StyleRule]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map StyleRule' -> StyleRule
inner ([StyleRule'] -> [StyleRule]) -> [StyleRule'] -> [StyleRule]
forall a b. (a -> b) -> a -> b
$ StyleIndex -> Element -> [StyleRule']
forall a. RuleStore a => a -> Element -> [StyleRule']
lookupRules StyleIndex
self Element
element

---

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

addRuleForSelector :: StyleIndex -> StyleRule' -> [SimpleSelector] -> StyleIndex
addRuleForSelector :: StyleIndex -> StyleRule' -> [SimpleSelector] -> StyleIndex
addRuleForSelector self :: StyleIndex
self@(StyleIndex index :: HashMap SimpleSelector [StyleRule']
index _) rule :: StyleRule'
rule sel :: [SimpleSelector]
sel
  | Just key :: SimpleSelector
key <- [SimpleSelector] -> Maybe SimpleSelector
selectorKey [SimpleSelector]
sel = StyleIndex
self {
        indexed :: HashMap SimpleSelector [StyleRule']
indexed = SimpleSelector
-> [StyleRule']
-> HashMap SimpleSelector [StyleRule']
-> HashMap SimpleSelector [StyleRule']
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert SimpleSelector
key (StyleRule'
rule StyleRule' -> [StyleRule'] -> [StyleRule']
forall a. a -> [a] -> [a]
: SimpleSelector
-> HashMap SimpleSelector [StyleRule'] -> [StyleRule']
forall a. SimpleSelector -> HashMap SimpleSelector [a] -> [a]
lookup' SimpleSelector
key HashMap SimpleSelector [StyleRule']
index) HashMap SimpleSelector [StyleRule']
index
    }
  | Bool
otherwise = StyleIndex
self {unindexed :: [StyleRule']
unindexed = StyleRule'
rule StyleRule' -> [StyleRule'] -> [StyleRule']
forall a. a -> [a] -> [a]
: StyleIndex -> [StyleRule']
unindexed StyleIndex
self}

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

----

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

-- Implement hashable for SimpleSelector here because it proved challenging to automatically derive it.
instance Hashable SimpleSelector where
    hashWithSalt :: Int -> SimpleSelector -> Int
hashWithSalt seed :: Int
seed (Tag tag :: Text
tag) = Int
seed Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (0::Int) Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text -> String
unpack Text
tag
    hashWithSalt seed :: Int
seed (Id i :: Text
i) = Int
seed Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (1::Int) Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text -> String
unpack Text
i
    hashWithSalt seed :: Int
seed (Class class_ :: Text
class_) = Int
seed Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (2::Int) Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text -> String
unpack Text
class_
    hashWithSalt seed :: Int
seed (Property ns :: Maybe Text
ns prop :: Text
prop test :: PropertyTest
test) =
        Int
seed Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (3::Int) Int -> Maybe String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text -> String
unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
ns Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text -> String
unpack Text
prop Int -> PropertyTest -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` PropertyTest
test
    hashWithSalt seed :: Int
seed (Psuedoclass p :: Text
p args :: [Token]
args) =
        Int
seed Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (4::Int) Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text
p Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` [Token] -> Text
serialize [Token]
args
    hashWithSalt seed :: Int
seed (Namespace ns :: Text
ns) = Int
seed Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (5::Int) Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Text -> String
unpack Text
ns

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