neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Cache scaled icons in taskbar

Browse source
This commit is contained in:
Matthias Schiffer 2011-07-18 00:59:40 +02:00
parent bb316caf3b
commit 0b92eda1bb
1 changed files with 85 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

139
lib/Phi/Widgets/Taskbar.hs
View file

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