5 files changed, 84 insertions(+), 31 deletions(-)

M Mondrian.cabal
M lib/Graphics/Rendering/Rect/Backgrounds.hs
M lib/Graphics/Rendering/Rect/CSS.hs
D lib/Graphics/Rendering/Rect/CSS/Background.hs
A lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs

@@ 22,7 22,7 @@ library
                        Graphics.Rendering.Rect.Backgrounds,
                        Graphics.Rendering.Rect.CSS,
                        Graphics.Rendering.Rect.CSS.Colour,
-                       Graphics.Rendering.Rect.CSS.Background
+                       Graphics.Rendering.Rect.CSS.Backgrounds
   other-modules:       Graphics.Rendering.Rect.Types
   -- other-extensions:
   build-depends:       base >=4.13 && <4.14, stylist-traits >= 0.1.3.1 && < 1,

@@ 1,10 1,11 @@
 module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), renderBackgrounds) where
 
-import Graphics.Rendering.Rect.CSS.Background
+import Graphics.Rendering.Rect.CSS.Backgrounds
 import Graphics.Rendering.Rect.Types
 import qualified Data.ByteString.Char8 as B8
 import Linear (M44)
 import Control.Monad.IO.Class (MonadIO(..))
+import Data.Maybe (fromMaybe, listToMaybe)
 
 baseFragmentShader = B8.pack $ unlines [
     "#version 330 core",


@@ 17,4 18,6 @@ renderBackgrounds :: (MonadIO m, MonadIO n) =>
     n (Backgrounds -> Rects -> M44 Float -> m ())
 renderBackgrounds = do
     base <- renderRectWith baseFragmentShader ["colour"]
-    return $ \self -> base [c $ background self] paddingBox
+    return $ \self -> base [c $ background self] $ headDef borderBox $ clip self
+
+headDef def = fromMaybe def . listToMaybe

@@ 3,12 3,12 @@ module Graphics.Rendering.Rect.CSS(RectStyle(..), colour) where
 
 import Stylist (PropertyParser(..))
 import Graphics.Rendering.Rect.CSS.Colour (ColourPallet(foreground))
-import Graphics.Rendering.Rect.CSS.Background (Backgrounds(..))
+import Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..))
 
 data RectStyle = RectStyle {
     colours :: ColourPallet,
     backgrounds :: Backgrounds
-} deriving (Read, Show, Eq)
+}
 colour = foreground . colours
 
 instance PropertyParser RectStyle where

@@ 1,26 0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Graphics.Rendering.Rect.CSS.Background (Backgrounds(..)) where
-
-import Stylist (PropertyParser(..), parseUnorderedShorthand)
-import Graphics.Rendering.Rect.CSS.Colour (ColourPallet, parseColour)
-import Data.Colour (AlphaColour, transparent)
-
-data Backgrounds = Backgrounds {
-    pallet :: ColourPallet,
-    background :: AlphaColour Float
-} deriving (Read, Show, Eq)
-
-instance PropertyParser Backgrounds where
-    temp = Backgrounds { pallet = temp, background = transparent }
-    inherit _ = temp
-    priority _ = []
-
-    longhand _ self@Backgrounds{ pallet = c } "background-color" toks
-        | Just ([], val) <- parseColour c toks = Just self { background = val }
-    longhand _ _ _ _ = Nothing
-
-    shorthand self "background" toks = parseUnorderedShorthand self [
-        "background-color"
-      ] toks
-    shorthand self key val | Just _ <- longhand self self key val = [(key, val)]
-        | otherwise = []

@@ 0,0 1,76 @@
+{-# 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'