{-# LANGUAGE OverloadedStrings #-}
module Stylist(cssPriorityAgent, cssPriorityUser, cssPriorityAuthor,
    PropertyParser(..), TrivialPropertyParser(..),
    StyleSheet(..), TrivialStyleSheet(..), Props,
    Element(..), Attribute(..),
    elementPath, compileAttrTest, matched, attrTest, hasWord, hasLang,
    parseUnorderedShorthand, parseUnorderedShorthand', parseOperands) where

import Data.Text (Text, unpack)
import Data.CSS.Syntax.Tokens (Token(..))
import Data.List

import Stylist.Parse (StyleSheet(..), TrivialStyleSheet(..), scanBlock)
import Stylist.Parse.Selector

-- | Set the priority for a CSS stylesheet being parsed.
cssPriorityAgent, cssPriorityUser, cssPriorityAuthor :: StyleSheet s => s -> s
cssPriorityAgent :: forall s. StyleSheet s => s -> s
cssPriorityAgent = Int -> s -> s
forall s. StyleSheet s => Int -> s -> s
setPriority Int
1
cssPriorityUser :: forall s. StyleSheet s => s -> s
cssPriorityUser = Int -> s -> s
forall s. StyleSheet s => Int -> s -> s
setPriority Int
2
cssPriorityAuthor :: forall s. StyleSheet s => s -> s
cssPriorityAuthor = Int -> s -> s
forall s. StyleSheet s => Int -> s -> s
setPriority Int
3

-- | Defines how to parse CSS properties into an output "style" format.
class PropertyParser a where
    -- | Default styles.
    temp :: a
    -- | Creates a style inherited from a parent style.
    inherit :: a -> a
    inherit = a -> a
forall a. a -> a
id

    priority :: a -> [Text]
    priority a
_ = []

    -- | Expand a shorthand property into longhand properties.
    shorthand :: a -> Text -> [Token] -> [(Text, [Token])]
    shorthand a
self Text
key [Token]
value | Just a
_ <- a -> a -> Text -> [Token] -> Maybe a
forall a. PropertyParser a => a -> a -> Text -> [Token] -> Maybe a
longhand a
self a
self Text
key [Token]
value = [(Text
key, [Token]
value)]
        | Bool
otherwise = []
    -- | Mutates self to store the given CSS property, if it's syntax is valid.
    -- longhand parent self name value
    longhand :: a -> a -> Text -> [Token] -> Maybe a

    -- | Retrieve stored variables, optional.
    getVars :: a -> Props
    getVars a
_ = []
    -- | Save variable values, optional.
    setVars :: Props -> a -> a
    setVars [(Text, [Token])]
_ = a -> a
forall a. a -> a
id

    -- | Mutates self to store the given pseudoelement styles,
    -- passing a callback so you can alter the parent &
    -- (for interactive pseudoclasses) base styles.
    pseudoEl :: a -> Text -> (a -> Maybe a -> a) -> a
    pseudoEl a
self Text
_ a -> Maybe a -> a
_ = a
self

-- | "key: value;" entries to be parsed into an output type.
type Props = [(Text, [Token])]

-- | Gathers properties as a key'd list.
-- Works well with `lookup`.
data TrivialPropertyParser = TrivialPropertyParser [(String, [Token])] deriving (Int -> TrivialPropertyParser -> ShowS
[TrivialPropertyParser] -> ShowS
TrivialPropertyParser -> [Char]
(Int -> TrivialPropertyParser -> ShowS)
-> (TrivialPropertyParser -> [Char])
-> ([TrivialPropertyParser] -> ShowS)
-> Show TrivialPropertyParser
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TrivialPropertyParser -> ShowS
showsPrec :: Int -> TrivialPropertyParser -> ShowS
$cshow :: TrivialPropertyParser -> [Char]
show :: TrivialPropertyParser -> [Char]
$cshowList :: [TrivialPropertyParser] -> ShowS
showList :: [TrivialPropertyParser] -> ShowS
Show, TrivialPropertyParser -> TrivialPropertyParser -> Bool
(TrivialPropertyParser -> TrivialPropertyParser -> Bool)
-> (TrivialPropertyParser -> TrivialPropertyParser -> Bool)
-> Eq TrivialPropertyParser
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TrivialPropertyParser -> TrivialPropertyParser -> Bool
== :: TrivialPropertyParser -> TrivialPropertyParser -> Bool
$c/= :: TrivialPropertyParser -> TrivialPropertyParser -> Bool
/= :: TrivialPropertyParser -> TrivialPropertyParser -> Bool
Eq)
instance PropertyParser TrivialPropertyParser where
    temp :: TrivialPropertyParser
temp = [([Char], [Token])] -> TrivialPropertyParser
TrivialPropertyParser []
    longhand :: TrivialPropertyParser
-> TrivialPropertyParser
-> Text
-> [Token]
-> Maybe TrivialPropertyParser
longhand TrivialPropertyParser
_ (TrivialPropertyParser [([Char], [Token])]
self) Text
key [Token]
value =
        TrivialPropertyParser -> Maybe TrivialPropertyParser
forall a. a -> Maybe a
Just (TrivialPropertyParser -> Maybe TrivialPropertyParser)
-> TrivialPropertyParser -> Maybe TrivialPropertyParser
forall a b. (a -> b) -> a -> b
$ [([Char], [Token])] -> TrivialPropertyParser
TrivialPropertyParser ((Text -> [Char]
unpack Text
key, [Token]
value)([Char], [Token]) -> [([Char], [Token])] -> [([Char], [Token])]
forall a. a -> [a] -> [a]
:[([Char], [Token])]
self)

-- | An inversely-linked tree of elements, to apply CSS selectors to.
data Element = ElementNode {
    -- | The element's parent in the tree.
    Element -> Maybe Element
parent :: Maybe Element,
    -- | The element's previous sibling in the tree.
    Element -> Maybe Element
previous :: Maybe Element,
    -- | The element's name.
    Element -> Text
name :: Text,
    -- | The element's namespace.
    Element -> Text
namespace :: Text,
    -- | The element's attributes, in sorted order.
    Element -> [Attribute]
attributes :: [Attribute]
}
-- | A key-value attribute.
data Attribute = Attribute Text Text String deriving (Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
/= :: Attribute -> Attribute -> Bool
Eq, Eq Attribute
Eq Attribute
-> (Attribute -> Attribute -> Ordering)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Attribute)
-> (Attribute -> Attribute -> Attribute)
-> Ord Attribute
Attribute -> Attribute -> Bool
Attribute -> Attribute -> Ordering
Attribute -> Attribute -> Attribute
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Attribute -> Attribute -> Ordering
compare :: Attribute -> Attribute -> Ordering
$c< :: Attribute -> Attribute -> Bool
< :: Attribute -> Attribute -> Bool
$c<= :: Attribute -> Attribute -> Bool
<= :: Attribute -> Attribute -> Bool
$c> :: Attribute -> Attribute -> Bool
> :: Attribute -> Attribute -> Bool
$c>= :: Attribute -> Attribute -> Bool
>= :: Attribute -> Attribute -> Bool
$cmax :: Attribute -> Attribute -> Attribute
max :: Attribute -> Attribute -> Attribute
$cmin :: Attribute -> Attribute -> Attribute
min :: Attribute -> Attribute -> Attribute
Ord)

-- | Computes the child indices to traverse to reach the given element.
elementPath :: Element -> [Int]
elementPath :: Element -> [Int]
elementPath = [Int] -> Element -> [Int]
forall {a}. (Enum a, Num a) => [a] -> Element -> [a]
elementPath' []
-- | Variant of `elementPath` with a prefix path.
elementPath' :: [a] -> Element -> [a]
elementPath' [a]
path ElementNode { parent :: Element -> Maybe Element
parent = Just Element
parent', previous :: Element -> Maybe Element
previous = Maybe Element
prev } =
    [a] -> Element -> [a]
elementPath' (a -> a
forall a. Enum a => a -> a
succ (Maybe Element -> a
forall {a}. (Enum a, Num a) => Maybe Element -> a
countSib Maybe Element
prev) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
path) Element
parent'
elementPath' [a]
path ElementNode { parent :: Element -> Maybe Element
parent = Maybe Element
Nothing, previous :: Element -> Maybe Element
previous = Maybe Element
prev } =
    (a -> a
forall a. Enum a => a -> a
succ (Maybe Element -> a
forall {a}. (Enum a, Num a) => Maybe Element -> a
countSib Maybe Element
prev) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
path)
-- | How many previous children does this element have?
countSib :: Maybe Element -> a
countSib (Just (ElementNode { previous :: Element -> Maybe Element
previous = Maybe Element
prev })) = a -> a
forall a. Enum a => a -> a
succ (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ Maybe Element -> a
countSib Maybe Element
prev
countSib Maybe Element
Nothing = a
0

-- | Converts a property text into a callback testing against a string.
compileAttrTest :: PropertyTest -> String -> Bool
compileAttrTest :: PropertyTest -> [Char] -> Bool
compileAttrTest PropertyTest
Exists = [Char] -> Bool
forall t. t -> Bool
matched
compileAttrTest (Equals Text
val) = ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> [Char]
unpack Text
val))
compileAttrTest (Suffix Text
val) = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf ([Char] -> [Char] -> Bool) -> [Char] -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
val
compileAttrTest (Prefix Text
val) = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf ([Char] -> [Char] -> Bool) -> [Char] -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
val
compileAttrTest (Substring Text
val) = [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf ([Char] -> [Char] -> Bool) -> [Char] -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
val
compileAttrTest (Include Text
val) = [Char] -> [Char] -> Bool
hasWord ([Char] -> [Char] -> Bool) -> [Char] -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
val
compileAttrTest (Dash Text
val) = [Char] -> [Char] -> Bool
hasLang ([Char] -> [Char] -> Bool) -> [Char] -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
unpack Text
val
compileAttrTest (Callback (PropertyFunc [Char] -> Bool
cb)) = [Char] -> Bool
cb

-- | returns True regardless of value.
matched :: t -> Bool
matched :: forall t. t -> Bool
matched t
_ = Bool
True
-- | Tests the given word is in the whitespace-seperated value.
hasWord :: String -> String -> Bool
hasWord :: [Char] -> [Char] -> Bool
hasWord [Char]
expected [Char]
value = [Char]
expected [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char] -> [[Char]]
words [Char]
value
-- | Tests whether the attribute holds the expected value or a sub-locale.
hasLang :: [Char] -> [Char] -> Bool
hasLang :: [Char] -> [Char] -> Bool
hasLang [Char]
expected [Char]
value = [Char]
expected [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
value Bool -> Bool -> Bool
|| [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf ([Char]
expected [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-") [Char]
value

-- | Test whether the element matches a parsed property test, for the given attribute.
attrTest :: Maybe Text -> Text -> PropertyTest -> Element -> Bool
attrTest :: Maybe Text -> Text -> PropertyTest -> Element -> Bool
attrTest Maybe Text
namespace Text
name PropertyTest
test ElementNode { attributes :: Element -> [Attribute]
attributes = [Attribute]
attrs } = (Attribute -> Bool) -> [Attribute] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Attribute -> Bool
predicate [Attribute]
attrs
    where
        predicate :: Attribute -> Bool
predicate attr :: Attribute
attr@(Attribute Text
ns' Text
_ [Char]
_) | Just Text
ns <- Maybe Text
namespace = Text
ns Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
ns' Bool -> Bool -> Bool
&& Attribute -> Bool
predicate' Attribute
attr
            | Bool
otherwise = Attribute -> Bool
predicate' Attribute
attr
        predicate' :: Attribute -> Bool
predicate' (Attribute Text
_ Text
name' [Char]
value') = Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name' Bool -> Bool -> Bool
&& PropertyTest -> [Char] -> Bool
compileAttrTest PropertyTest
test [Char]
value'

-- | Utility for parsing shorthand attributes which don't care in which order the
-- subproperties are specified.
-- Each property must parse only a single function or token.
parseUnorderedShorthand :: PropertyParser a =>
        a -> [Text] -> [Token] -> [(Text, [Token])]
parseUnorderedShorthand :: forall a.
PropertyParser a =>
a -> [Text] -> [Token] -> [(Text, [Token])]
parseUnorderedShorthand a
self [Text]
properties [Token]
toks
    | Just [Token]
_ <- Text -> [(Text, [Token])] -> Maybe [Token]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"" [(Text, [Token])]
ret = [] -- Error recovery!
    | Bool
otherwise = [(Text, [Token])]
ret
  where
    ret :: [(Text, [Token])]
ret = a -> [Text] -> [[Token]] -> [(Text, [Token])]
forall a.
PropertyParser a =>
a -> [Text] -> [[Token]] -> [(Text, [Token])]
parseUnorderedShorthand' a
self [Text]
properties ([[Token]] -> [(Text, [Token])]) -> [[Token]] -> [(Text, [Token])]
forall a b. (a -> b) -> a -> b
$ [Token] -> [[Token]]
parseOperands [Token]
toks
-- | Variant of `parseUnorderedShorthand` taking pre-split list.
parseUnorderedShorthand' :: PropertyParser a =>
        a -> [Text] -> [[Token]] -> [(Text, [Token])]
parseUnorderedShorthand' :: forall a.
PropertyParser a =>
a -> [Text] -> [[Token]] -> [(Text, [Token])]
parseUnorderedShorthand' a
self [Text]
properties ([Token]
arg:[[Token]]
args) = [Text] -> [Text] -> [(Text, [Token])]
inner [Text]
properties []
  where
    inner :: [Text] -> [Text] -> [(Text, [Token])]
inner (Text
prop:[Text]
props) [Text]
props'
        | entry :: [(Text, [Token])]
entry@((Text, [Token])
_:[(Text, [Token])]
_) <- a -> Text -> [Token] -> [(Text, [Token])]
forall a.
PropertyParser a =>
a -> Text -> [Token] -> [(Text, [Token])]
shorthand a
self Text
prop [Token]
arg =
            [(Text, [Token])]
entry [(Text, [Token])] -> [(Text, [Token])] -> [(Text, [Token])]
forall a. [a] -> [a] -> [a]
++ a -> [Text] -> [[Token]] -> [(Text, [Token])]
forall a.
PropertyParser a =>
a -> [Text] -> [[Token]] -> [(Text, [Token])]
parseUnorderedShorthand' a
self ([Text]
props' [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
props) [[Token]]
args
        | Bool
otherwise = [Text] -> [Text] -> [(Text, [Token])]
inner [Text]
props (Text
propText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
props')
    inner [] [Text]
_ = [(Text
"", [])] -- Error caught & handled by public API.
parseUnorderedShorthand' a
self (Text
prop:[Text]
props) [] = -- Shorthands have long effects!
    (Text
prop, [Text -> Token
Ident Text
"initial"])(Text, [Token]) -> [(Text, [Token])] -> [(Text, [Token])]
forall a. a -> [a] -> [a]
:a -> [Text] -> [[Token]] -> [(Text, [Token])]
forall a.
PropertyParser a =>
a -> [Text] -> [[Token]] -> [(Text, [Token])]
parseUnorderedShorthand' a
self [Text]
props []
parseUnorderedShorthand' a
_ [] [] = []

-- | Splits a token list so each function is it's own list.
-- Other tokens are split into their own singletons.
parseOperands :: [Token] -> [[Token]]
parseOperands :: [Token] -> [[Token]]
parseOperands (Function Text
name:[Token]
toks) = let ([Token]
args, [Token]
toks') = Parser [Token]
scanBlock [Token]
toks
    in (Text -> Token
Function Text
nameToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
args)[Token] -> [[Token]] -> [[Token]]
forall a. a -> [a] -> [a]
:[Token] -> [[Token]]
parseOperands [Token]
toks'
parseOperands (Token
tok:[Token]
toks) = [Token
tok][Token] -> [[Token]] -> [[Token]]
forall a. a -> [a] -> [a]
:[Token] -> [[Token]]
parseOperands [Token]
toks
parseOperands [] = []