{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..), Pattern(..),
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(..))
import Debug.Trace (traceShow)
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] 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 "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 (Comma:toks) = Just $ Linear pi cs
inner (Function "linear-gradient":Dimension _ x unit:toks)
| Just s <- lookup unit [("deg", pi/180), ("grad", pi/200),
("rad", 1), ("turn", 2*pi)],
Just cs@(_:_:_) <- colourStops 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 toks =
Just $ Linear angle stops
| Just angle <- corner b a, Just stops@(_:_:_) <- colourStops 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 toks = Just $ Linear angle cs
inner _ = Nothing
colourStops [RightParen] = Just []
colourStops (Comma:toks)
| Just (toks', c) <- parseColour (pallet self) toks,
Just ret <- colourStops toks' = Just $ c:ret
colourStops _ = Nothing
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 <- length x, Just b <- length 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.
length (Ident "auto") = Just Auto
length (Dimension _ x "px") = Just $ Absolute $ f x
length (Percentage _ x) = Just $ Scale $ p x
length _ = 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 = []
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 f s = (left,right)
where
(left,right')=break f s
right = if null right' then [] else tail right'
------
--- 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)
| width > height = (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)
| width > height = (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