Cache windows in taskbar

1 files changed, 62 insertions, 29 deletions

diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index 723427b..da68c27 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -51,13 +51,15 @@ import Phi.Widget
 import Phi.X11.Atoms
 
 
-type IconStyle = Surface -> Render ()
+newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () }
+instance Eq IconStyle where
+  _ == _ = True
 
 idIconStyle :: IconStyle
-idIconStyle = flip withPatternForSurface setSource
+idIconStyle = IconStyle $ flip withPatternForSurface setSource
 
 desaturateIconStyle :: Double -> IconStyle
-desaturateIconStyle v icon = do
+desaturateIconStyle v = IconStyle $ \icon -> do
   w <- imageSurfaceGetWidth icon
   h <- imageSurfaceGetHeight icon
   
@@ -66,14 +68,14 @@ desaturateIconStyle v icon = do
       setOperator OperatorAdd
       withPatternForSurface icon setSource
       paint
-    
+      
       setSourceRGB 0 0 0
       paint
       
       setOperator OperatorHslSaturation
       setSourceRGBA 0 0 0 (1-v)
       paint
-        
+      
       setOperator OperatorDestIn
       withPatternForSurface icon setSource
       paint
@@ -104,7 +106,7 @@ data TaskStyle = TaskStyle { taskFont      :: !String
                            , taskColor     :: !Color
                            , taskBorder    :: !BorderConfig
                            , taskIconStyle :: !IconStyle
-                           }
+                           } deriving Eq
 
 data DesktopStyle = DesktopStyle { desktopFont       :: !String
                                  , desktopLabelWidth :: !Int
@@ -159,13 +161,24 @@ data WindowState = WindowState { windowTitle   :: !String
                                , windowScreen  :: !Xlib.Rectangle
                                } deriving (Eq, Show)
 
-data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Surface))
+data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon))
+                               , renderWindowCached     :: !(IOCache (String, Maybe Icon, TaskStyle, Int, Int) Surface)
                                }
 
+createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached
+renderWindowCached' = A.fromSetGet (\a cache -> cache {renderWindowCached = a}) renderWindowCached
+
+
+newtype DesktopCache = DesktopCache (IOCache () ())
+
 emptyWindowCache :: WindowCache
 emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon
+                               , renderWindowCached     = createIOCache doRenderWindow
                                }
-createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached
+
+data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache)
+                                 , windowCaches  :: !(M.Map Window WindowCache)
+                                 }
 
 -- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant
 liftT :: (Monad m) => A.T r s -> StateT s m a -> StateT r m a
@@ -182,6 +195,9 @@ liftIOStateT m = do
   put s1
   return a
 
+cached :: (MonadIO m, Eq a) => A.T s (IOCache a b) -> a -> StateT s m b
+cached t = liftT t . liftIOStateT . runIOCache
+
 data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState)
                     | DesktopCountUpdate !Int
                     | CurrentDesktopUpdate !Int
@@ -233,7 +249,7 @@ instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
         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
@@ -259,8 +275,14 @@ instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
                   y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds)
               
               case mstate of
-                Just state ->
-                  liftT (AC.mapDefault emptyWindowCache window) $ renderTask state style x y windowWidth h'
+                Just state -> do
+                  windowSurface <- liftT (AC.mapDefault emptyWindowCache window) . liftIOStateT $ renderWindow state style windowWidth h'
+                  lift $ do
+                    save
+                    translate (fromIntegral $ x - 5) (fromIntegral $ y - 5)
+                    withPatternForSurface windowSurface setSource
+                    paint
+                    restore
             
                 Nothing -> return ()
         
@@ -296,36 +318,47 @@ renderText font x y w h text = do
   moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2)
   showLayout layout
 
-renderTask :: WindowState -> TaskStyle -> Int -> Int -> Int -> Int -> StateT WindowCache Render ()
-renderTask state style x y w h = do
+renderWindow :: WindowState -> TaskStyle -> Int -> Int -> StateT WindowCache IO Surface
+renderWindow state style w h = do
+  let h' = h - (borderV $ margin $ taskBorder style)
+  
+  scaledIcon <- cached createScaledIconCached' (windowIcons state, h')
+  cached renderWindowCached' (windowTitle state, scaledIcon, style, w, h)
+
+doRenderWindow :: (String, Maybe Icon, TaskStyle, Int, Int) -> IO Surface
+doRenderWindow (title, scaledIcon, style, w, h) = do
   let (r, g, b, a) = taskColor style
       leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style)
       rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style)
       h' = h - (borderV $ margin $ taskBorder style)
   
-  lift $ do
+  surface <- createImageSurface FormatARGB32 (w+10) (h+10)
+  renderWith surface $ do
+    translate 5 5
+    
     save
-    drawBorder (taskBorder style) x y w h
+    drawBorder (taskBorder style) 0 0 w h
     clip
     
     setSourceRGBA r g b a
-    renderText (taskFont style) (fromIntegral (x + leftBorder + h' + 3)) y (w - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
-  
+    renderText (taskFont style) (fromIntegral (leftBorder + h' + 3)) 0 (w - leftBorder - h' - 3 - rightBorder) h title
+    
     restore
-  
-  (scaledIcon, updated) <- liftT createScaledIconCached' $ liftIOStateT $ runIOCache (windowIcons state, h')
-  case scaledIcon of
-    Just icon -> lift $ do
-      save
-      translate (fromIntegral $ x + leftBorder) (fromIntegral $ y + (borderTop $ margin $ taskBorder style))
-      taskIconStyle style icon
-      paint
-      restore
     
-    _ -> return ()
+    case scaledIcon of
+      Just (Icon _ _ icon) -> do
+        save
+        translate (fromIntegral leftBorder) (fromIntegral . borderTop . margin . taskBorder $ style)
+        withIconStyle (taskIconStyle style) icon
+        paint
+        restore
+    
+      _ -> return ()
+  
+  return surface
                 
 
-createScaledIcon :: ([Icon], Int) -> IO (Maybe Surface)
+createScaledIcon :: ([Icon], Int) -> IO (Maybe Icon)
 createScaledIcon (icons, h) = do
   case bestIcon of
     Just (Icon _ _ icon) -> do
@@ -342,7 +375,7 @@ createScaledIcon (icons, h) = do
         
         downscaled scalef icon
         paint
-      return $ Just scaledIcon
+      fmap Just $ createIcon h scaledIcon
           
     _ -> return Nothing