diff options
Diffstat (limited to 'lib/Phi')
| -rw-r--r-- | lib/Phi/Border.hs | 2 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Taskbar.hs | 193 | ||||
| -rw-r--r-- | lib/Phi/X11/AtomList.hs | 1 |
3 files changed, 159 insertions, 37 deletions
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs index 0576f27..7de66ea 100644 --- a/lib/Phi/Border.hs +++ b/lib/Phi/Border.hs @@ -2,6 +2,8 @@ module Phi.Border ( BorderWidth(..) , simpleBorderWidth + , borderH + , borderV , BorderConfig(..) , defaultBorderConfig , drawBorder diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs index aa75258..c48321c 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/Taskbar.hs @@ -10,9 +10,14 @@ import Control.Monad import Control.Monad.State import Control.Monad.Trans +import Data.Array.MArray +import Data.Bits import Data.Char +import Data.Function +import Data.List import Data.Maybe import Data.Typeable +import Data.Word import qualified Data.Map as M import Foreign.C.Types @@ -21,6 +26,7 @@ import Graphics.Rendering.Cairo import Graphics.Rendering.Pango.Cairo import Graphics.Rendering.Pango.Enums (PangoRectangle(..)) import Graphics.Rendering.Pango.Layout +import Graphics.Rendering.Pango.Font import Graphics.X11.Xlib (Window) import qualified Graphics.X11.Xlib as Xlib @@ -35,14 +41,16 @@ import Phi.Widget import Phi.X11.Atoms -data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int - , showDesktops :: !Bool - , taskBorder :: !BorderConfig - , activeTaskBorder :: !BorderConfig +data TaskbarConfig = TaskbarConfig { taskbarFont :: !String + , taskMaxSize :: !Int + , showDesktops :: !Bool + , taskBorder :: !BorderConfig + , activeTaskBorder :: !BorderConfig } deriving Show defaultTaskbarConfig :: TaskbarConfig -defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150 +defaultTaskbarConfig = TaskbarConfig { taskbarFont = "Sans 7" + , taskMaxSize = 150 , showDesktops = False , taskBorder = defaultBorderConfig , activeTaskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) } @@ -50,10 +58,14 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150 data Taskbar = Taskbar TaskbarConfig deriving Show +instance Show Surface where + show _ = "Surface <?>" + data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window , taskbarDesktopCount :: !Int , taskbarWindows :: ![Window] , taskbarWindowStates :: !(M.Map Window WindowState) + , taskbarWindowIcons :: !(M.Map Window [Surface]) } deriving Show data WindowState = WindowState { windowTitle :: !String @@ -61,7 +73,7 @@ data WindowState = WindowState { windowTitle :: !String , windowVisible :: !Bool } deriving (Show, Eq) -data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) +data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) (M.Map Window [Surface]) | DesktopCountUpdate Int | ActiveWindowUpdate Window deriving (Show, Typeable) @@ -72,13 +84,13 @@ instance WidgetClass Taskbar where initWidget (Taskbar _) phi dispvar = do forkIO $ taskbarRunner phi dispvar - return $ TaskbarState 0 0 [] M.empty + return $ TaskbarState 0 0 [] M.empty M.empty minSize _ = 0 weight _ = 1 - render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates} w h = do + render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = windowIcons} w h = do let desktopWindows = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) windows)) $ take desktopCount [0..] windowCount = sum $ map (length . snd) $ desktopWindows when (windowCount /= 0) $ do @@ -86,46 +98,107 @@ instance WidgetClass Taskbar where forM_ (zip [0..] $ join $ map snd desktopWindows) $ \(i, window) -> do let border = if window == activeWindow then activeTaskBorder config else taskBorder config - drawBorder border (i*windowWidth) 0 windowWidth h + leftBorder = (borderLeft $ margin border) + (borderWidth border) + (borderLeft $ padding border) + rightBorder = (borderRight $ margin border) + (borderWidth border) + (borderRight $ padding border) + h' = h - (borderV $ margin border) + mstate = M.lookup window windowStates + micons = M.lookup window windowIcons + + case (mstate, micons) of + (Just state, Just icons) -> do + save + drawBorder border (i*windowWidth) 0 windowWidth h + clip + + setSourceRGB 1 1 1 + renderText config (fromIntegral (i*windowWidth + leftBorder + h' + 3)) 0 (windowWidth - leftBorder - h' - 3 - rightBorder) h $ windowTitle state + + restore + + icon' <- liftIO $ bestIcon h' icons + case icon' of + Just icon -> withPatternForSurface icon $ \pattern -> do + save + translate (fromIntegral $ i*windowWidth + leftBorder) (fromIntegral $ borderTop $ margin border) + imageW <- imageSurfaceGetWidth icon + imageH <- imageSurfaceGetHeight icon + let scalef = (fromIntegral h')/(fromIntegral $ max imageW imageH) + scale scalef scalef + setSource pattern + paint + restore + + Nothing -> return () + + _ -> return () + handleMessage _ priv m = case (fromMessage m) of - Just (WindowListUpdate windows windowStates) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates} + Just (WindowListUpdate windows windowStates icons) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = icons} Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count} Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window} _ -> priv +renderText :: TaskbarConfig -> Int -> Int -> Int -> Int -> String -> Render () +renderText config x y w h text = do + layout <- createLayout "" + (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do + layoutSetMarkup layout $ "<span font='" ++ (taskbarFont config) ++ "'>" ++ (escapeMarkup text) ++ "</span>" + layoutSetWidth layout $ Just $ fromIntegral w + layoutSetEllipsize layout EllipsizeEnd + + layoutGetExtents layout + + + moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2) + showLayout layout + +bestIcon :: Int -> [Surface] -> IO (Maybe Surface) +bestIcon h icons = do + imageSizes <- forM icons $ \icon -> liftM2 (,) (return icon) $ liftM2 max (imageSurfaceGetWidth icon) (imageSurfaceGetHeight icon) + let sortedIcons = sortBy compareIcons imageSizes + return $ findBest sortedIcons + where + compareIcons a b = (compare `on` snd) b a + + findBest (a1:a2:ax) = if (snd a2) < h then Just $ fst a1 else findBest (a2:ax) + findBest [a] = Just $ fst a + findBest [] = Nothing + + windowOnDesktop :: Int -> WindowState -> Bool windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state) taskbarRunner :: Phi -> Display -> IO () taskbarRunner phi dispvar = do - (windows, tasks) <- liftIO $ withDisplay dispvar $ \disp -> do - (windows, tasks) <- getWindowStates disp (getAtoms dispvar) [] M.empty + (windows, states, icons) <- liftIO $ withDisplay dispvar $ \disp -> do + (windows, states, icons) <- getWindowStates disp (getAtoms dispvar) [] M.empty M.empty desktopCount <- getDesktopCount disp (getAtoms dispvar) activeWindow <- getActiveWindow disp (getAtoms dispvar) - sendMessage phi $ WindowListUpdate windows tasks + sendMessage phi $ WindowListUpdate windows states icons sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi $ ActiveWindowUpdate activeWindow - return (windows, tasks) + return (windows, states, icons) sendMessage phi Repaint - flip evalStateT (windows, tasks) $ forever $ do + flip evalStateT (windows, states, icons) $ forever $ do m <- receiveMessage phi case (fromMessage m) of Just event@XExtras.PropertyEvent {} -> handlePropertyUpdate phi dispvar event _ -> return () - -handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO () + +handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [Surface]) IO () handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do let atoms = getAtoms dispvar when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW , atom_NET_NUMBER_OF_DESKTOPS , atom_NET_CLIENT_LIST + , atom_NET_WM_ICON , atom_NET_WM_NAME , atomWM_NAME , atom_NET_WM_DESKTOP @@ -143,25 +216,33 @@ handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi Repaint when (atom == atom_NET_CLIENT_LIST atoms) $ do - (windows, windowStates) <- get - (windows', windowStates') <- liftIO $ getWindowStates disp atoms windows windowStates + (windows, windowStates, icons) <- get + (windows', windowStates', icons') <- liftIO $ getWindowStates disp atoms windows windowStates icons - when (windows /= windows' || windowStates /= windowStates') $ do - sendMessage phi $ WindowListUpdate windows' windowStates' + when (windows /= windows') $ do + sendMessage phi $ WindowListUpdate windows' windowStates' icons' sendMessage phi Repaint - put (windows', windowStates') + put (windows', windowStates', icons') else do - (windows, windowStates) <- get + (windows, windowStates, icons) <- get when (elem window windows) $ do - let windowState = M.lookup window windowStates - windowState' <- liftIO $ getWindowState disp atoms window - - when (windowState /= (Just windowState')) $ do - let windowStates' = M.insert window windowState' windowStates - sendMessage phi $ WindowListUpdate windows windowStates' + when (atom == atom_NET_WM_ICON atoms) $ do + icon <- liftIO $ getWindowIcons disp atoms window + let icons' = M.insert window icon icons + sendMessage phi $ WindowListUpdate windows windowStates icons' sendMessage phi Repaint - put (windows, windowStates') + put (windows, windowStates, icons') + + when (atom /= atom_NET_WM_ICON atoms) $ do + let windowState = M.lookup window windowStates + windowState' <- liftIO $ getWindowState disp atoms window + + when (windowState /= (Just windowState')) $ do + let windowStates' = M.insert window windowState' windowStates + sendMessage phi $ WindowListUpdate windows windowStates' icons + sendMessage phi Repaint + put (windows, windowStates', icons) getDesktopCount :: Xlib.Display -> Atoms -> IO Int getDesktopCount disp atoms = @@ -171,24 +252,29 @@ 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 -> Atoms -> [Window] -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState) -getWindowStates disp atoms oldWindows windowStates = do +getWindowStates :: Xlib.Display -> Atoms -> [Window] -> M.Map Window WindowState -> M.Map Window [Surface] -> IO ([Window], M.Map Window WindowState, M.Map Window [Surface]) +getWindowStates disp atoms oldWindows windowStates windowIcons = 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 newWindowStates <- mapM getWindowState' windowStates' + newWindowIcons <- mapM getWindowIcons' windowIcons' - return (windows, M.fromList newWindowStates) + return (windows, M.fromList newWindowStates, M.fromList newWindowIcons) where - rootwin = Xlib.defaultRootWindow disp - getWindowState' (window, Just windowState) = return (window, windowState) getWindowState' (window, Nothing) = do windowState <- getWindowState disp atoms window return (window, windowState) + + getWindowIcons' (window, Just icons) = return (window, icons) + getWindowIcons' (window, Nothing) = do + icons <- getWindowIcons disp atoms window + return (window, icons) -getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState +getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState getWindowState disp atoms window = do Xlib.selectInput disp window Xlib.propertyChangeMask netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window @@ -204,6 +290,39 @@ getWindowState disp atoms window = do where unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar)) +getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Surface] +getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe [] + +readIcons :: [CLong] -> IO [Surface] +readIcons (width:height:iconData) = do + if ((fromIntegral $ length iconData) < (width*height)) then return [] else do + let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData + icon <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height) + surfaceData <- imageSurfaceGetPixels icon :: IO (SurfaceData Int Word32) + forM_ (zip thisIcon [1..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e + + surfaceMarkDirty icon + + moreIcons <- readIcons rest + return $ icon:moreIcons + +readIcons _ = return [] + +premultiply :: Word32 -> Word32 +premultiply c = a .|. r .|. g .|. b + where + amask = 0xFF000000 + rmask = 0x00FF0000 + gmask = 0x0000FF00 + bmask = 0x000000FF + + a = c .&. amask + pm mask = (((c .&. mask) * (a `shiftR` 24)) `div` 0xFF) .&. mask + + r = pm rmask + g = pm gmask + b = pm bmask + showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool showWindow disp atoms window = do states <- liftM (map fromIntegral . fromMaybe []) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window @@ -219,7 +338,7 @@ showWindow disp atoms window = do , atom_NET_WM_WINDOW_TYPE_SPLASH ] ] - + getWindowList :: Xlib.Display -> Atoms -> [Window] -> IO [Window] getWindowList disp atoms windows = do diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index d1abb24..dc5eac1 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/lib/Phi/X11/AtomList.hs @@ -12,6 +12,7 @@ atoms = [ "UTF8_STRING" , "_NET_WM_WINDOW_TYPE_MENU" , "_NET_WM_WINDOW_TYPE_SPLASH" , "_NET_WM_DESKTOP" + , "_NET_WM_ICON" , "_NET_WM_STATE" , "_NET_WM_STATE_SKIP_PAGER" , "_NET_WM_STATE_SKIP_TASKBAR" |