Cache windows in taskbar

lib/Phi/Widget.hs

@@ -98,12 +98,12 @@ type RenderCache w s = IOCache (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surfac
 createIOCache :: Eq a => (a -> IO b) -> IOCache a b
 createIOCache = lift . Kleisli
 
-runIOCache :: Eq a => a -> StateT (IOCache a b) IO (b, Bool)
+runIOCache :: Eq a => a -> StateT (IOCache a b) IO b
 runIOCache a = do
   cache <- get
-  (b, updated, cache') <- liftIO $ runKleisli (runCache' cache) a
+  (b, cache') <- liftIO $ runKleisli (runCache cache) a
   put cache'
-  return (b, updated)
+  return b
 
 createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ())
                      -> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface

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
   
@@ -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
+                               }
+
+data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache)
+                                 , windowCaches  :: !(M.Map Window WindowCache)
                                  }
-createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached
 
 -- 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
@@ -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 ->
+                Just state -> do
-                  liftT (AC.mapDefault emptyWindowCache window) $ renderTask state style x y windowWidth h'
+                  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 ()
+renderWindow :: WindowState -> TaskStyle -> Int -> Int -> StateT WindowCache IO Surface
-renderTask state style x y w h = do
+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
+      Just (Icon _ _ icon) -> do
         save
-      translate (fromIntegral $ x + leftBorder) (fromIntegral $ y + (borderTop $ margin $ taskBorder style))
+        translate (fromIntegral leftBorder) (fromIntegral . borderTop . margin . taskBorder $ style)
-      taskIconStyle style icon
+        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