{-# LANGUAGE OverloadedStrings #-}
module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..)) where

import Stylist (PropertyParser(..), parseUnorderedShorthand)
import Data.CSS.Syntax.Tokens (Token(..))
import Data.Maybe (isJust, catMaybes)

import Graphics.Rendering.Rect.CSS.Colour (ColourPallet, parseColour)
import Data.Colour (AlphaColour, transparent)
import Graphics.Rendering.Rect.Types (Rects(..), Rect(..))

data Backgrounds = Backgrounds {
    pallet :: ColourPallet,
    background :: AlphaColour Float,
    clip :: [Rects -> Rect]
}

instance PropertyParser Backgrounds where
    temp = Backgrounds {
        pallet = temp, background = transparent, clip = [borderBox]
      }
    inherit _ = temp
    priority _ = []

    longhand _ self@Backgrounds{ pallet = c } "background-color" toks
        | Just ([], val) <- parseColour c toks = Just self { background = val }
    longhand _ self "background-clip" t | val@(_:_) <- parseCSSList inner t =
        Just self { clip = val }
      where
        inner [Ident "content-box"] = Just contentBox
        inner [Ident "padding-box"] = Just paddingBox
        inner [Ident "border-box"] = Just borderBox
        inner [Ident "initial"] = Just borderBox -- To aid shorthand implementation.
        inner _ = Nothing
    longhand _ _ _ _ = Nothing

    -- The multi-layered shorthand is one source of parsing complexity.
    shorthand self "background" t = catProps $ reverse $ parseCSSList inner t
      where
        catProps [] = []
        catProps (props:pss)
            | Just [Ident "initial"] <- "background-color" `lookup` catProps pss =
                map (catProp $ catProps pss) props
            | otherwise = [] -- Only allow background-color in bottommost layer.
        catProp _ ret@("background-color", _) = ret
        catProp bases (key, val)
            | Just base <- key `lookup` bases = (key, val ++ Comma:base)
            -- Shouldn't happen, `inner` expands all props at least to "initial"!
            | otherwise = (key, val)
        inner toks | ret@(_:_) <- parseUnorderedShorthand self [
                "background-color", "background-clip"
              ] toks = Just ret
          | otherwise = Nothing
    shorthand self key val | Just _ <- longhand self self key val = [(key, val)]
        | otherwise = []

parseCSSList cb toks | all isJust ret = catMaybes ret
    | otherwise = []
  where ret = map cb $ splitList Comma toks

------
--- Utils taken from HappStack
------

-- | Repeadly splits a list by the provided separator and collects the results
splitList :: Eq a => a -> [a] -> [[a]]
splitList _   [] = []
splitList sep list = h:splitList sep t
        where (h,t)=split (==sep) list

-- | Split is like break, but the matching element is dropped.
split :: (a -> Bool) -> [a] -> ([a], [a])
split f s = (left,right)
        where
        (left,right')=break f s
        right = if null right' then [] else tail right'