2 files changed, 42 insertions(+), 29 deletions(-)

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

@@ 25,9 25,10 @@ imageFragmentShader = B8.pack $ unlines [
     "#version 330 core",
     "in vec2 coord;",
     "out vec4 fcolour;",
+    "uniform vec2 pos;",
     "uniform sampler2D image;",
     "uniform vec2 size;",
-    "void main() { fcolour = texture(image, coord/size); }"
+    "void main() { fcolour = texture(image, coord/size - pos/size); }"
   ]
 
 linearFragmentShader :: B8.ByteString


@@ 160,7 161,7 @@ renderBackgrounds :: (MonadIO m, MonadIO n) =>
     n (Backgrounds Texture -> Rects -> M44 Float -> m ())
 renderBackgrounds = do
     base <- renderRectWith baseFragmentShader ["colour"]
-    layer <- renderRectWith imageFragmentShader ["size"]
+    layer <- renderRectWith imageFragmentShader ["size", "pos"]
     linear <- renderRectWith linearFragmentShader ["size", "angle",
             "stops", "stopPoints", "nStops"]
     ellipse <- renderRectWith radialFragmentShader ["size", "extent", "center",


@@ 175,10 176,12 @@ renderBackgrounds = do
         let layers = image self `zip` (clip self ++ repeat borderBox)
                 `zip` (bgSize self ++ repeat (Size Auto Auto))
                 `zip` (origin self ++ repeat paddingBox)
-        _ <- forM layers $ \(((pat0, clip0), size0), origin0) -> case pat0 of
+                `zip` (bgPos self ++ repeat (Absolute 0, Absolute 0))
+        _ <- forM layers $ \((((pat0, clip0), size0), origin0), pos0) -> case pat0 of
             None -> return ()
-            Img img0 -> layer [img0] [
-                    u $ v2 $ resolveSize (size $ clip0 a) (texSize img0) size0
+            Img img0 -> let sz = resolveSize (size $ clip0 a) (texSize img0) size0
+                in layer [img0] [
+                    u $ v2 $ sz, u $ v2 $ l2f' pos0 sz
                 ] clip0 origin0 a b
             Linear angle stops -> let size' = size $ clip0 a in linear [] [
                     u $ v2 $ size', u angle, cs 10 $ map fst stops,

@@ 19,6 19,7 @@ data Backgrounds img = Backgrounds {
     clip :: [Rects -> Rect],
     origin :: [Rects -> Rect],
     image :: [Pattern img],
+    bgPos :: [(Length, Length)],
     bgSize :: [Resize]
 } deriving (Eq, Show, Read)
 


@@ 39,7 40,8 @@ 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], origin = [paddingBox]
+        image = [None], bgSize = [Size Auto Auto], origin = [paddingBox],
+        bgPos = [(Absolute 0, Absolute 0)]
       }
     inherit _ = temp
     priority _ = []


@@ 156,30 158,10 @@ instance PropertyParser (Backgrounds Text) where
 
         angularUnits = [("deg",pi/180),("grad",pi/200),("rad",1),("turn",2*pi)]
         center = (Scale 0.5, Scale 0.5)
-        position (x:y:ts) = position' x y ts *> position' y x ts
-        position _ = Nothing
-        position' x y ts = case ((case x of
-                Ident "left" -> Scale 0
-                Ident "center" -> Scale 0.5
-                Ident "right" -> Scale 1
-                Percentage _ a -> p' a
-                Dimension _ a "px" -> f' a
-                _ -> Auto,
-            case y of
-                Ident "top" -> Scale 0
-                Ident "center" -> Scale 0.5
-                Ident "right" -> Scale 1
-                Percentage _ a -> p' a
-                Dimension _ a "px" -> f' a
-                _ -> Auto),
-            ts) of
-                ((Auto, _), _) -> Nothing
-                ((_, Auto), _) -> Nothing
-                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-position" t | val@(_:_) <- parseCSSList position t,
+        all (null . snd) val = Just self { bgPos = reverse $ map fst val }
     longhand _ self "background-size" t | val@(_:_) <- parseCSSList inner t =
         Just self { bgSize = reverse val }
       where -- TODO: Add shorthand support, after background-position.


@@ 210,7 192,8 @@ instance PropertyParser (Backgrounds Text) where
             -- Shouldn't happen, `inner` expands all props at least to "initial"!
             | otherwise = (key, val)
         inner toks | ret@(_:_) <- parseUnorderedShorthand self [
-                "background-color", "background-clip", "background-image"
+                "background-color", "background-clip", "background-image",
+                "background-origin", "background-position"
               ] toks = Just ret
           | otherwise = Nothing
     shorthand self key val | Just _ <- longhand self self key val = [(key, val)]


@@ 223,6 206,29 @@ box [Ident "border-box"] = Just borderBox
 box [Ident "initial"] = Just borderBox -- To aid shorthand implementation.
 box _ = Nothing
 
+position :: [Token] -> Maybe ((Length, Length), [Token])
+position (x:y:ts) = position' x y ts *> position' y x ts
+position _ = Nothing
+position' :: Token -> Token -> [Token] -> Maybe ((Length, Length), [Token])
+position' x y ts = case ((case x of
+        Ident "left" -> Scale 0
+        Ident "center" -> Scale 0.5
+        Ident "right" -> Scale 1
+        Percentage _ a -> p' a
+        Dimension _ a "px" -> f' a
+        _ -> Auto,
+    case y of
+        Ident "top" -> Scale 0
+        Ident "center" -> Scale 0.5
+        Ident "right" -> Scale 1
+        Percentage _ a -> p' a
+        Dimension _ a "px" -> f' a
+        _ -> Auto),
+    ts) of
+        ((Auto, _), _) -> Nothing
+        ((_, Auto), _) -> Nothing
+        ret -> Just ret
+
 colourStops :: ColourPallet
         -> [Token] -> Maybe [(AlphaColour Float, Length)]
 colourStops _ [RightParen] = Just []


@@ 253,6 259,10 @@ p :: NumericValue -> Float
 p (NVInteger x) = fromInteger x / 100
 -- Do the division while we're in base-10!
 p (NVNumber x) = toRealFloat (x/scientific 1 2)
+p' :: NumericValue -> Length
+p' = Scale . p
+f' :: NumericValue -> Length
+f' = Absolute . f
 
 ------
 --- Utils taken from HappStack