{-# 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 :: s -> s
cssPriorityAgent = Int -> s -> s
forall s. StyleSheet s => Int -> s -> s
setPriority 1
cssPriorityUser :: s -> s
cssPriorityUser = Int -> s -> s
forall s. StyleSheet s => Int -> s -> s
setPriority 2
cssPriorityAuthor :: s -> s
cssPriorityAuthor = Int -> s -> s
forall s. StyleSheet s => Int -> s -> s
setPriority 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 _ = []

    -- | Expand a shorthand property into longhand properties.
    shorthand :: a -> Text -> [Token] -> [(Text, [Token])]
    shorthand self :: a
self key :: Text
key value :: [Token]
value | Just _ <- 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 _ = []
    -- | Save variable values, optional.
    setVars :: Props -> a -> a
    setVars _ = 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 self :: a
self _ _ = 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 -> 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 = [(String, [Token])] -> TrivialPropertyParser
TrivialPropertyParser []
    longhand :: TrivialPropertyParser
-> TrivialPropertyParser
-> Text
-> [Token]
-> Maybe TrivialPropertyParser
longhand _ (TrivialPropertyParser self :: [(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
$ [(String, [Token])] -> TrivialPropertyParser
TrivialPropertyParser ((Text -> String
unpack Text
key, [Token]
value)(String, [Token]) -> [(String, [Token])] -> [(String, [Token])]
forall a. a -> [a] -> [a]
:[(String, [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
/= :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c== :: 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
min :: Attribute -> Attribute -> Attribute
$cmin :: Attribute -> Attribute -> Attribute
max :: Attribute -> Attribute -> Attribute
$cmax :: Attribute -> Attribute -> Attribute
>= :: Attribute -> Attribute -> Bool
$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
compare :: Attribute -> Attribute -> Ordering
$ccompare :: Attribute -> Attribute -> Ordering
$cp1Ord :: Eq 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' path :: [a]
path ElementNode { parent :: Element -> Maybe Element
parent = Just parent' :: 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 p. (Enum p, Num p) => Maybe Element -> p
countSib Maybe Element
prev) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
path) Element
parent'
elementPath' path :: [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 p. (Enum p, Num p) => Maybe Element -> p
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 -> p
countSib (Just (ElementNode { previous :: Element -> Maybe Element
previous = Maybe Element
prev })) = p -> p
forall a. Enum a => a -> a
succ (p -> p) -> p -> p
forall a b. (a -> b) -> a -> b
$ Maybe Element -> p
countSib Maybe Element
prev
countSib Nothing = 0

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

-- | returns True regardless of value.
matched :: t -> Bool
matched :: t -> Bool
matched _ = Bool
True
-- | Tests the given word is in the whitespace-seperated value.
hasWord :: String -> String -> Bool
hasWord :: String -> String -> Bool
hasWord expected :: String
expected value :: String
value = String
expected String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String -> [String]
words String
value
-- | Tests whether the attribute holds the expected value or a sub-locale.
hasLang :: [Char] -> [Char] -> Bool
hasLang :: String -> String -> Bool
hasLang expected :: String
expected value :: String
value = String
expected String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
value Bool -> Bool -> Bool
|| String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ "-") String
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 namespace :: Maybe Text
namespace name :: Text
name test :: 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 ns' :: Text
ns' _ _) | Just ns :: 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 _ name' :: Text
name' value' :: String
value') = Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name' Bool -> Bool -> Bool
&& PropertyTest -> String -> Bool
compileAttrTest PropertyTest
test String
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 :: a -> [Text] -> [Token] -> [(Text, [Token])]
parseUnorderedShorthand self :: a
self properties :: [Text]
properties toks :: [Token]
toks
    | Just _ <- Text -> [(Text, [Token])] -> Maybe [Token]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "" [(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' :: a -> [Text] -> [[Token]] -> [(Text, [Token])]
parseUnorderedShorthand' self :: a
self properties :: [Text]
properties (arg :: [Token]
arg:args :: [[Token]]
args) = [Text] -> [Text] -> [(Text, [Token])]
inner [Text]
properties []
  where
    inner :: [Text] -> [Text] -> [(Text, [Token])]
inner (prop :: Text
prop:props :: [Text]
props) props' :: [Text]
props'
        | entry :: [(Text, [Token])]
entry@(_:_) <- 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 [] _ = [("", [])] -- Error caught & handled by public API.
parseUnorderedShorthand' self :: a
self (prop :: Text
prop:props :: [Text]
props) [] = -- Shorthands have long effects!
    (Text
prop, [Text -> Token
Ident "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' _ [] [] = []

-- | 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 name :: Text
name:toks :: [Token]
toks) = let (args :: [Token]
args, toks' :: [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 (tok :: Token
tok:toks :: [Token]
toks) = [Token
tok][Token] -> [[Token]] -> [[Token]]
forall a. a -> [a] -> [a]
:[Token] -> [[Token]]
parseOperands [Token]
toks
parseOperands [] = []