diff options
Diffstat (limited to 'lib/Phi/Widgets')
| -rw-r--r-- | lib/Phi/Widgets/Taskbar.hs | 139 |
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 |