~alcinnz/Mondrian

ref: a22a7f055c206193392f8adbb1dcea79eb7d2e20 Mondrian/lib/Graphics/Rendering/Rect/CSS.hs -rw-r--r-- 1.8 KiB
a22a7f05 — Adrian Cochrane Implement groove, ridge, inset, & outset border styles! Fix border-left-color 1 year, 5 months ago
                                                                                
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
{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}
module Graphics.Rendering.Rect.CSS(RectStyle(..), colour, border) where

import Stylist (PropertyParser(..))
import Graphics.Rendering.Rect.CSS.Colour (ColourPallet(foreground))
import Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..))
import Graphics.Rendering.Rect.CSS.Border (Border(..))
import Data.Text (Text)
import Data.Colour(AlphaColour)

data RectStyle img = RectStyle {
    colours :: ColourPallet,
    backgrounds :: Backgrounds img,
    border' :: Border
} deriving (Eq, Show, Read)
colour :: RectStyle img -> AlphaColour Float
colour = foreground . colours
border :: RectStyle img -> Border
border self = (border' self) { borderPallet = colours self }

instance PropertyParser (RectStyle Text) where
    temp = RectStyle { colours = temp, backgrounds = temp, border' = temp }
    inherit RectStyle {..} = RectStyle {
        colours = inherit colours, backgrounds = temp, border' = temp
    }
    priority RectStyle {..} =
        priority colours ++ priority backgrounds ++ priority border'

    shorthand self key value
        | ret@(_:_) <- shorthand (backgrounds self) key value = ret
        | ret@(_:_) <- shorthand (border self) key value = ret
        | Just _ <- longhand self self key value = [(key, value)]
        | otherwise = []
    longhand parent self key value
        | Just ret <- longhand (backgrounds parent) { pallet = colours self }
                (backgrounds self) { pallet = colours self } key value =
            Just self { backgrounds = ret }
        | Just ret <- longhand (colours parent) (colours self) key value =
            Just self { colours = ret }
        | Just ret <- longhand (border parent) (border self) key value =
            Just self { border' = ret }
        | otherwise = Nothing