{-# 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 Data.Text (isPrefixOf)
import Data.List (elemIndex)

-- | 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.
    forall store parser. QueryableStyleSheet' store parser -> store
store :: store,
    -- | The "PropertyParser" to use for property syntax validation.
    forall store parser. 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.
    forall store parser. QueryableStyleSheet' store parser -> [Int]
priority :: [Int], -- author vs user agent vs user styles, incorporates Cascade Layers
    -- | Parse data for @layer, to give webdevs explicit control over the cascade.
    forall store parser. QueryableStyleSheet' store parser -> Tree
layers :: AtLayer.Tree,
    --- | The name of the @layer we're within.
    forall store parser. QueryableStyleSheet' store parser -> [Text]
layerNamespace :: [Text]
}

-- | Constructs an empty QueryableStyleSheet'.
queryableStyleSheet :: PropertyParser p => QueryableStyleSheet p
queryableStyleSheet :: forall p. PropertyParser p => 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,
    priority :: [Int]
priority = [Int
0], layerNamespace :: [Text]
layerNamespace = [] }

instance (RuleStore s, PropertyParser p) => StyleSheet (QueryableStyleSheet' s p) where
    setPriorities :: [Int] -> QueryableStyleSheet' s p -> QueryableStyleSheet' s p
setPriorities [Int]
vs QueryableStyleSheet' s p
self = QueryableStyleSheet' s p
self { priority :: [Int]
priority = [Int]
vs }
    addRule :: QueryableStyleSheet' s p -> StyleRule -> QueryableStyleSheet' s p
addRule self :: QueryableStyleSheet' s p
self@(QueryableStyleSheet' s
store' p
_ [Int]
priority' Tree
_ [Text]
_) 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_, priority :: forall store parser. QueryableStyleSheet' store parser -> [Int]
priority = Int
v:[Int]
_ }
            Text
"layer" [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
$ \[Text]
ns' [Int]
path -> QueryableStyleSheet' s p
self {
            priority :: [Int]
priority = Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
path, layerNamespace :: [Text]
layerNamespace = [Text]
ns'
        } of
            (Tree
layers', Just QueryableStyleSheet' s p
self', [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')
            (Tree
layers', Maybe (QueryableStyleSheet' s p)
Nothing, [Token]
toks') -> (QueryableStyleSheet' s p
self { layers :: Tree
layers = Tree
layers' }, [Token]
toks')
    addAtRule QueryableStyleSheet' s p
self Text
_ [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 :: forall p s.
(PropertyParser p, RuleStore s) =>
QueryableStyleSheet' s p -> Element -> HashMap Text [StyleRule']
queryRules (QueryableStyleSheet' s
store' p
_ [Int]
_ Tree
_ [Text]
_) = 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' :: forall p. PropertyParser p => [StyleRule'] -> Props -> p -> p
cascade' = [StyleRule'] -> Props -> p -> p
forall p. PropertyParser p => [StyleRule'] -> Props -> p -> p
Cascade.cascade

-- | Facade over `queryRules` & `cascade'` for simple cases you don't care about psuedoelements.
cascade :: PropertyParser p => QueryableStyleSheet p -> Element -> Props -> p -> p
cascade :: forall p.
PropertyParser p =>
QueryableStyleSheet p -> Element -> Props -> p -> p
cascade QueryableStyleSheet p
self Element
el = [StyleRule'] -> Props -> p -> p
forall p. PropertyParser p => [StyleRule'] -> Props -> p -> p
cascade' ([StyleRule'] -> Props -> p -> p)
-> [StyleRule'] -> Props -> p -> p
forall a b. (a -> b) -> a -> b
$ [StyleRule'] -> Text -> HashMap Text [StyleRule'] -> [StyleRule']
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
lookupDefault [] Text
"" (HashMap Text [StyleRule'] -> [StyleRule'])
-> HashMap Text [StyleRule'] -> [StyleRule']
forall a b. (a -> b) -> a -> b
$ 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

--- 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' inner
inner') [Int]
priority' 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 parser
_ inner
inner') Element
el = inner -> Element -> [StyleRule']
forall a. RuleStore a => a -> Element -> [StyleRule']
lookupRules inner
inner' Element
el

expandRule :: PropertyParser t => t -> StyleRule' -> StyleRule'
expandRule :: forall t. PropertyParser t => t -> StyleRule' -> StyleRule'
expandRule t
parser' 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 Selector
sel Props
props Text
psuedo) = StyleRule' -> StyleRule
inner StyleRule'
rule
expandProperties :: PropertyParser t => t -> [(Text, [Token])] -> [(Text, [Token])]
expandProperties :: forall t. PropertyParser t => t -> Props -> Props
expandProperties t
parser' ((Text
key, [Token]
value):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 t
_ [] = []

--------
---- var()
--------
-- | `PropertyParser` that lowers var() calls before forwarding to another.
data VarParser a = VarParser {forall a. VarParser a -> Props
vars :: Props, forall a. 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 Props
vars' 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

    shorthand :: VarParser p -> Text -> [Token] -> Props
shorthand VarParser p
self Text
name' [Token]
value
        | Text -> Token
Function Text
"var" Token -> [Token] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Token]
value Bool -> Bool -> Bool
|| Text
"--" 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 VarParser p
parent' self :: VarParser p
self@(VarParser Props
vars' p
inner') Text
name' [Token]
value
        | Text -> Token
Function Text
"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 Props
v 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 Text
"var":Ident Text
var:Token
RightParen:[Token]
toks) 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 Text
"var":Ident Text
var:Token
Comma:[Token]
toks) HashMap Text [Token]
ctxt
    | Just Int
i <- Token
RightParen Token -> [Token] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Token]
toks, ([Token]
fallback, Token
RightParen:[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 Text
"var":[Token]
_) HashMap Text [Token]
_ = Maybe [Token]
forall a. Maybe a
Nothing
resolveVars (Token
tok:[Token]
toks) 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 [] HashMap Text [Token]
_ = [Token] -> Maybe [Token]
forall a. a -> Maybe a
Just []