Make render function return cachable surface slices

1 files changed, 50 insertions, 17 deletions

diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index c9b582e..c6e7531 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -53,19 +53,21 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
                                    , borderWeight = 1
                                    }
 
-data Border w d = (Widget w d) => Border !BorderConfig !w
-deriving instance Show (Border w d)
-deriving instance Eq (Border w d)
+data Border w s c = (Widget w s c) => Border !BorderConfig !w
+deriving instance Show (Border w s c)
+deriving instance Eq (Border w s c)
 
-instance Eq d => Widget (Border w d) d where
+data BorderCache w s c = (Widget w s c) => BorderCache !c
+
+instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
   initWidget (Border _ w) = initWidget w
   
-  minSize (Border config w) d height screen =
+  minSize (Border config w) s height screen =
     case True of
       _ | childSize == 0 -> 0
         | otherwise -> max (borderH m+2*(bw+cr)) (childSize + borderH p + 2*bw + borderH m)
     where
-      childSize = minSize w d height' screen
+      childSize = minSize w s height' screen
       
       m = margin config
       bw = borderWidth config
@@ -75,9 +77,9 @@ instance Eq d => Widget (Border w d) d where
   
   weight (Border config _) = borderWeight config
   
-  layout (Border config w) d width height screen = case True of
-    _ | width' > 0 -> layout w d width' height' screen
-      | otherwise -> d
+  layout (Border config w) s width height screen = case True of
+    _ | width' > 0 -> layout w s width' height' screen
+      | otherwise -> s
     where
       m = margin config
       bw = borderWidth config
@@ -86,18 +88,49 @@ instance Eq d => Widget (Border w d) d where
       width' = width - borderH m - 2*bw - borderH p
       height' = height - borderV m - 2*bw - borderV p
 
-  render (Border config w) d x y width height screen = when (width > borderH m - 2*bw - borderH p) $ do
-    drawBorder config 0 0 width height
-    clip
-    translate (fromIntegral dx) (fromIntegral dy)
-    render w d (x+dx) (y+dy) width' height' screen
-    return ()
+  render (Border config w) s x y width height screen = case () of 
+    _ | (width > borderH m - 2*bw - borderH p) -> do
+      border <- createImageSurface FormatARGB32 width height
+      renderWith border $ do
+        setOperator OperatorClear
+        paint
+        setOperator OperatorOver
+        drawBorder config 0 0 width height
+      surfaces <- render w s (x+dx) (y+dy) width' height' screen
+      let surfaces' = (True, 0, Nothing):(map (\(updated, SurfaceSlice x surf) -> (updated, x+dx, Just surf)) surfaces)++[(True, width-rightWidth, Nothing)]
+          surfacesWidths = zipWith (\(updated, x, surf) (_, x', _) -> (updated, x, x'-x, surf)) surfaces' (tail surfaces' ++ [(False, width, Nothing)])
+      forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do
+        surf' <- createImageSurface FormatARGB32  surfWidth height
+        renderWith surf' $ do
+          setOperator OperatorClear
+          paint
+          setOperator OperatorOver
+          
+          save
+          translate (fromIntegral (-x)) 0
+          withPatternForSurface border setSource
+          paint
+          restore
+          
+          case surf of
+            Just surface -> do
+              translate 0 (fromIntegral dy)
+              withPatternForSurface surface setSource
+              paint
+            Nothing -> return ()
+          
+        return (updated, SurfaceSlice x surf')
+      | otherwise -> do
+      surface <- createImageSurface FormatARGB32 width height
+      return [(True, SurfaceSlice 0 surface)]
     where
       m = margin config
       bw = borderWidth config
       p = padding config
       
-      dx = borderLeft m + bw + borderLeft p
+      leftWidth = borderLeft m + bw + borderLeft p
+      rightWidth = borderRight m + bw + borderRight p
+      dx = leftWidth
       dy = borderTop m + bw + borderTop p
       width' = width - borderH m - 2*bw - borderH p
       height' = height - borderV m - 2*bw - borderV p
@@ -139,5 +172,5 @@ roundRectangle x y width height radius = do
   arc (x + radius) (y + radius) radius  pi (pi*3/2)
   closePath
 
-border :: (Widget w d) => BorderConfig -> w -> Border w d
+border :: (Widget w s c) => BorderConfig -> w -> Border w s c
 border = Border