{-# LANGUAGE OverloadedStrings #-}
-- | Applies CSS selection, cascade, & inheritance.
-- INTERNAL MODULE.
module Data.CSS.Style.Cascade(
        query, cascade, cascadeWithParent,
        TrivialPropertyParser(..), PropertyParser(..), Props
    ) where

import Data.CSS.Style.Common
import Data.CSS.Syntax.Tokens
import Stylist (PropertyParser(..), Props)

-- TODO do performance tests to decide beside between strict/lazy,
--      or is another Map implementation better?
import Data.Hashable (Hashable)
import Data.HashMap.Strict as HM
import qualified Data.HashMap.Lazy as HML
import Data.Text (unpack, pack, isPrefixOf)

-- | Gather properties into a hashmap.
data TrivialPropertyParser = TrivialPropertyParser (HashMap String [Token]) deriving (Int -> TrivialPropertyParser -> ShowS
[TrivialPropertyParser] -> ShowS
TrivialPropertyParser -> String
(Int -> TrivialPropertyParser -> ShowS)
-> (TrivialPropertyParser -> String)
-> ([TrivialPropertyParser] -> ShowS)
-> Show TrivialPropertyParser
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TrivialPropertyParser] -> ShowS
$cshowList :: [TrivialPropertyParser] -> ShowS
show :: TrivialPropertyParser -> String
$cshow :: TrivialPropertyParser -> String
showsPrec :: Int -> TrivialPropertyParser -> ShowS
$cshowsPrec :: Int -> TrivialPropertyParser -> ShowS
Show, TrivialPropertyParser -> TrivialPropertyParser -> Bool
(TrivialPropertyParser -> TrivialPropertyParser -> Bool)
-> (TrivialPropertyParser -> TrivialPropertyParser -> Bool)
-> Eq TrivialPropertyParser
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TrivialPropertyParser -> TrivialPropertyParser -> Bool
$c/= :: TrivialPropertyParser -> TrivialPropertyParser -> Bool
== :: TrivialPropertyParser -> TrivialPropertyParser -> Bool
$c== :: TrivialPropertyParser -> TrivialPropertyParser -> Bool
Eq)
instance PropertyParser TrivialPropertyParser where
    temp :: TrivialPropertyParser
temp = HashMap String [Token] -> TrivialPropertyParser
TrivialPropertyParser HashMap String [Token]
forall k v. HashMap k v
empty
    longhand :: TrivialPropertyParser
-> TrivialPropertyParser
-> Text
-> [Token]
-> Maybe TrivialPropertyParser
longhand _ (TrivialPropertyParser self :: HashMap String [Token]
self) key :: Text
key value :: [Token]
value =
        TrivialPropertyParser -> Maybe TrivialPropertyParser
forall a. a -> Maybe a
Just (TrivialPropertyParser -> Maybe TrivialPropertyParser)
-> TrivialPropertyParser -> Maybe TrivialPropertyParser
forall a b. (a -> b) -> a -> b
$ HashMap String [Token] -> TrivialPropertyParser
TrivialPropertyParser (HashMap String [Token] -> TrivialPropertyParser)
-> HashMap String [Token] -> TrivialPropertyParser
forall a b. (a -> b) -> a -> b
$ String
-> [Token] -> HashMap String [Token] -> HashMap String [Token]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert (Text -> String
unpack Text
key) [Token]
value HashMap String [Token]
self

--------
---- Query/Psuedo-elements
--------

-- | Looks up style rules for an element, grouped by psuedoelement.
query :: RuleStore s => s -> Element -> HashMap Text [StyleRule']
query :: s -> Element -> HashMap Text [StyleRule']
query self :: s
self el :: Element
el = (StyleRule'
 -> HashMap Text [StyleRule'] -> HashMap Text [StyleRule'])
-> HashMap Text [StyleRule']
-> [StyleRule']
-> HashMap Text [StyleRule']
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Prelude.foldr StyleRule'
-> HashMap Text [StyleRule'] -> HashMap Text [StyleRule']
yield HashMap Text [StyleRule']
forall k v. HashMap k v
empty ([StyleRule'] -> HashMap Text [StyleRule'])
-> [StyleRule'] -> HashMap Text [StyleRule']
forall a b. (a -> b) -> a -> b
$ s -> Element -> [StyleRule']
forall a. RuleStore a => a -> Element -> [StyleRule']
lookupRules s
self Element
el
    where yield :: StyleRule'
-> HashMap Text [StyleRule'] -> HashMap Text [StyleRule']
yield rule :: StyleRule'
rule store :: HashMap Text [StyleRule']
store = ([StyleRule'] -> [StyleRule'] -> [StyleRule'])
-> Text
-> [StyleRule']
-> HashMap Text [StyleRule']
-> HashMap Text [StyleRule']
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
insertWith [StyleRule'] -> [StyleRule'] -> [StyleRule']
forall a. [a] -> [a] -> [a]
(++) (StyleRule' -> Text
psuedoElement StyleRule'
rule) [StyleRule' -> Element -> StyleRule'
resolveAttr StyleRule'
rule Element
el] HashMap Text [StyleRule']
store

--------
---- Cascade/Inheritance
--------

-- | Applies cascade for the given `StyleRule'`s & explicit styles,
-- parsed to a value of the same `PropertyParser` type passed in & inheriting from it.
cascade :: PropertyParser p => [StyleRule'] -> Props -> p -> p
cascade :: [StyleRule'] -> Props -> p -> p
cascade styles :: [StyleRule']
styles overrides :: Props
overrides base :: p
base =
    p -> Props -> p
forall p. PropertyParser p => p -> Props -> p
construct p
base (Props -> p) -> Props -> p
forall a b. (a -> b) -> a -> b
$ HashMap Text [Token] -> Props
forall k v. HashMap k v -> [(k, v)]
HML.toList (HashMap Text [Token] -> Props) -> HashMap Text [Token] -> Props
forall a b. (a -> b) -> a -> b
$ Props -> [StyleRule'] -> HashMap Text [Token]
cascadeRules (p -> Props
forall a. PropertyParser a => a -> Props
getVars p
base Props -> Props -> Props
forall a. [a] -> [a] -> [a]
++ Props
overrides) [StyleRule']
styles
-- | Variant of `cascade` which allows configuring base styles seperate from parent.
cascadeWithParent :: PropertyParser p => [StyleRule'] -> Props -> p -> p -> p
cascadeWithParent :: [StyleRule'] -> Props -> p -> p -> p
cascadeWithParent styles :: [StyleRule']
styles overrides :: Props
overrides parent' :: p
parent' base :: p
base = p -> p -> Props -> p
forall p. PropertyParser p => p -> p -> Props -> p
constructWithParent p
parent' p
base (Props -> p) -> Props -> p
forall a b. (a -> b) -> a -> b
$
    [Text] -> HashMap Text [Token] -> Props
forall k v. Hashable k => [k] -> HashMap k v -> [(k, v)]
toPrioList (p -> [Text]
forall a. PropertyParser a => a -> [Text]
priority p
base) (HashMap Text [Token] -> Props) -> HashMap Text [Token] -> Props
forall a b. (a -> b) -> a -> b
$ Props -> [StyleRule'] -> HashMap Text [Token]
cascadeRules (p -> Props
forall a. PropertyParser a => a -> Props
getVars p
base Props -> Props -> Props
forall a. [a] -> [a] -> [a]
++ Props
overrides) [StyleRule']
styles

cascadeRules :: Props -> [StyleRule'] -> HashMap Text [Token]
cascadeRules :: Props -> [StyleRule'] -> HashMap Text [Token]
cascadeRules overrides :: Props
overrides rules :: [StyleRule']
rules = Props -> Props -> HashMap Text [Token]
cascadeProperties Props
overrides (Props -> HashMap Text [Token]) -> Props -> HashMap Text [Token]
forall a b. (a -> b) -> a -> b
$ [Props] -> Props
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Props] -> Props) -> [Props] -> Props
forall a b. (a -> b) -> a -> b
$ (StyleRule' -> Props) -> [StyleRule'] -> [Props]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map StyleRule' -> Props
properties [StyleRule']
rules
cascadeProperties :: Props -> Props -> HashMap Text [Token]
cascadeProperties :: Props -> Props -> HashMap Text [Token]
cascadeProperties overrides :: Props
overrides props :: Props
props = Props -> HashMap Text [Token]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HML.fromList (Props
props Props -> Props -> Props
forall a. [a] -> [a] -> [a]
++ Props
overrides)

toPrioList :: Hashable k => [k] -> HashMap k v -> [(k, v)]
toPrioList :: [k] -> HashMap k v -> [(k, v)]
toPrioList (key :: k
key:keys :: [k]
keys) map :: HashMap k v
map
    | Just val :: v
val <- k
key k -> HashMap k v -> Maybe v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HM.lookup` HashMap k v
map =
        (k
key, v
val)(k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
:[k] -> HashMap k v -> [(k, v)]
forall k v. Hashable k => [k] -> HashMap k v -> [(k, v)]
toPrioList [k]
keys (k -> HashMap k v -> HashMap k v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
delete k
key HashMap k v
map)
    | Bool
otherwise = [k] -> HashMap k v -> [(k, v)]
forall k v. Hashable k => [k] -> HashMap k v -> [(k, v)]
toPrioList [k]
keys HashMap k v
map
toPrioList [] map :: HashMap k v
map = HashMap k v -> [(k, v)]
forall k v. HashMap k v -> [(k, v)]
toList HashMap k v
map

constructWithParent :: PropertyParser p => p -> p -> Props -> p
constructWithParent :: p -> p -> Props -> p
constructWithParent parent' :: p
parent' base :: p
base props :: Props
props = p -> p -> Props -> p
forall p. PropertyParser p => p -> p -> Props -> p
dispatch p
parent' p
child Props
props
    where child :: p
child = Props -> p -> p
forall a. PropertyParser a => Props -> a -> a
setVars [(Text, [Token])
item | item :: (Text, [Token])
item@(n :: Text
n, _) <- Props
props, Text -> Text -> Bool
isPrefixOf "--" Text
n] p
base
construct :: PropertyParser p => p -> Props -> p
construct :: p -> Props -> p
construct base :: p
base props :: Props
props = p -> p -> Props -> p
forall p. PropertyParser p => p -> p -> Props -> p
constructWithParent p
base (p -> p
forall a. PropertyParser a => a -> a
inherit p
base) Props
props
dispatch :: PropertyParser p => p -> p -> Props -> p
dispatch :: p -> p -> Props -> p
dispatch base :: p
base child :: p
child ((key :: Text
key, value :: [Token]
value):props :: Props
props)
    | Just child' :: p
child' <- p -> p -> Text -> [Token] -> Maybe p
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand p
base p
child Text
key [Token]
value = p -> p -> Props -> p
forall p. PropertyParser p => p -> p -> Props -> p
dispatch p
base p
child' Props
props
    | Bool
otherwise = p -> p -> Props -> p
forall p. PropertyParser p => p -> p -> Props -> p
dispatch p
base p
child Props
props
dispatch _ child :: p
child [] = p
child

--------
---- attr()
--------
resolveAttr :: StyleRule' -> Element -> StyleRule'
resolveAttr :: StyleRule' -> Element -> StyleRule'
resolveAttr self :: StyleRule'
self el :: Element
el = StyleRule'
self {
        inner :: StyleRule
inner = Selector -> Props -> Text -> StyleRule
StyleRule Selector
sel [(Text
n, [Token] -> HashMap Text String -> [Token]
resolveAttr' [Token]
v (HashMap Text String -> [Token]) -> HashMap Text String -> [Token]
forall a b. (a -> b) -> a -> b
$ Element -> HashMap Text String
attrs2Dict Element
el) | (n :: Text
n, v :: [Token]
v) <- Props
attrs] Text
psuedo
    } where StyleRule sel :: Selector
sel attrs :: Props
attrs psuedo :: Text
psuedo = StyleRule' -> StyleRule
inner StyleRule'
self

attrs2Dict :: Element -> HashMap Text String
attrs2Dict :: Element -> HashMap Text String
attrs2Dict el :: Element
el = [(Text, String)] -> HashMap Text String
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList [(Text
a, String
b) | Attribute a :: Text
a _ b :: String
b <- Element -> [Attribute]
attributes Element
el]

resolveAttr' :: [Token] -> HashMap Text String  -> [Token]
resolveAttr' :: [Token] -> HashMap Text String -> [Token]
resolveAttr' (Function "attr":Ident attr :: Text
attr:RightParen:toks :: [Token]
toks) attrs :: HashMap Text String
attrs =
    Text -> Token
String (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text -> HashMap Text String -> String
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
lookupDefault "" Text
attr HashMap Text String
attrs) Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> HashMap Text String -> [Token]
resolveAttr' [Token]
toks HashMap Text String
attrs
resolveAttr' (tok :: Token
tok:toks :: [Token]
toks) attrs :: HashMap Text String
attrs = Token
tok Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: [Token] -> HashMap Text String -> [Token]
resolveAttr' [Token]
toks HashMap Text String
attrs
resolveAttr' [] _ = []