summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/Widgets/Taskbar.hs139
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