4 files changed, 58 insertions(+), 22 deletions(-)

M app/Main.hs
M lib/Graphics/Rendering/Rect.hs
M lib/Graphics/Rendering/Rect/Backgrounds.hs
M lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs

@@ 5,7 5,7 @@ import Graphics.Rendering.Rect
 import Stylist.Parse (parseProperties')
 import Stylist (PropertyParser(..))
 import Data.Text (Text, pack, unpack)
-import Data.CSS.Syntax.Tokens (tokenize, serialize)
+import Data.CSS.Syntax.Tokens (tokenize, serialize, Token(Whitespace))
 
 import SDL hiding (trace)
 import Graphics.GL.Core32


@@ 28,10 28,12 @@ parseStyle syn
   where
     toks = tokenize $ pack syn
     apply ((key, val):props)
-        | Just self' <- longhand self self key val = self'
-        | props'@(_:_) <- shorthand self key val = apply (props' ++ props)
+        | Just self' <- longhand self self key val' = self'
+        | props'@(_:_) <- shorthand self key val' = apply (props' ++ props)
         | otherwise = trace ("Unsupported property " ++ unpack key) self
-      where self = apply props
+      where
+        self = apply props
+        val' = filter (/= Whitespace) val
     apply [] = temp
 
 orthoProjection (V2 ww wh) =

@@ 1,5 1,5 @@
 module Graphics.Rendering.Rect(Rect(..), Rects(..), shrink, shrink1, renderRects,
-    RectStyle(..), colour, Backgrounds(..),
+    RectStyle(..), colour, Backgrounds(..), Pattern(..), Resize(..), Length(..),
     Atlas, buildAtlas, atlasFromStyles, Texture, styleResolveImages) where
 
 import Graphics.Rendering.Rect.CSS


@@ 30,10 30,14 @@ renderRects = do
 
 styleResolveImages :: Atlas -> RectStyle Text -> RectStyle Texture
 styleResolveImages atlas self =
-    let textures = map (flip atlasLookup atlas) $ image $ backgrounds self
+    let textures = map atlasLookup' $ image $ backgrounds self
     in self { backgrounds = (backgrounds self) { image = textures } }
+  where
+    atlasLookup' None = None
+    atlasLookup' (Img path) = Img $ atlasLookup path atlas
+    atlasLookup' (Linear a b) = Linear a b
 
 atlasFromStyles :: MonadIO m =>
         (Text -> IO DynamicImage) -> [RectStyle Text] -> m Atlas
 atlasFromStyles cb styles =
-    buildAtlas cb $ nub $ concat $ map (image . backgrounds) styles
+    buildAtlas cb $ nub  [path | s <- styles, Img path <- image $ backgrounds s]

@@ 1,4 1,5 @@
-module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), renderBackgrounds) where
+module Graphics.Rendering.Rect.Backgrounds(Backgrounds(..), Pattern(..),
+    Resize(..), Length(..), resolveSize, renderBackgrounds) where
 
 import Graphics.Rendering.Rect.CSS.Backgrounds
 import Graphics.Rendering.Rect.Types


@@ 26,19 27,34 @@ imageFragmentShader = B8.pack $ unlines [
     "void main() { fcolour = texture(image, coord/size); }"
   ]
 
+linearFragmentShader = B8.pack $ unlines [
+    "#version 330 core",
+    "in vec2 coord;",
+    "out vec4 fcolour;",
+    "uniform vec2 size;",
+    "uniform vec4 start;",
+    "uniform vec4 end;",
+    "void main() { fcolour = mix(start, end, coord.y/size.y); }"
+  ]
+
 renderBackgrounds :: (MonadIO m, MonadIO n) =>
     n (Backgrounds Texture -> Rects -> M44 Float -> m ())
 renderBackgrounds = do
     base <- renderRectWith baseFragmentShader ["colour"]
     layer <- renderRectWith imageFragmentShader ["size"]
+    linear <- renderRectWith linearFragmentShader ["size", "start", "end"]
     return $ \self a b -> do
         base [] [c $ background self] (headDef borderBox $ clip self) a b
         let layers = image self `zip` (clip self ++ repeat borderBox)
                 `zip` (bgSize self ++ repeat (Size Auto Auto))
-        forM layers $ \((img0, clip0), size0) ->
-            layer [img0] [
-                u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0
-            ] clip0 a b
+        forM layers $ \((pat0, clip0), size0) -> case pat0 of
+            None -> return ()
+            Img img0 -> layer [img0] [
+                    u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0
+                ] clip0 a b
+            Linear start end -> linear [] [
+                    u $ v2 $ size $ clip0 a, c start, c end
+                ] clip0 a b
         return ()
 
 headDef def = fromMaybe def . listToMaybe

@@ 1,8 1,8 @@
 {-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
-module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..),
+module Graphics.Rendering.Rect.CSS.Backgrounds (Backgrounds(..), Pattern(..),
     Resize(..), Length(..), resolveSize) where
 
-import Stylist (PropertyParser(..), parseUnorderedShorthand)
+import Stylist (PropertyParser(..), parseUnorderedShorthand, parseOperands)
 import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
 import Data.Maybe (isJust, catMaybes)
 import Data.Text (Text)


@@ 12,14 12,20 @@ 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 :: AlphaColour Float,
+    background :: C,
     clip :: [Rects -> Rect],
-    image :: [img],
+    image :: [Pattern img],
     bgSize :: [Resize]
 } deriving (Eq, Show, Read)
 
+type C = AlphaColour Float
+
+data Pattern img = None | Img img | Linear C 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)


@@ 27,7 33,7 @@ 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 = [""], bgSize = [Size Auto Auto]
+        image = [None], bgSize = [Size Auto Auto]
       }
     inherit _ = temp
     priority _ = []


@@ 45,11 51,19 @@ instance PropertyParser (Backgrounds Text) where
     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 [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 [s, e] <- colourStops (Comma:toks) = Just $ Linear s e
+            | otherwise = traceShow toks Nothing
         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.


@@ 88,7 102,7 @@ instance PropertyParser (Backgrounds Text) where
 
 parseCSSList cb toks | all isJust ret = catMaybes ret
     | otherwise = []
-  where ret = map cb $ splitList Comma toks
+  where ret = map cb $ concat $ splitList [Comma] $ parseOperands toks
 
 f :: NumericValue -> Float
 f (NVInteger x) = fromInteger x