Make render function return cachable surface slices

4 files changed, 97 insertions, 72 deletions

diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs
index eacda5a..cd540e3 100644
--- a/lib/Phi/Widgets/AlphaBox.hs
+++ b/lib/Phi/Widgets/AlphaBox.hs
@@ -12,11 +12,11 @@ import Control.Monad
 import Graphics.Rendering.Cairo
 
 
-data AlphaBox w d = (Widget w d) => AlphaBox !Double !w
-deriving instance Show (AlphaBox w d)
-deriving instance Eq (AlphaBox w d)
+data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w
+deriving instance Show (AlphaBox w s c)
+deriving instance Eq (AlphaBox w s c)
 
-instance Eq d => Widget (AlphaBox w d) d where
+instance Eq s => Widget (AlphaBox w s c) s () where
   initWidget (AlphaBox _ w) = initWidget w
   
   minSize (AlphaBox _ w) = minSize w
@@ -25,21 +25,25 @@ instance Eq d => Widget (AlphaBox w d) d where
   
   layout (AlphaBox _ w) = layout w
 
-  render (AlphaBox alpha w) d x y width height screen = do
-    renderWithSimilarSurface ContentColorAlpha width height $ \surface -> do
-      renderWith surface $ do
-        render w d x y width height screen
+  render (AlphaBox alpha w) s x y width height screen = do
+    surfaces <- render w s x y width height screen
+    let surfacesWidths = zipWith (\(updated, SurfaceSlice x surf) x' -> (updated, x, x'-x, surf)) surfaces (map (\(_, SurfaceSlice x _) -> x) (tail surfaces) ++ [width])
+    forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do
+      surf' <- createImageSurface FormatARGB32  surfWidth height
+      renderWith surf' $ do
+        setOperator OperatorSource
+        withPatternForSurface surf setSource
+        paint
         
         setOperator OperatorDestIn
         setSourceRGBA 0 0 0 alpha
         paint
       
-      withPatternForSurface surface setSource
-      paint
+      return (updated, SurfaceSlice x surf')
   
   handleMessage (AlphaBox _ w) = handleMessage w
 
 
-alphaBox :: (Widget w d) => Double -> w -> AlphaBox w d
+alphaBox :: (Widget w s c) => Double -> w -> AlphaBox w s c
 alphaBox = AlphaBox
 
diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs
index bee8d39..12906c0 100644
--- a/lib/Phi/Widgets/Clock.hs
+++ b/lib/Phi/Widgets/Clock.hs
@@ -43,7 +43,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq)
 
 data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable)
 
-instance Widget Clock ClockState where
+instance Widget Clock ClockState () where
   initWidget (Clock _) phi _ = do
     forkIO $ forever $ do
       time <- getZonedTime
@@ -59,26 +59,33 @@ instance Widget Clock ClockState where
   minSize (Clock config) _ _ _ = clockSize config
   
   render (Clock config) (ClockState time) _ _ w h _ = do
-    let (r, g, b, a) = fontColor config
-        str = formatTime defaultTimeLocale (clockFormat config) time
-    setSourceRGBA r g b a
-    
-    layout <- createLayout ""
-    (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do
-      layoutSetMarkup layout str
-      layoutSetAlignment layout AlignCenter
-      layoutSetSpacing layout $ lineSpacing config
-      layoutGetExtents layout
-    
-    let scalef = min 1 ((fromIntegral w)/textWidth)
-    when (scalef < 1) $ do
-      scale scalef scalef
-      updateLayout layout
-    
-    (_, PangoRectangle _ _ textWidth' textHeight') <- liftIO $ layoutGetExtents layout
-    
-    moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2)
-    showLayout layout
+    surface <- createImageSurface FormatARGB32 w h
+    renderWith surface $ do
+      setOperator OperatorClear
+      paint
+
+      setOperator OperatorOver
+      let (r, g, b, a) = fontColor config
+          str = formatTime defaultTimeLocale (clockFormat config) time
+      setSourceRGBA r g b a
+      
+      layout <- createLayout ""
+      (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do
+        layoutSetMarkup layout str
+        layoutSetAlignment layout AlignCenter
+        layoutSetSpacing layout $ lineSpacing config
+        layoutGetExtents layout
+      
+      let scalef = min 1 ((fromIntegral w)/textWidth)
+      when (scalef < 1) $ do
+        scale scalef scalef
+        updateLayout layout
+      
+      (_, PangoRectangle _ _ textWidth' textHeight') <- liftIO $ layoutGetExtents layout
+      
+      moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2)
+      showLayout layout
+    return [(True, SurfaceSlice 0 surface)]
   
   handleMessage _ priv m = case (fromMessage m) of
     Just (UpdateTime time) -> ClockState time
diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs
index 6812018..662c6a7 100644
--- a/lib/Phi/Widgets/Systray.hs
+++ b/lib/Phi/Widgets/Systray.hs
@@ -47,7 +47,7 @@ data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon
                       deriving (Show, Typeable)
 
 
-instance Widget Systray SystrayState where
+instance Widget Systray SystrayState () where
   initWidget (Systray) phi dispvar = do
     phi' <- dupPhi phi
     forkIO $ systrayRunner phi' dispvar
@@ -61,15 +61,20 @@ instance Widget Systray SystrayState where
 
   weight _ = 0
   
-  render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = case True of 
-    _ | screen == systrayScreen -> do
-      lastReset <- liftIO $ readIORef lastResetRef
-      liftIO $ writeIORef lastResetRef reset
+  render Systray (SystrayState phi systrayScreen reset lastResetRef icons) x y w h screen = do
+    when (screen == systrayScreen) $ do
+      lastReset <- readIORef lastResetRef
+      writeIORef lastResetRef reset
       forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
         let x' = x + i*(h+2)
         sendMessage phi $ RenderIcon midParent window x' y h h (lastReset /= reset)
-        
-      | otherwise -> return ()
+    
+    surface <- createImageSurface FormatARGB32 w h
+    renderWith surface $ do
+      setOperator OperatorClear
+      paint
+    return [(True, SurfaceSlice 0 surface)]
+
   
   handleMessage _ priv@(SystrayState phi screen reset lastReset icons) m = case (fromMessage m) of
     Just (AddIcon midParent window) -> SystrayState phi screen reset lastReset ((SystrayIconState midParent window):icons)
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index c17ac36..fbf7da8 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -166,7 +166,7 @@ data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState
 instance Show (IORef a) where
   show _ = "IORef <?>"
 
-instance Widget Taskbar TaskbarState where
+instance Widget Taskbar TaskbarState () where
   initWidget (Taskbar _) phi dispvar = do
     phi' <- dupPhi phi
     forkIO $ taskbarRunner phi' dispvar
@@ -204,41 +204,50 @@ instance Widget Taskbar TaskbarState where
         
         desktopsWidth  = sum $ map dwidth desktopNumbers
         windowWidth    = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount)
-      
-    flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do
-      let dstyle' = dstyle desktop
-          dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth
-      
-      case dstyle' of
-        Just ds -> do
-          let (r, g, b, a) = desktopColor ds
-          save
-          drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h
-          clip
-          
-          setSourceRGBA r g b a
-          renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1)
-          
-          restore
-      
-          forM_ (zip [0..] desktopWindows) $ \(i, window) -> do
-            let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
-                h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds)
-                mstate = M.lookup window windowStates
-                micons = M.lookup window windowIcons
-                mscaledIconRef = M.lookup window windowScaledIcons
-                x = dx + i*windowWidth
-                y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds)
+    
+    surface <- createImageSurface FormatARGB32 w h
+    renderWith surface $ do
+      setOperator OperatorClear
+      paint
+
+      setOperator OperatorOver
+
+      flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do
+        let dstyle' = dstyle desktop
+            dx = dleftwidth desktop + (sum $ map dwidth $ take desktop [0..]) + nwindows*windowWidth
+        
+        case dstyle' of
+          Just ds -> do
+            let (r, g, b, a) = desktopColor ds
+            save
+            drawBorder (desktopBorder ds) (dx - dleftwidth desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h
+            clip
             
-            case (mstate, micons, mscaledIconRef) of
-              (Just state, Just icons, Just scaledIconRef) ->
-                renderTask state icons scaledIconRef style x y windowWidth h'
-          
-              _ -> return ()
+            setSourceRGBA r g b a
+            renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1)
+            
+            restore
+            
+            forM_ (zip [0..] desktopWindows) $ \(i, window) -> do
+              let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
+                  h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds)
+                  mstate = M.lookup window windowStates
+                  micons = M.lookup window windowIcons
+                  mscaledIconRef = M.lookup window windowScaledIcons
+                  x = dx + i*windowWidth
+                  y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds)
+              
+              case (mstate, micons, mscaledIconRef) of
+                (Just state, Just icons, Just scaledIconRef) ->
+                  renderTask state icons scaledIconRef style x y windowWidth h'
+            
+                _ -> return ()
         
-        _ -> return ()
+          _ -> return ()
       
-      return $ nwindows + length desktopWindows
+        return $ nwindows + length desktopWindows
+    
+    return [(True, SurfaceSlice 0 surface)]
       
   
   handleMessage _ priv m = case (fromMessage m) of