{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..),
    Pattern(..), RadialShape(..), Extent(..),
    Resize(..), Length(..), resolveSize) where

import Stylist (PropertyParser(..), parseUnorderedShorthand, parseOperands)
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Maybe (isJust, catMaybes)
import Data.Text (Text)
import Data.Scientific (scientific, toRealFloat)

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

data Backgrounds img = Backgrounds {
    pallet :: ColourPallet,
    background :: C,
    clip :: [Rects -> Rect],
    image :: [Pattern img],
    bgSize :: [Resize]
} deriving (Eq, Show, Read)

type C = AlphaColour Float

data Pattern img = None | Img img | Linear Float [(C, Length)]
    | Radial RadialShape Extent (Length, Length) [(C, Length)]
    | Conical Float (Length, Length) [(C, Length)]
    deriving (Eq, Show, Read)
data RadialShape = Circle | Ellipse deriving (Eq, Show, Read)
data Extent = Extent Length Length | ClosestCorner
    | ClosestSide | FarthestCorner | FarthestSide deriving (Eq, Show, Read)

-- We need to resolve images before we can compute the actual lengths!
data Resize = Cover | Contain | Size Length Length deriving (Eq, Show, Read)
data Length = Absolute Float | Scale Float | Auto deriving (Eq, Show, Read)

instance PropertyParser (Backgrounds Text) where
    temp = Backgrounds {
        pallet = temp, background = transparent, clip = [borderBox],
        image = [None], bgSize = [Size Auto Auto]
      }
    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 = reverse 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 _ self@Backgrounds { pallet = pp } "background-image" t
        | val@(_:_) <- parseCSSList inner t = Just self { image = reverse val }
      where
        inner [Ident "none"] = Just None
        inner [Ident "initial"] = Just None
        inner [Url ret] = Just $ Img ret
        inner [Function "url", String ret, RightParen] = Just $ Img ret
        inner (Function "linear-gradient":toks)
            | Just cs@(_:_:_)<-colourStops pp (Comma:toks) = Just $ Linear pi cs
        inner (Function "linear-gradient":Dimension _ x unit:toks)
            | Just s <- lookup unit angularUnits,
                Just cs@(_:_:_) <- colourStops pp toks = Just $ Linear (f x*s) cs
        inner (Function "linear-gradient":Ident "to":Ident a:Ident b:toks)
            | Just angle<-corner a b, Just stops@(_:_:_)<-colourStops pp toks =
                Just $ Linear angle stops
            | Just angle<-corner b a, Just stops@(_:_:_)<-colourStops pp toks =
                Just $ Linear angle stops
          where
            corner "top" "right" = Just $ 0.25*pi
            corner "bottom" "right" = Just $ 0.75*pi
            corner "bottom" "left" = Just $ 1.25*pi
            corner "top" "left" = Just $ 1.75*pi
            corner _ _ = Nothing
        inner (Function "linear-gradient":Ident "to":Ident side:toks)
            | Just angle <- lookup side [
                ("top", 0), ("right", pi/2), ("bottom", pi), ("left", pi*1.5)],
                Just cs@(_:_:_) <- colourStops pp toks = Just $ Linear angle cs
        inner (Function "radial-gradient":toks)
            | Just cs@(_:_:_) <- colourStops pp (Comma:toks) =
                Just $ Radial Ellipse FarthestCorner center cs
            | (shp, org, ext, ts) <- radArgs toks,
                Just cs@(_:_:_) <- colourStops pp ts = Just $ Radial shp ext org cs
          where
            radArgs (Ident s:Ident "at":ts) | Just shape <- radShape s,
                    Just (org, ts') <- position ts =
                (shape, org, FarthestCorner, ts')
            radArgs (Ident "at":ts) | Just (org, ts') <- position ts =
                (Ellipse, org, FarthestCorner, ts')
            radArgs (Ident "circle":Ident "at":ts)
                | Just (org, ts') <- position ts = (Circle,org,FarthestCorner,ts')
            radArgs (Ident "circle":ts)
                | Just (_, Ident "at":ts') <- circleExt ts,
                        Just (org, stops) <- position ts' =
                    (Circle, org, FarthestCorner, stops)
                | Just (_,ts')<-circleExt ts=(Circle,center,FarthestCorner,ts')
                | otherwise = (Circle, center, FarthestCorner, ts)
            radArgs (Ident "ellipse":Ident "at":ts)
                | Just (org,ts')<-position ts=(Ellipse,org,FarthestCorner,ts')
            radArgs (Ident "ellipse":ts)
                | Just (_, Ident "at":ts') <- ellipseExt ts,
                        Just (org, stops) <- position ts' =
                    (Ellipse, org, FarthestCorner, stops)
                | Just (_,ts')<-ellipseExt ts=(Ellipse,center,FarthestCorner,ts')
                | otherwise = (Ellipse, center, FarthestCorner, ts)
            radArgs ts | Just (_, Ident "at":ts') <- ellipseExt ts,
                        Just (org, stops) <- position ts' =
                    (Ellipse, org, FarthestCorner, stops)
                | Just (_, Ident "ellipse":Ident "at":ts') <- ellipseExt ts,
                        Just (org, stops) <- position ts' =
                    (Ellipse, org, FarthestCorner, stops)
                | Just (_, Ident "ellipse":ts') <- ellipseExt ts =
                    (Ellipse, center, FarthestCorner, ts')
                | Just (_, Ident "circle":Ident "at":ts') <- circleExt ts,
                        Just (org, stops) <- position ts' =
                    (Circle, org, FarthestCorner, stops)
                | Just (_, Ident "circle":ts') <- circleExt ts =
                    (Circle, center, FarthestCorner, ts')
                | otherwise = (Ellipse, center, FarthestCorner, ts)
            radShape "circle" = Just Circle
            radShape "ellipse" = Just Ellipse
            radShape _ = Nothing
            radExt (Ident "closest-corner":ts) = Just (ClosestCorner, ts)
            radExt (Ident "closest-side":ts) = Just (ClosestSide, ts)
            radExt (Ident "farthest-corner":ts) = Just (FarthestCorner, ts)
            radExt (Ident "farthest-side":ts) = Just (FarthestSide, ts)
            radExt _ = Nothing
            ellipseExt ts | Just ret <- radExt ts = Just ret
            ellipseExt (Percentage _ x:Percentage _ y:ts) =
                Just (p' x `Extent` p' y, ts)
            ellipseExt (Percentage _ x:Dimension _ y "px":ts) =
                Just (p' x `Extent` f' y, ts)
            ellipseExt (Dimension _ x "px":Percentage _ y:ts) =
                Just (f' x `Extent` p' y, ts)
            ellipseExt (Dimension _ x "px":Dimension _ y "px":ts) =
                Just (f' x `Extent` p' y, ts)
            ellipseExt _ = Nothing
            circleExt (Dimension _ x "px":ts) = Just (f' x `Extent` f' x, ts)
            circleExt ts = radExt ts
        -- NOTE: Not implementing colourspaces yet...
        inner (Function "conic-gradient":Ident "from":Dimension _ x unit:
                    Ident "at":ts)
            | Just (org, ts') <- position ts, Just s <- lookup unit angularUnits,
              Just stops@(_:_:_) <- colourStops pp ts' =
                Just $ Conical (f x*s) org stops
        inner (Function "conic-gradient":Ident "from":Dimension _ x unit:ts)
            | Just s <- lookup unit angularUnits,
              Just stops@(_:_:_) <- colourStops pp ts =
                Just $ Conical (f x*s) center stops
        inner (Function "conic-gradient":Ident "at":ts)
            | Just (org, ts') <- position ts,
                Just cs@(_:_:_) <- colourStops pp ts' = Just $ Conical 0 org cs
        inner (Function "conic-gradient":ts)
            | Just stops@(_:_:_) <- colourStops pp (Comma:ts) =
                Just $ Conical 0 center stops
        inner _ = Nothing

        angularUnits = [("deg",pi/180),("grad",pi/200),("rad",1),("turn",2*pi)]
        center = (Scale 0.5, Scale 0.5)
        position (x:y:ts) = position' x y ts *> position' y x ts
        position _ = Nothing
        position' x y ts = case ((case x of
                Ident "left" -> Scale 0
                Ident "center" -> Scale 0.5
                Ident "right" -> Scale 1
                Percentage _ a -> p' a
                Dimension _ a "px" -> f' a
                _ -> Auto,
            case y of
                Ident "top" -> Scale 0
                Ident "center" -> Scale 0.5
                Ident "right" -> Scale 1
                Percentage _ a -> p' a
                Dimension _ a "px" -> f' a
                _ -> Auto),
            ts) of
                ((Auto, _), _) -> Nothing
                ((_, Auto), _) -> Nothing
                ret -> Just ret
        p' = Scale . p
        f' = Absolute . f
    longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t =
        Just self { bgSize = reverse val }
      where -- TODO: Add shorthand support, after background-position.
        inner [x, y] | Just a <- l x, Just b <- l y = Just $ Size a b
        inner [Ident "contain"] = Just Contain
        inner [Ident "cover"] = Just Cover
        inner [Ident "auto"] = Just $ Size Auto Auto
        inner [Ident "initial"] = Just $ Size Auto Auto
        inner _ = Nothing
        -- NOTE: Leave lowering other units to CatTrap.
        l (Ident "auto") = Just Auto
        l (Dimension _ x "px") = Just $ Absolute $ f x
        l (Percentage _ x) = Just $ Scale $ p x
        l _ = 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, base ++ Comma:val)
            -- Shouldn't happen, `inner` expands all props at least to "initial"!
            | otherwise = (key, val)
        inner toks | ret@(_:_) <- parseUnorderedShorthand self [
                "background-color", "background-clip", "background-image"
              ] toks = Just ret
          | otherwise = Nothing
    shorthand self key val | Just _ <- longhand self self key val = [(key, val)]
        | otherwise = []

colourStops :: ColourPallet
        -> [Token] -> Maybe [(AlphaColour Float, Length)]
colourStops _ [RightParen] = Just []
colourStops cs (Comma:toks)
    | Just (Percentage _ x:toks', c) <- parseColour cs toks,
        Just ret <- colourStops cs toks' = Just $ (c, Scale $ p x):ret
    | Just (Dimension _ x "px":toks', c) <- parseColour cs toks,
        Just ret <- colourStops cs toks' = Just $ (c, Absolute $ f x):ret
    | Just (toks', c) <- parseColour cs toks,
        Just ret <- colourStops cs toks' = Just $ (c, Auto):ret
colourStops cs (Comma:Percentage _ x:toks)
    | Just (toks', c) <- parseColour cs toks,
        Just ret <- colourStops cs toks' = Just $ (c, Scale $ p x):ret
colourStops cs (Comma:Dimension _ x "px":toks)
    | Just (toks', c) <- parseColour cs toks,
        Just ret <- colourStops cs toks' = Just $ (c, Absolute $ f x):ret
colourStops _ _ = Nothing

parseCSSList :: ([Token] -> Maybe a) -> [Token] -> [a]
parseCSSList cb toks | all isJust ret = catMaybes ret
    | otherwise = []
  where ret = map cb $ concat $ splitList [Comma] $ parseOperands toks

f :: NumericValue -> Float
f (NVInteger x) = fromInteger x
f (NVNumber x) = toRealFloat x
p :: NumericValue -> Float
p (NVInteger x) = fromInteger x / 100
-- Do the division while we're in base-10!
p (NVNumber x) = toRealFloat (x/scientific 1 2)

------
--- 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 filt s = (x,y)
        where
        (x,y')=break filt s
        y = if null y' then [] else tail y'

------
--- Dynamically-computed properties
------

resolveSize :: (Float, Float) -> (Float, Float) -> Resize -> (Float, Float)
resolveSize (owidth, oheight) (width, height) Contain
    | width > owidth, height*sw > oheight, height > width = (width*sh, height*sh)
    | width > owidth = (width*sw, height*sw)
    | height > oheight = (width*sh, height*sh)
    | height > width = (width*sw, height*sw)
    | otherwise = (width*sh, height*sh)
  where
    sh = oheight/height
    sw = owidth/width
resolveSize (owidth, oheight) (width, height) Cover
    | owidth > width, oheight > height*sw = (width*sh, height*sh)
    | oheight > height, owidth > width*sh = (width*sw, height*sw)
    | owidth > width = (width*sw, height*sw)
    | oheight > height = (width*sh, height*sh)
    | oheight > height*sw = (width*sh, height*sh)
    | owidth > width*sh = (width*sw, height*sw)
    | height > width = (width*sw, height*sw)
    | otherwise = (width*sh, height*sh)
  where
    sh = oheight/height
    sw = owidth/width
resolveSize _ ret (Size Auto Auto) = ret
resolveSize _ (width, height) (Size x y) = (x', y')
  where
    x' | Absolute ret <- x = ret
        | Scale s <- x = width*s
        | Auto <- x = y' * width/height
    y' | Absolute ret <- y = ret
        | Scale s <- y = height*s
    -- NOTE: If Auto,Auto case wasn't handled above this'd be an infinite loop.
        | Auto <- y = x' * height/width