Cache scaled icons in taskbar
This commit is contained in:
parent
bb316caf3b
commit
0b92eda1bb
1 changed files with 85 additions and 54 deletions
|
|
@ -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
|
||||
|
|
@ -140,6 +141,7 @@ data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
|
|||
, 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
|
||||
|
||||
|
|
@ -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,10 +235,15 @@ 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
|
||||
save
|
||||
translate (fromIntegral $ x + leftBorder) (fromIntegral $ borderTop $ margin $ taskBorder style)
|
||||
scaledIcon <- liftIO $ createSimilarSurface icon ContentColorAlpha h' h'
|
||||
renderWith scaledIcon $ do
|
||||
imageW <- imageSurfaceGetWidth icon
|
||||
imageH <- imageSurfaceGetHeight icon
|
||||
|
||||
|
|
@ -241,16 +253,23 @@ instance WidgetClass Taskbar where
|
|||
_ | 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
|
||||
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)
|
||||
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
|
||||
|
|
|
|||
Reference in a new issue