{-# 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 = setPriority 1
cssPriorityUser = setPriority 2
cssPriorityAuthor = 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 = id

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

    -- | Expand a shorthand property into longhand properties.
    shorthand :: a -> Text -> [Token] -> [(Text, [Token])]
    shorthand self key value | Just _ <- longhand self self key value = [(key, value)]
        | 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 _ = 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 _ _ = 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 (Show, Eq)
instance PropertyParser TrivialPropertyParser where
    temp = TrivialPropertyParser []
    longhand _ (TrivialPropertyParser self) key value =
        Just $ TrivialPropertyParser ((unpack key, value):self)

-- | An inversely-linked tree of elements, to apply CSS selectors to.
data Element = ElementNode {
    -- | The element's parent in the tree.
    parent :: Maybe Element,
    -- | The element's previous sibling in the tree.
    previous :: Maybe Element,
    -- | The element's name.
    name :: Text,
    -- | The element's namespace.
    namespace :: Text,
    -- | The element's attributes, in sorted order.
    attributes :: [Attribute]
}
-- | A key-value attribute.
data Attribute = Attribute Text Text String deriving (Eq, Ord)

elementPath :: Element -> [Int]
elementPath = elementPath' []
elementPath' path ElementNode { parent = Just parent', previous = prev } =
    elementPath' (succ (countSib prev) : path) parent'
elementPath' path ElementNode { parent = Nothing, previous = prev } =
    (succ (countSib prev) : path)
countSib (Just (ElementNode { previous = prev })) = succ $ countSib prev
countSib Nothing = 0

compileAttrTest :: PropertyTest -> String -> Bool
compileAttrTest Exists = matched
compileAttrTest (Equals val) = (== (unpack val))
compileAttrTest (Suffix val) = isSuffixOf $ unpack val
compileAttrTest (Prefix val) = isPrefixOf $ unpack val
compileAttrTest (Substring val) = isInfixOf $ unpack val
compileAttrTest (Include val) = hasWord $ unpack val
compileAttrTest (Dash val) = hasLang $ unpack val
compileAttrTest (Callback (PropertyFunc cb)) = cb

matched :: t -> Bool
matched _ = True
hasWord :: String -> String -> Bool
hasWord expected value = expected `elem` words value
hasLang :: [Char] -> [Char] -> Bool
hasLang expected value = expected == value || isPrefixOf (expected ++ "-") value

attrTest :: Maybe Text -> Text -> PropertyTest -> Element -> Bool
attrTest namespace name test ElementNode { attributes = attrs } = any predicate attrs
    where
        predicate attr@(Attribute ns' _ _) | Just ns <- namespace = ns == ns' && predicate' attr
            | otherwise = predicate' attr
        predicate' (Attribute _ name' value') = name == name' && compileAttrTest test value'

parseUnorderedShorthand :: PropertyParser a =>
        a -> [Text] -> [Token] -> [(Text, [Token])]
parseUnorderedShorthand self properties toks
    | Just _ <- lookup "" ret = [] -- Error recovery!
    | otherwise = ret
  where
    ret = parseUnorderedShorthand' self properties $ parseOperands toks
parseUnorderedShorthand' :: PropertyParser a =>
        a -> [Text] -> [[Token]] -> [(Text, [Token])]
parseUnorderedShorthand' self properties (arg:args) = inner properties []
  where
    inner (prop:props) props'
        | Just _ <- longhand self self prop arg =
            parseUnorderedShorthand' self (props' ++ props) args
        | otherwise = inner props (prop:props')
    inner [] _ = [("", [])] -- Error caught & handled by public API.
parseUnorderedShorthand' self (prop:props) [] = -- Shorthands have long effects!
    (prop, [Ident "initial"]):parseUnorderedShorthand' self props []
parseUnorderedShorthand' _ [] [] = []

parseOperands :: [Token] -> [[Token]]
parseOperands (Function name:toks) = let (args, toks') = scanBlock toks
    in (Function name:args):parseOperands toks'
parseOperands (tok:toks) = [tok]:parseOperands toks
parseOperands [] = []