1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..)) where
import Stylist (PropertyParser(..), parseUnorderedShorthand)
import Data.CSS.Syntax.Tokens (Token(..))
import Data.Maybe (isJust, catMaybes)
import Data.Text (Text)
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 :: AlphaColour Float,
clip :: [Rects -> Rect],
image :: [img]
} deriving (Eq, Show, Read)
instance PropertyParser (Backgrounds Text) where
temp = Backgrounds {
pallet = temp, background = transparent, clip = [borderBox], image = [""]
}
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 ""
inner [Ident "initial"] = Just ""
inner [Url ret] = Just ret
inner [Function "url", String ret, RightParen] = Just ret
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, 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-color"
] 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'