{-# LANGUAGE OverloadedStrings #-}
-- | Queries computed styles out of a specially-parsed CSS stylesheet.
-- See in particular `QueryableStyleSheet`, `queryRules`, & `cascade'`.
module Data.CSS.Style(
        QueryableStyleSheet, QueryableStyleSheet'(..), queryableStyleSheet,
        queryRules,
        PropertyParser(..), cascade, cascade', VarParser(..),
        TrivialPropertyParser(..),
        Element(..), Attribute(..)
    ) where

import Data.CSS.Style.Selector.Index
import Data.CSS.Style.Selector.Interpret
import Data.CSS.Style.Selector.Specificity
import Data.CSS.Style.Selector.LowerWhere
import Data.CSS.Style.Importance
import Data.CSS.Style.Common
import qualified Data.CSS.Style.Cascade as Cascade
import Data.CSS.Style.Cascade (PropertyParser(..), TrivialPropertyParser, Props)

import Data.CSS.Syntax.Tokens (Token(..))
import Data.CSS.Syntax.StyleSheet (StyleSheet(..), skipAtRule)
import Data.CSS.Syntax.AtLayer as AtLayer

import Data.HashMap.Strict (HashMap, lookupDefault, fromList)
import qualified Data.HashMap.Strict as HM
import Data.Text (isPrefixOf)
import Data.List (elemIndex)
import Data.Maybe (fromMaybe)

-- | A parsed CSS stylesheet from which you can query styles to match an element.
type QueryableStyleSheet parser = QueryableStyleSheet' (ImportanceSplitter (
        PropertyExpander parser (
            OrderedRuleStore (WhereLowerer (InterpretedRuleStore StyleIndex))
        )
    )) parser

-- | More generic version of `QueryableStyleSheet`.
data QueryableStyleSheet' store parser = QueryableStyleSheet' {
    -- | Internal datastructure for efficient style lookup.
    QueryableStyleSheet' store parser -> store
store :: store,
    -- | The "PropertyParser" to use for property syntax validation.
    QueryableStyleSheet' store parser -> parser
parser :: parser,
    -- | Whether author, useragent, or user styles are currently being parsed.
    -- The tail of this list indicates which Cascade Layer is active.
    QueryableStyleSheet' store parser -> [Int]
priorities :: [Int], -- author vs user agent vs user styles, incorporates Cascade Layers
    -- | Parse data for @layer, to give webdevs explicit control over the cascade.
    QueryableStyleSheet' store parser -> Tree
layers :: AtLayer.Tree,
    --- | The name of the @layer we're within.
    QueryableStyleSheet' store parser -> [Text]
layerNamespace :: [Text]
}

-- | Constructs an empty QueryableStyleSheet'.
queryableStyleSheet :: PropertyParser p => QueryableStyleSheet p
queryableStyleSheet :: QueryableStyleSheet p
queryableStyleSheet = QueryableStyleSheet' :: forall store parser.
store
-> parser
-> [Int]
-> Tree
-> [Text]
-> QueryableStyleSheet' store parser
QueryableStyleSheet' {
    store :: ImportanceSplitter
  (PropertyExpander
     p
     (OrderedRuleStore
        (WhereLowerer (InterpretedRuleStore StyleIndex))))
store = ImportanceSplitter
  (PropertyExpander
     p
     (OrderedRuleStore
        (WhereLowerer (InterpretedRuleStore StyleIndex))))
forall a. RuleStore a => a
new, parser :: p
parser = p
forall a. PropertyParser a => a
temp, layers :: Tree
layers = Tree
AtLayer.emptyTree,
    priorities :: [Int]
priorities = [0], layerNamespace :: [Text]
layerNamespace = [] }

instance (RuleStore s, PropertyParser p) => StyleSheet (QueryableStyleSheet' s p) where
    setPriorities :: [Int] -> QueryableStyleSheet' s p -> QueryableStyleSheet' s p
setPriorities vs :: [Int]
vs self :: QueryableStyleSheet' s p
self = QueryableStyleSheet' s p
self { priorities :: [Int]
priorities = [Int]
vs }
    addRule :: QueryableStyleSheet' s p -> StyleRule -> QueryableStyleSheet' s p
addRule self :: QueryableStyleSheet' s p
self@(QueryableStyleSheet' store' :: s
store' _ priority' :: [Int]
priority' _ _) rule :: StyleRule
rule = QueryableStyleSheet' s p
self {
            store :: s
store = s -> [Int] -> StyleRule' -> s
forall a. RuleStore a => a -> [Int] -> StyleRule' -> a
addStyleRule s
store' [Int]
priority' (StyleRule' -> s) -> StyleRule' -> s
forall a b. (a -> b) -> a -> b
$ StyleRule -> StyleRule'
styleRule' StyleRule
rule
        }
    addAtRule :: QueryableStyleSheet' s p
-> Text -> [Token] -> (QueryableStyleSheet' s p, [Token])
addAtRule self :: QueryableStyleSheet' s p
self@QueryableStyleSheet' { layerNamespace :: forall store parser. QueryableStyleSheet' store parser -> [Text]
layerNamespace = [Text]
ns, layers :: forall store parser. QueryableStyleSheet' store parser -> Tree
layers = Tree
layers_, priorities :: forall store parser. QueryableStyleSheet' store parser -> [Int]
priorities = v :: Int
v:_ }
            "layer" toks :: [Token]
toks =
        case [Text]
-> [Token]
-> Tree
-> ([Text] -> [Int] -> QueryableStyleSheet' s p)
-> (Tree, Maybe (QueryableStyleSheet' s p), [Token])
forall s.
StyleSheet s =>
[Text]
-> [Token]
-> Tree
-> ([Text] -> [Int] -> s)
-> (Tree, Maybe s, [Token])
parseAtLayer [Text]
ns [Token]
toks Tree
layers_ (([Text] -> [Int] -> QueryableStyleSheet' s p)
 -> (Tree, Maybe (QueryableStyleSheet' s p), [Token]))
-> ([Text] -> [Int] -> QueryableStyleSheet' s p)
-> (Tree, Maybe (QueryableStyleSheet' s p), [Token])
forall a b. (a -> b) -> a -> b
$ \ns' :: [Text]
ns' path :: [Int]
path -> QueryableStyleSheet' s p
self {
            priorities :: [Int]
priorities = Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
path, layerNamespace :: [Text]
layerNamespace = [Text]
ns'
        } of
            (layers' :: Tree
layers', Just self' :: QueryableStyleSheet' s p
self', toks' :: [Token]
toks') -> (QueryableStyleSheet' s p
self { store :: s
store = QueryableStyleSheet' s p -> s
forall store parser. QueryableStyleSheet' store parser -> store
store QueryableStyleSheet' s p
self', layers :: Tree
layers = Tree
layers' }, [Token]
toks')
            (layers' :: Tree
layers', Nothing, toks' :: [Token]
toks') -> (QueryableStyleSheet' s p
self { layers :: Tree
layers = Tree
layers' }, [Token]
toks')
    addAtRule self :: QueryableStyleSheet' s p
self _ toks :: [Token]
toks = (QueryableStyleSheet' s p
self, [Token] -> [Token]
skipAtRule [Token]
toks)

--- Reexpose cascade methods
-- | Looks up style rules matching the specified element, grouped by psuedoelement.
queryRules :: (PropertyParser p, RuleStore s) =>
    QueryableStyleSheet' s p -> Element -> HashMap Text [StyleRule']
queryRules :: QueryableStyleSheet' s p -> Element -> HashMap Text [StyleRule']
queryRules (QueryableStyleSheet' store' :: s
store' _ _ _ _) = s -> Element -> HashMap Text [StyleRule']
forall s. RuleStore s => s -> Element -> HashMap Text [StyleRule']
Cascade.query s
store'

-- | Selects used property values from the given style rules,
-- & populates into a new `PropertyParser` inheriting from the one given.
cascade' :: PropertyParser p => [StyleRule'] -> Props -> p -> p
cascade' :: [StyleRule'] -> Props -> p -> p
cascade' = [StyleRule'] -> Props -> p -> p
forall p. PropertyParser p => [StyleRule'] -> Props -> p -> p
Cascade.cascade

-- | Facade over `queryRules` & `cascade'`.
-- Instead of exposing pseudoelements to callers it exposes pseudoelements to
-- the `PropertyParser` implementation.
cascade :: PropertyParser p => QueryableStyleSheet p -> Element -> Props -> p -> p
cascade :: QueryableStyleSheet p -> Element -> Props -> p -> p
cascade self :: QueryableStyleSheet p
self el :: Element
el props :: Props
props style :: p
style = (p -> Text -> [StyleRule'] -> p)
-> p -> HashMap Text [StyleRule'] -> p
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
HM.foldlWithKey' p -> Text -> [StyleRule'] -> p
forall p. PropertyParser p => p -> Text -> [StyleRule'] -> p
applyPseudoEl ([StyleRule'] -> Props -> p -> p
forall p. PropertyParser p => [StyleRule'] -> Props -> p -> p
cascade' (
        [StyleRule'] -> Text -> HashMap Text [StyleRule'] -> [StyleRule']
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
lookupDefault [] "" HashMap Text [StyleRule']
rules) Props
props p
style) HashMap Text [StyleRule']
rules
  where
    rules :: HashMap Text [StyleRule']
rules = QueryableStyleSheet p -> Element -> HashMap Text [StyleRule']
forall p s.
(PropertyParser p, RuleStore s) =>
QueryableStyleSheet' s p -> Element -> HashMap Text [StyleRule']
queryRules QueryableStyleSheet p
self Element
el
    applyPseudoEl :: PropertyParser p => p -> Text -> [StyleRule'] -> p
    applyPseudoEl :: p -> Text -> [StyleRule'] -> p
applyPseudoEl self' :: p
self' "" _ = p
self'
    applyPseudoEl self' :: p
self' pseudo :: Text
pseudo props' :: [StyleRule']
props' = p -> Text -> (p -> Maybe p -> p) -> p
forall a. PropertyParser a => a -> Text -> (a -> Maybe a -> a) -> a
pseudoEl p
self' Text
pseudo p -> Maybe p -> p
forall a. PropertyParser a => a -> Maybe a -> a
cb
        where cb :: a -> Maybe a -> a
cb parent' :: a
parent' base' :: Maybe a
base' = [StyleRule'] -> Props -> a -> a -> a
forall p. PropertyParser p => [StyleRule'] -> Props -> p -> p -> p
Cascade.cascadeWithParent [StyleRule']
props' [] a
parent' (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$
                                    a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (a -> a
forall a. PropertyParser a => a -> a
inherit a
parent') Maybe a
base'

--- Verify syntax during parsing, so invalid properties don't interfere with cascade.
data PropertyExpander parser inner = PropertyExpander parser inner
instance (PropertyParser parser, RuleStore inner) => RuleStore (PropertyExpander parser inner) where
    new :: PropertyExpander parser inner
new = parser -> inner -> PropertyExpander parser inner
forall parser inner.
parser -> inner -> PropertyExpander parser inner
PropertyExpander parser
forall a. PropertyParser a => a
temp inner
forall a. RuleStore a => a
new
    addStyleRule :: PropertyExpander parser inner
-> [Int] -> StyleRule' -> PropertyExpander parser inner
addStyleRule (PropertyExpander parser' :: parser
parser' inner' :: inner
inner') priority' :: [Int]
priority' rule :: StyleRule'
rule =
        parser -> inner -> PropertyExpander parser inner
forall parser inner.
parser -> inner -> PropertyExpander parser inner
PropertyExpander parser
parser' (inner -> PropertyExpander parser inner)
-> inner -> PropertyExpander parser inner
forall a b. (a -> b) -> a -> b
$ inner -> [Int] -> StyleRule' -> inner
forall a. RuleStore a => a -> [Int] -> StyleRule' -> a
addStyleRule inner
inner' [Int]
priority' (StyleRule' -> inner) -> StyleRule' -> inner
forall a b. (a -> b) -> a -> b
$ parser -> StyleRule' -> StyleRule'
forall t. PropertyParser t => t -> StyleRule' -> StyleRule'
expandRule parser
parser' StyleRule'
rule
    lookupRules :: PropertyExpander parser inner -> Element -> [StyleRule']
lookupRules (PropertyExpander _ inner' :: inner
inner') el :: Element
el = inner -> Element -> [StyleRule']
forall a. RuleStore a => a -> Element -> [StyleRule']
lookupRules inner
inner' Element
el

expandRule :: PropertyParser t => t -> StyleRule' -> StyleRule'
expandRule :: t -> StyleRule' -> StyleRule'
expandRule parser' :: t
parser' rule :: StyleRule'
rule = StyleRule'
rule {inner :: StyleRule
inner = Selector -> Props -> Text -> StyleRule
StyleRule Selector
sel (t -> Props -> Props
forall t. PropertyParser t => t -> Props -> Props
expandProperties t
parser' Props
props) Text
psuedo}
    where (StyleRule sel :: Selector
sel props :: Props
props psuedo :: Text
psuedo) = StyleRule' -> StyleRule
inner StyleRule'
rule
expandProperties :: PropertyParser t => t -> [(Text, [Token])] -> [(Text, [Token])]
expandProperties :: t -> Props -> Props
expandProperties parser' :: t
parser' ((key :: Text
key, value :: [Token]
value):props :: Props
props) =
        t -> Text -> [Token] -> Props
forall a. PropertyParser a => a -> Text -> [Token] -> Props
shorthand t
parser' Text
key [Token]
value Props -> Props -> Props
forall a. [a] -> [a] -> [a]
++ t -> Props -> Props
forall t. PropertyParser t => t -> Props -> Props
expandProperties t
parser' Props
props
expandProperties _ [] = []

--------
---- var()
--------
-- | `PropertyParser` that lowers var() calls before forwarding to another.
data VarParser a = VarParser {VarParser a -> Props
vars :: Props, VarParser a -> a
innerParser :: a}

instance PropertyParser p => PropertyParser (VarParser p) where
    temp :: VarParser p
temp = Props -> p -> VarParser p
forall a. Props -> a -> VarParser a
VarParser [] p
forall a. PropertyParser a => a
temp
    inherit :: VarParser p -> VarParser p
inherit (VarParser vars' :: Props
vars' self :: p
self) = Props -> p -> VarParser p
forall a. Props -> a -> VarParser a
VarParser Props
vars' (p -> VarParser p) -> p -> VarParser p
forall a b. (a -> b) -> a -> b
$ p -> p
forall a. PropertyParser a => a -> a
inherit p
self
    priority :: VarParser p -> [Text]
priority (VarParser _ self :: p
self) = p -> [Text]
forall a. PropertyParser a => a -> [Text]
priority p
self

    shorthand :: VarParser p -> Text -> [Token] -> Props
shorthand self :: VarParser p
self name' :: Text
name' value :: [Token]
value
        | Text -> Token
Function "var" Token -> [Token] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Token]
value Bool -> Bool -> Bool
|| "--" Text -> Text -> Bool
`isPrefixOf` Text
name' = [(Text
name', [Token]
value)] -- Fail during inheritance...
        | Bool
otherwise = p -> Text -> [Token] -> Props
forall a. PropertyParser a => a -> Text -> [Token] -> Props
shorthand (VarParser p -> p
forall a. VarParser a -> a
innerParser VarParser p
self) Text
name' [Token]
value
    longhand :: VarParser p
-> VarParser p -> Text -> [Token] -> Maybe (VarParser p)
longhand parent' :: VarParser p
parent' self :: VarParser p
self@(VarParser vars' :: Props
vars' inner' :: p
inner') name' :: Text
name' value :: [Token]
value
        | Text -> Token
Function "var" Token -> [Token] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Token]
value = [Token] -> HashMap Text [Token] -> Maybe [Token]
resolveVars [Token]
value (Props -> HashMap Text [Token]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList Props
vars') Maybe [Token]
-> ([Token] -> Maybe (VarParser p)) -> Maybe (VarParser p)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= VarParser p
-> VarParser p -> Text -> [Token] -> Maybe (VarParser p)
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand VarParser p
parent' VarParser p
self Text
name'
        | Bool
otherwise = Props -> p -> VarParser p
forall a. Props -> a -> VarParser a
VarParser Props
vars' (p -> VarParser p) -> Maybe p -> Maybe (VarParser p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p -> p -> Text -> [Token] -> Maybe p
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand (VarParser p -> p
forall a. VarParser a -> a
innerParser VarParser p
parent') p
inner' Text
name' [Token]
value

    getVars :: VarParser p -> Props
getVars = VarParser p -> Props
forall a. VarParser a -> Props
vars
    setVars :: Props -> VarParser p -> VarParser p
setVars v :: Props
v self :: VarParser p
self = VarParser p
self {vars :: Props
vars = Props
v}

resolveVars :: [Token] -> HashMap Text [Token] -> Maybe [Token]
resolveVars :: [Token] -> HashMap Text [Token] -> Maybe [Token]
resolveVars (Function "var":Ident var :: Text
var:RightParen:toks :: [Token]
toks) ctxt :: HashMap Text [Token]
ctxt = ([Token] -> Text -> HashMap Text [Token] -> [Token]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
lookupDefault [] Text
var HashMap Text [Token]
ctxt [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++) ([Token] -> [Token]) -> Maybe [Token] -> Maybe [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token] -> HashMap Text [Token] -> Maybe [Token]
resolveVars [Token]
toks HashMap Text [Token]
ctxt
resolveVars (Function "var":Ident var :: Text
var:Comma:toks :: [Token]
toks) ctxt :: HashMap Text [Token]
ctxt
    | Just i :: Int
i <- Token
RightParen Token -> [Token] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Token]
toks, (fallback :: [Token]
fallback, RightParen:toks' :: [Token]
toks') <- Int
i Int -> [Token] -> ([Token], [Token])
forall a. Int -> [a] -> ([a], [a])
`splitAt` [Token]
toks =
        ([Token] -> Text -> HashMap Text [Token] -> [Token]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
lookupDefault [Token]
fallback Text
var HashMap Text [Token]
ctxt [Token] -> [Token] -> [Token]
forall a. [a] -> [a] -> [a]
++) ([Token] -> [Token]) -> Maybe [Token] -> Maybe [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token] -> HashMap Text [Token] -> Maybe [Token]
resolveVars [Token]
toks' HashMap Text [Token]
ctxt
resolveVars (Function "var":_) _ = Maybe [Token]
forall a. Maybe a
Nothing
resolveVars (tok :: Token
tok:toks :: [Token]
toks) ctxt :: HashMap Text [Token]
ctxt = (Token
tokToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:) ([Token] -> [Token]) -> Maybe [Token] -> Maybe [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token] -> HashMap Text [Token] -> Maybe [Token]
resolveVars [Token]
toks HashMap Text [Token]
ctxt
resolveVars [] _ = [Token] -> Maybe [Token]
forall a. a -> Maybe a
Just []