From 6236cf8ab70f087f4348706e4d677874ec5002cb Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 7 Jun 2023 11:08:10 +1200 Subject: [PATCH] Add support for background-clip & prepare for multilayered backgrounds! --- Mondrian.cabal | 2 +- lib/Graphics/Rendering/Rect/Backgrounds.hs | 7 +- lib/Graphics/Rendering/Rect/CSS.hs | 4 +- lib/Graphics/Rendering/Rect/CSS/Background.hs | 26 ------- .../Rendering/Rect/CSS/Backgrounds.hs | 76 +++++++++++++++++++ 5 files changed, 84 insertions(+), 31 deletions(-) delete mode 100644 lib/Graphics/Rendering/Rect/CSS/Background.hs create mode 100644 lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs diff --git a/Mondrian.cabal b/Mondrian.cabal index f3a15f4..ee19b27 100644 --- a/Mondrian.cabal +++ b/Mondrian.cabal @@ -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, diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs index 9a3f374..e7606fc 100644 --- a/lib/Graphics/Rendering/Rect/Backgrounds.hs +++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs @@ -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 diff --git a/lib/Graphics/Rendering/Rect/CSS.hs b/lib/Graphics/Rendering/Rect/CSS.hs index 0cc0100..ffee393 100644 --- a/lib/Graphics/Rendering/Rect/CSS.hs +++ b/lib/Graphics/Rendering/Rect/CSS.hs @@ -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 diff --git a/lib/Graphics/Rendering/Rect/CSS/Background.hs b/lib/Graphics/Rendering/Rect/CSS/Background.hs deleted file mode 100644 index d41fd77..0000000 --- a/lib/Graphics/Rendering/Rect/CSS/Background.hs +++ /dev/null @@ -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 = [] diff --git a/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs new file mode 100644 index 0000000..b5deb10 --- /dev/null +++ b/lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs @@ -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' -- 2.30.2