Cache scaled icons in taskbar

1 files changed, 85 insertions, 54 deletions

diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index ab67846..92c93e8 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -19,6 +19,7 @@ import Data.Array.MArray
 import Data.Bits
 import Data.Char
 import Data.Function
+import Data.IORef
 import Data.List
 import Data.Maybe
 import Data.Typeable
@@ -123,7 +124,7 @@ defaultStyle = TaskStyle { taskFont = "Sans 8"
                          }
 
 defaultTaskbarConfig :: TaskbarConfig
-defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
+defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
                                      , normalTaskStyle = defaultStyle
                                      , activeTaskStyle = defaultStyle {taskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }}
                                      , desktopStyle = Nothing
@@ -134,13 +135,14 @@ data Taskbar = Taskbar TaskbarConfig deriving Show
 instance Show Surface where
   show _ = "Surface <?>"
 
-data TaskbarState = TaskbarState { taskbarActiveWindow   :: !Window
-                                 , taskbarDesktopCount   :: !Int
-                                 , taskbarCurrentDesktop :: !Int
-                                 , taskbarWindows        :: ![Window]
-                                 , taskbarWindowStates   :: !(M.Map Window WindowState)
-                                 , taskbarWindowIcons    :: !(M.Map Window [(Int, Surface)])
-                                 , taskbarWindowScreens  :: !(M.Map Window Xlib.Rectangle)
+data TaskbarState = TaskbarState { taskbarActiveWindow      :: !Window
+                                 , taskbarDesktopCount      :: !Int
+                                 , taskbarCurrentDesktop    :: !Int
+                                 , taskbarWindows           :: ![Window]
+                                 , taskbarWindowStates      :: !(M.Map Window WindowState)
+                                 , taskbarWindowIcons       :: !(M.Map Window [(Int, Surface)])
+                                 , taskbarWindowScaledIcons :: !(M.Map Window (IORef (Maybe (Int, Surface))))
+                                 , taskbarWindowScreens     :: !(M.Map Window Xlib.Rectangle)
                                  } deriving Show
 
 data WindowState = WindowState { windowTitle   :: !String
@@ -148,19 +150,22 @@ data WindowState = WindowState { windowTitle   :: !String
                                , windowVisible :: !Bool
                                } deriving (Show, Eq)
 
-data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) (M.Map Window [(Int, Surface)]) (M.Map Window Xlib.Rectangle)
+data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) (M.Map Window [(Int, Surface)]) (M.Map Window (IORef (Maybe (Int, Surface)))) (M.Map Window Xlib.Rectangle)
                     | DesktopCountUpdate Int
                     | CurrentDesktopUpdate Int
                     | ActiveWindowUpdate Window
                     deriving (Show, Typeable)
 
+instance Show (IORef a) where
+  show _ = "IORef <?>"
+
 instance WidgetClass Taskbar where
   type WidgetData Taskbar = TaskbarState
   
   initWidget (Taskbar _) phi dispvar = do
     forkIO $ taskbarRunner phi dispvar
     
-    return $ TaskbarState 0 0 (-1) [] M.empty M.empty M.empty
+    return $ TaskbarState 0 0 (-1) [] M.empty M.empty M.empty M.empty
 
     
   minSize _ _ _ = 0
@@ -172,6 +177,7 @@ instance WidgetClass Taskbar where
                                        , taskbarWindows = windows
                                        , taskbarWindowStates = windowStates
                                        , taskbarWindowIcons = windowIcons
+                                       , taskbarWindowScaledIcons = windowScaledIcons
                                        , taskbarWindowScreens = windowScreens
                                        } w h screen = do
     let screenWindows = filter ((== Just screen) . flip M.lookup windowScreens) windows
@@ -215,10 +221,11 @@ instance WidgetClass Taskbar where
             h' = h - (borderV $ margin $ taskBorder style)
             mstate = M.lookup window windowStates
             micons = M.lookup window windowIcons
+            mscaledIconRef = M.lookup window windowScaledIcons
             x = dx + i*windowWidth
         
-        case (mstate, micons) of
-          (Just state, Just icons) -> do
+        case (mstate, micons, mscaledIconRef) of
+          (Just state, Just icons, Just scaledIconRef) -> do
             save
             drawBorder (taskBorder style) x 0 windowWidth h
             clip
@@ -228,29 +235,41 @@ instance WidgetClass Taskbar where
             
             restore
             
-            case bestIcon h' icons of
+            mscaledIcon <- liftIO $ readIORef scaledIconRef
+            scaledIcon <- case mscaledIcon of
+              Just (size, icon) | size == h' -> do
+                return $ Just icon
+              _ -> do
+                case bestIcon icons of
+                  Just icon -> do
+                    scaledIcon <- liftIO $ createSimilarSurface icon ContentColorAlpha h' h'
+                    renderWith scaledIcon $ do
+                      imageW <- imageSurfaceGetWidth icon
+                      imageH <- imageSurfaceGetHeight icon
+                      
+                      let scalef = (fromIntegral h')/(fromIntegral $ max imageW imageH)
+                      
+                      case True of
+                        _ | imageH < imageW -> translate 0 (fromIntegral (imageW-imageH)*scalef/2)
+                          | otherwise -> translate (fromIntegral (imageH-imageW)*scalef/2) 0
+                      
+                      downscaled scalef icon
+                      paint
+                    liftIO $ writeIORef scaledIconRef $ Just (h', scaledIcon)
+                    return $ Just scaledIcon
+                  
+                  Nothing -> return Nothing
+            
+            case scaledIcon of
               Just icon -> do
                 save
                 translate (fromIntegral $ x + leftBorder) (fromIntegral $ borderTop $ margin $ taskBorder style)
-                imageW <- imageSurfaceGetWidth icon
-                imageH <- imageSurfaceGetHeight icon
-                
-                let scalef = (fromIntegral h')/(fromIntegral $ max imageW imageH)
-                
-                case True of
-                  _ | imageH < imageW -> translate 0 (fromIntegral (imageW-imageH)*scalef/2)
-                    | otherwise -> translate (fromIntegral (imageH-imageW)*scalef/2) 0
-                
-                renderWithSimilarSurface ContentColorAlpha h' h' $ \surface -> do
-                  renderWith surface $ do
-                    downscaled scalef icon
-                    paint
-                  taskIconStyle style surface
-                
+                taskIconStyle style icon
                 paint
                 restore
               
-              Nothing -> return ()
+              Nothing ->
+                return ()
           
           _ -> return ()
       
@@ -258,7 +277,12 @@ instance WidgetClass Taskbar where
       
   
   handleMessage _ priv m = case (fromMessage m) of
-    Just (WindowListUpdate windows windowStates icons screens) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = icons, taskbarWindowScreens = screens}
+    Just (WindowListUpdate windows windowStates icons scaledIcons screens) -> priv {taskbarWindows = windows
+                                                                                   , taskbarWindowStates = windowStates
+                                                                                   , taskbarWindowIcons = icons
+                                                                                   , taskbarWindowScaledIcons = scaledIcons
+                                                                                   , taskbarWindowScreens = screens
+                                                                                   }
     Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
     Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current}
     Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
@@ -279,8 +303,8 @@ renderText font x y w h text = do
   moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2)
   showLayout layout
 
-bestIcon :: Int -> [(Int, Surface)] -> Maybe Surface
-bestIcon h icons = fmap snd . listToMaybe $ sortBy compareIcons icons
+bestIcon :: [(Int, Surface)] -> Maybe Surface
+bestIcon icons = fmap snd . listToMaybe $ sortBy compareIcons icons
   where
     compareIcons = flip (compare `on` fst)
 
@@ -292,19 +316,19 @@ windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDeskt
 taskbarRunner :: Phi -> Display -> IO ()
 taskbarRunner phi dispvar = do
   let screens = getScreens dispvar
-  (windows, states, icons, windowScreens) <- liftIO $ withDisplay dispvar $ \disp -> do
-    (windows, states, icons, windowScreens) <- getWindowStates disp screens (getAtoms dispvar) [] M.empty M.empty M.empty
+  (windows, states, icons, scaledIcons, windowScreens) <- liftIO $ withDisplay dispvar $ \disp -> do
+    (windows, states, icons, scaledIcons, windowScreens) <- getWindowStates disp screens (getAtoms dispvar) [] M.empty M.empty M.empty M.empty
     desktopCount <- getDesktopCount disp (getAtoms dispvar) 
     current <- getCurrentDesktop disp (getAtoms dispvar) 
     activeWindow <- getActiveWindow disp (getAtoms dispvar) 
-    sendMessage phi $ WindowListUpdate windows states icons windowScreens
+    sendMessage phi $ WindowListUpdate windows states icons scaledIcons windowScreens
     sendMessage phi $ DesktopCountUpdate desktopCount
     sendMessage phi $ CurrentDesktopUpdate current
     sendMessage phi $ ActiveWindowUpdate activeWindow
-    return (windows, states, icons, windowScreens)
+    return (windows, states, icons, scaledIcons, windowScreens)
   sendMessage phi Repaint
   
-  flip evalStateT (windows, states, icons, windowScreens) $ forever $ do
+  flip evalStateT (windows, states, icons, scaledIcons, windowScreens) $ forever $ do
     m <- receiveMessage phi
     case (fromMessage m) of
       Just event -> 
@@ -312,7 +336,7 @@ taskbarRunner phi dispvar = do
       _ ->
         return ()
 
-handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window Xlib.Rectangle) IO ()
+handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window (IORef (Maybe (Int, Surface))), M.Map Window Xlib.Rectangle) IO ()
 handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
   let atoms = getAtoms dispvar
   let screens = getScreens dispvar
@@ -342,23 +366,25 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
         sendMessage phi $ CurrentDesktopUpdate current
         sendMessage phi Repaint
       when (atom == atom_NET_CLIENT_LIST atoms) $ do
-        (windows, windowStates, icons, windowScreens) <- get
-        (windows', windowStates', icons', windowScreens') <- liftIO $ getWindowStates disp screens atoms windows windowStates icons windowScreens
+        (windows, windowStates, icons, scaledIcons, windowScreens) <- get
+        (windows', windowStates', icons', scaledIcons', windowScreens') <- liftIO $ getWindowStates disp screens atoms windows windowStates icons scaledIcons windowScreens
         
         when (windows /= windows') $ do
-          sendMessage phi $ WindowListUpdate windows' windowStates' icons' windowScreens'
+          sendMessage phi $ WindowListUpdate windows' windowStates' icons' scaledIcons' windowScreens'
           sendMessage phi Repaint
-          put (windows', windowStates', icons', windowScreens')
+          put (windows', windowStates', icons', scaledIcons', windowScreens')
     
       else do
-      (windows, windowStates, icons, windowScreens) <- get
+      (windows, windowStates, icons, scaledIcons, windowScreens) <- get
       when (elem window windows) $ do
         when (atom == atom_NET_WM_ICON atoms) $ do
           icon <- liftIO $ getWindowIcons disp atoms window
+          scaledIcon <- liftIO $ newIORef Nothing
           let icons' = M.insert window icon icons
-          sendMessage phi $ WindowListUpdate windows windowStates icons' windowScreens
+              scaledIcons' = M.insert window scaledIcon scaledIcons
+          sendMessage phi $ WindowListUpdate windows windowStates icons' scaledIcons' windowScreens
           sendMessage phi Repaint
-          put (windows, windowStates, icons', windowScreens)
+          put (windows, windowStates, icons', scaledIcons', windowScreens)
         
         when (atom /= atom_NET_WM_ICON atoms) $ do
           let windowState = M.lookup window windowStates
@@ -366,22 +392,22 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
           
           when (windowState /= (Just windowState')) $ do
             let windowStates' = M.insert window windowState' windowStates
-            sendMessage phi $ WindowListUpdate windows windowStates' icons windowScreens
+            sendMessage phi $ WindowListUpdate windows windowStates' icons scaledIcons windowScreens
             sendMessage phi Repaint
-            put (windows, windowStates', icons, windowScreens)
+            put (windows, windowStates', icons, scaledIcons, windowScreens)
 
 handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
   let screens = getScreens dispvar
 
-  (windows, windowStates, icons, windowScreens) <- get
+  (windows, windowStates, icons, scaledIcons, windowScreens) <- get
   when (elem window windows) $ withDisplay dispvar $ \disp -> do
     let screen = M.lookup window windowScreens
     screen' <- liftIO $ getWindowScreen disp screens window
     when (screen /= (Just screen')) $ do
       let windowScreens' = M.insert window screen' windowScreens
-      sendMessage phi $ WindowListUpdate windows windowStates icons windowScreens'
+      sendMessage phi $ WindowListUpdate windows windowStates icons scaledIcons windowScreens'
       sendMessage phi Repaint
-      put (windows, windowStates, icons, windowScreens')
+      put (windows, windowStates, icons, scaledIcons, windowScreens')
 
 handleEvent _ _ _ = return ()
 
@@ -399,20 +425,22 @@ getActiveWindow :: Xlib.Display -> Atoms -> IO Window
 getActiveWindow disp atoms =
   liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp
 
-getWindowStates :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> [Window] -> M.Map Window WindowState -> M.Map Window [(Int, Surface)] -> M.Map Window Xlib.Rectangle
-                   -> IO ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window Xlib.Rectangle)
-getWindowStates disp screens atoms oldWindows windowStates windowIcons windowScreens = do
+getWindowStates :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> [Window] -> M.Map Window WindowState -> M.Map Window [(Int, Surface)] -> M.Map Window (IORef (Maybe (Int, Surface))) -> M.Map Window Xlib.Rectangle
+                   -> IO ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)], M.Map Window (IORef (Maybe (Int, Surface))), M.Map Window Xlib.Rectangle)
+getWindowStates disp screens atoms oldWindows windowStates windowIcons windowScaledIcons windowScreens = do
   windows <- getWindowList disp atoms oldWindows
   
   let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
       windowIcons' = map (\w -> (w, M.lookup w windowIcons)) windows
+      windowScaledIcons' = map (\w -> (w, M.lookup w windowScaledIcons)) windows
       windowScreens' = map (\w -> (w, M.lookup w windowScreens)) windows
   
   newWindowStates <- mapM getWindowState' windowStates'
   newWindowIcons <- mapM getWindowIcons' windowIcons'
+  newWindowScaledIcons <- mapM getScaledIcons windowScaledIcons'
   newWindowScreens <- mapM getWindowScreen' windowScreens'
   
-  return (windows, M.fromList newWindowStates, M.fromList newWindowIcons, M.fromList newWindowScreens)
+  return (windows, M.fromList newWindowStates, M.fromList newWindowIcons, M.fromList newWindowScaledIcons, M.fromList newWindowScreens)
     where
       getWindowState' (window, Just windowState) = return (window, windowState) 
       getWindowState' (window, Nothing) = do
@@ -425,6 +453,9 @@ getWindowStates disp screens atoms oldWindows windowStates windowIcons windowScr
         icons <- getWindowIcons disp atoms window
         return (window, icons)
       
+      getScaledIcons (window, Just icon) = return (window, icon)
+      getScaledIcons (window, Nothing) = liftM2 (,) (return window) $ newIORef Nothing
+      
       getWindowScreen' (window, Just screen) = return (window, screen)
       getWindowScreen' (window, Nothing) = do
         screen <- getWindowScreen disp screens window