3 files changed, 26 insertions(+), 19 deletions(-)

M lib/Graphics/Rendering/Rect/Backgrounds.hs
M lib/Graphics/Rendering/Rect/CSS/Backgrounds.hs
M lib/Graphics/Rendering/Rect/Types.hs

@@ 170,34 170,36 @@ renderBackgrounds = do
     conic <- renderRectWith conicFragmentShader ["center", "angle",
             "stops", "stopPoints", "nStops"]
     return $ \self a b -> do
-        base [] [c $ background self] (headDef borderBox $ clip self) a b
+        base [] [c $ background self] (headDef borderBox $ clip self)
+                (headDef paddingBox $ origin self) a b
         let layers = image self `zip` (clip self ++ repeat borderBox)
                 `zip` (bgSize self ++ repeat (Size Auto Auto))
-        _ <- forM layers $ \((pat0, clip0), size0) -> case pat0 of
+                `zip` (origin self ++ repeat paddingBox)
+        _ <- forM layers $ \(((pat0, clip0), size0), origin0) -> case pat0 of
             None -> return ()
             Img img0 -> layer [img0] [
                     u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0
-                ] clip0 a b
+                ] clip0 origin0 a b
             Linear angle stops -> let size' = size $ clip0 a in linear [] [
                     u $ v2 $ size', u angle, cs 10 $ map fst stops,
                     us $ ls2fs size' $ map snd $ take 10 stops, u $ length stops
-                ] clip0 a b
+                ] clip0 origin0 a b
             -- FIXME: Incorporate resolveEllipseExtent without messing up center
             Radial Ellipse ext org stops -> let sz@(_,h) = size $ clip0 a in
                 let (org', ext') = resolveEllipseExtent sz org ext in ellipse [] [
                     u $ v2 sz, u $ v2 ext', u $ v2 org', cs 10 $ map fst stops,
                     us $ ls2fs (0,h/2) $ map snd $ take 10 stops, u $ length stops
-                ] clip0 a b
+                ] clip0 origin0 a b
             Radial Circle ext org stops -> let sz@(w,h) = size $ clip0 a
                 in let (org', r) = resolveCircleExtent sz org ext in circle [] [
                     u $ v2 org', u r, cs 10 $ map fst stops,
                     us $ ls2fs (0,min w h/2) $ map snd $ take 10 stops,
                     u $ length stops
-                ] clip0 a b
+                ] clip0 origin0 a b
             Conical angle org stops -> let sz = size $ clip0 a in conic [] [
                     u $ v2 $ l2f' org sz, u angle, cs 10 $ map fst stops,
                     us $ ls2fs (0,2*pi) $ map snd $ take 10 stops, u $ length stops
-                ] clip0 a b
+                ] clip0 origin0 a b
         return ()
 
 headDef :: c -> [c] -> c

@@ 17,6 17,7 @@ data Backgrounds img = Backgrounds {
     pallet :: ColourPallet,
     background :: C,
     clip :: [Rects -> Rect],
+    origin :: [Rects -> Rect],
     image :: [Pattern img],
     bgSize :: [Resize]
 } deriving (Eq, Show, Read)


@@ 38,21 39,15 @@ 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 = [None], bgSize = [Size Auto Auto]
+        image = [None], bgSize = [Size Auto Auto], origin = [paddingBox]
       }
     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 =
+    longhand _ self "background-clip" t | val@(_:_) <- parseCSSList box 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@Backgrounds { pallet = pp } "background-image" t
         | val@(_:_) <- parseCSSList inner t = Just self { image = reverse val }
       where


@@ 183,6 178,8 @@ instance PropertyParser (Backgrounds Text) where
                 ret -> Just ret
         p' = Scale . p
         f' = Absolute . f
+    longhand _ self "background-origin" t | val@(_:_) <- parseCSSList box t =
+        Just self { origin = reverse val }
     longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t =
         Just self { bgSize = reverse val }
       where -- TODO: Add shorthand support, after background-position.


@@ 219,6 216,13 @@ instance PropertyParser (Backgrounds Text) where
     shorthand self key val | Just _ <- longhand self self key val = [(key, val)]
         | otherwise = []
 
+box :: [Token] -> Maybe (Rects -> Rect)
+box [Ident "content-box"] = Just contentBox
+box [Ident "padding-box"] = Just paddingBox
+box [Ident "border-box"] = Just borderBox
+box [Ident "initial"] = Just borderBox -- To aid shorthand implementation.
+box _ = Nothing
+
 colourStops :: ColourPallet
         -> [Token] -> Maybe [(AlphaColour Float, Length)]
 colourStops _ [RightParen] = Just []

@@ 97,7 97,8 @@ cs mlen rgba prog slot = do
     clearUniformUpdateError prog slot val
 
 renderRectWith :: (MonadIO m, MonadIO n) => ByteString -> [String] ->
-        n ([Texture] -> [Uniform m] -> (a -> Rect) -> a -> M44 Float -> m ())
+        n ([Texture] -> [Uniform m] -> (a -> Rect) -> (a -> Rect) -> a
+            -> M44 Float -> m ())
 renderRectWith fragmentShader uniformNames = do
     vs <- liftGL $ compileOGLShader vertexShader GL_VERTEX_SHADER
     fs <- liftGL $ compileOGLShader fragmentShader GL_FRAGMENT_SHADER


@@ 108,14 109,14 @@ renderRectWith fragmentShader uniformNames = do
     glUseProgram prog
     glEnable GL_BLEND
     glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
-    return $ \textures uniforms getter rects mat -> do
-        let r = getter rects
+    return $ \textures uniforms clip' origin' rects mat -> do
         vao <- liftIO $ newBoundVAO
         pbuf <- newBuffer
-        bufferGeometry 0 pbuf $ rect2geom r
+        bufferGeometry 0 pbuf $ rect2geom $ clip' rects
 
         glUseProgram prog
         liftIO $ updateUniform prog matID $ mflip mat
+        let r = origin' rects
         liftIO $ updateUniform prog originID $ V2 (left r) (top r)
         _ <- forM (zip uniformIDs uniforms) $ \(slot, cb) -> cb prog slot