diff options
Diffstat (limited to 'lib/Phi/Widgets/X11/Taskbar.hs')
| -rw-r--r-- | lib/Phi/Widgets/X11/Taskbar.hs | 649 |
1 files changed, 649 insertions, 0 deletions
diff --git a/lib/Phi/Widgets/X11/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs new file mode 100644 index 0000000..07a7292 --- /dev/null +++ b/lib/Phi/Widgets/X11/Taskbar.hs @@ -0,0 +1,649 @@ +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} + +module Phi.Widgets.X11.Taskbar ( IconStyle + , idIconStyle + , desaturateIconStyle + , TaskStyle(..) + , DesktopStyle(..) + , TaskbarConfig(..) + , defaultTaskbarConfig + , Taskbar + , taskbar + ) where + +import Control.Arrow +import Control.Concurrent +import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Trans + +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 +import Data.Unique +import Data.Word +import qualified Data.Accessor.Basic as A +import qualified Data.Accessor.Container as AC +import qualified Data.Map as M + +import Foreign.C.Types + +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.XHB +import Graphics.XHB.Gen.Xproto + +import Codec.Binary.UTF8.String + +import Phi.Phi +import Phi.Types +import Phi.Border +import Phi.Widget +import Phi.X11 +import Phi.X11.Atoms +import Phi.X11.Util + + +newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () } +instance Eq IconStyle where + _ == _ = True + +idIconStyle :: IconStyle +idIconStyle = IconStyle $ flip withPatternForSurface setSource + +desaturateIconStyle :: Double -> IconStyle +desaturateIconStyle v = IconStyle $ \icon -> do + w <- imageSurfaceGetWidth icon + h <- imageSurfaceGetHeight icon + + renderWithSimilarSurface ContentColorAlpha w h $ \surface -> do + renderWith surface $ do + setOperator OperatorAdd + withPatternForSurface icon setSource + paint + + setSourceRGB 0 0 0 + paint + + setOperator OperatorHslSaturation + setSourceRGBA 0 0 0 (1-v) + paint + + setOperator OperatorDestIn + withPatternForSurface icon setSource + paint + + withPatternForSurface surface setSource + + +downscaled :: Double -> Surface -> Render () +downscaled s surface = do + case True of + _ | s < 0.5 -> do + w <- imageSurfaceGetWidth surface + h <- imageSurfaceGetHeight surface + + renderWithSimilarSurface ContentColorAlpha (ceiling (fromIntegral w*s)) (ceiling (fromIntegral h*s)) $ \surface' -> do + renderWith surface' $ do + scale 0.5 0.5 + downscaled (2*s) surface + paint + withPatternForSurface surface' setSource + + | otherwise -> do + scale s s + withPatternForSurface surface setSource + + +data TaskStyle = TaskStyle { taskFont :: !String + , taskColor :: !Color + , taskBorder :: !BorderConfig + , taskIconStyle :: !IconStyle + } deriving Eq + +data DesktopStyle = DesktopStyle { desktopFont :: !String + , desktopLabelWidth :: !Int + , desktopLabelGap :: !Int + , desktopColor :: !Color + , desktopBorder :: !BorderConfig + } + +data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int + , normalTaskStyle :: !TaskStyle + , activeTaskStyle :: !TaskStyle + , desktopStyle :: !(Maybe (DesktopStyle, DesktopStyle)) + } + +defaultStyle :: TaskStyle +defaultStyle = TaskStyle { taskFont = "Sans 8" + , taskColor = (0, 0, 0, 1) + , taskBorder = defaultBorderConfig { backgroundColor = (0.75, 0.75, 0.75, 1) } + , taskIconStyle = idIconStyle + } + +defaultTaskbarConfig :: TaskbarConfig +defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200 + , normalTaskStyle = defaultStyle + , activeTaskStyle = defaultStyle {taskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }} + , desktopStyle = Nothing + } + +data Taskbar = Taskbar TaskbarConfig + +data TaskbarState = TaskbarState { taskbarScreens :: ![Rectangle] + , taskbarActiveWindow :: !WINDOW + , taskbarDesktopCount :: !Int + , taskbarCurrentDesktop :: !Int + , taskbarDesktopNames :: ![String] + , taskbarWindows :: ![WINDOW] + , taskbarWindowStates :: !(M.Map WINDOW WindowState) + } deriving Eq + +data Icon = Icon !Unique !Int !Surface +instance Eq Icon where (Icon a _ _) == (Icon b _ _) = a == b +instance Show Icon where show (Icon _ size _) = "Icon { size = " ++ (show size) ++ " }" + +createIcon :: Int -> Surface -> IO Icon +createIcon size surface = do + id <- newUnique + return $ Icon id size surface + + +data WindowState = WindowState { windowTitle :: !String + , windowDesktop :: !Int + , windowVisible :: !Bool + , windowIcons :: ![Icon] + , windowGeometry :: !Rectangle + } deriving (Eq, Show) + +data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon)) + , renderWindowCached :: !(IOCache (String, Maybe Icon, TaskStyle, Int, Int) Surface) + } + +createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached +renderWindowCached' = A.fromSetGet (\a cache -> cache {renderWindowCached = a}) renderWindowCached + + +newtype DesktopCache = DesktopCache (IOCache () ()) + +emptyWindowCache :: WindowCache +emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon + , renderWindowCached = createIOCache doRenderWindow + } + +data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache) + , windowCaches :: !(M.Map WINDOW WindowCache) + } + +-- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant +liftT :: (Monad m) => A.T r s -> StateT s m a -> StateT r m a +liftT f m = do + s0 <- gets $ A.get f + (a,s1) <- lift $ runStateT m s0 + modify $ A.set f s1 + return a + +liftIOStateT :: (MonadIO m) => StateT s IO a -> StateT s m a +liftIOStateT m = do + s0 <- get + (a,s1) <- liftIO $ runStateT m s0 + put s1 + return a + +cached :: (MonadIO m, Eq a) => A.T s (IOCache a b) -> a -> StateT s m b +cached t = liftT t . liftIOStateT . runIOCache + +data TaskbarMessage = WindowListUpdate ![WINDOW] !(M.Map WINDOW WindowState) + | DesktopCountUpdate !Int + | CurrentDesktopUpdate !Int + | DesktopNamesUpdate ![String] + | ActiveWindowUpdate !WINDOW + deriving (Typeable, Show) + +instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) X11 where + initWidget (Taskbar _) phi dispvar screens = do + phi' <- dupPhi phi + forkIO $ taskbarRunner phi' dispvar + + return $ TaskbarState (map fst screens) (fromXid xidNone) 0 (-1) [] [] M.empty + + initCache _ = M.empty + + minSize _ _ _ _ = 0 + weight _ = 1 + + render (Taskbar config) TaskbarState { taskbarScreens = screens + , taskbarActiveWindow = activeWindow + , taskbarDesktopCount = desktopCount + , taskbarCurrentDesktop = currentDesktop + , taskbarDesktopNames = desktopNames + , taskbarWindows = windows + , taskbarWindowStates = windowStates + } _ _ w h screen = do + let windowScreen w = maximumBy (compare `on` unionArea (windowGeometry w)) screens + screenWindows = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows + desktopNumbers = take desktopCount $ zip [0..] (desktopNames ++ repeat "") + desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop . fst $ desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers + + windowCount = sum $ map (length . snd) $ desktops + + dstyle d = fmap (if d == currentDesktop then snd else fst) $ desktopStyle config + dlabelwidth d = fromMaybe 0 $ fmap desktopLabelWidth $ dstyle d + gap d ds = if null (snd $ desktops !! d) then 0 else desktopLabelGap ds + dleftwidth d = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border} + -> (borderLeft $ margin border) + (borderWidth border) + (borderLeft $ padding border) + + dlabelwidth d + gap d ds) $ dstyle d + dwidth d = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border} + -> (borderH $ margin border) + 2*(borderWidth border) + (borderH $ padding border) + + dlabelwidth d + gap d ds) $ dstyle d + + desktopsWidth = sum $ map (dwidth . fst) desktopNumbers + windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount) + + surface <- liftIO $ createImageSurface FormatARGB32 w h + cache <- liftM (M.filterWithKey $ \w _ -> elem w windows) get + cache' <- renderWith surface $ flip execStateT cache $ do + lift $ do + setOperator OperatorClear + paint + + setOperator OperatorOver + + flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do + let dstyle' = dstyle (fst desktop) + dx = dleftwidth (fst desktop) + (sum $ map dwidth $ take (fst desktop) [0..]) + nwindows*windowWidth + + case dstyle' of + Just ds -> do + let (r, g, b, a) = desktopColor ds + lift $ do + save + drawBorder (desktopBorder ds) (dx - dleftwidth (fst desktop)) 0 (dwidth (fst desktop) + windowWidth * length desktopWindows) h + clip + + setSourceRGBA r g b a + renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth (fst desktop) - gap (fst desktop) ds)) 0 (dlabelwidth (fst desktop)) h $ snd desktop + + restore + + forM_ (zip [0..] desktopWindows) $ \(i, window) -> do + let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config + h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds) + mstate = M.lookup window windowStates + x = dx + i*windowWidth + y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds) + + case mstate of + Just state -> do + windowSurface <- liftT (AC.mapDefault emptyWindowCache window) . liftIOStateT $ renderWindow state style windowWidth h' + lift $ do + save + translate (fromIntegral $ x - 5) (fromIntegral $ y - 5) + withPatternForSurface windowSurface setSource + paint + restore + + Nothing -> return () + + _ -> return () + + return $ nwindows + length desktopWindows + put cache' + + return [(True, SurfaceSlice 0 surface)] + + + handleMessage _ priv m = case (fromMessage m) of + Just (WindowListUpdate windows windowStates) -> priv { taskbarWindows = windows + , taskbarWindowStates = windowStates + } + Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count} + Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current} + Just (DesktopNamesUpdate names) -> priv {taskbarDesktopNames = names} + Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window} + _ -> case (fromMessage m) of + Just (UpdateScreens screens) -> priv {taskbarScreens = map fst screens} + _ -> priv + + +renderText :: String -> Int -> Int -> Int -> Int -> String -> Render () +renderText font x y w h text = do + layout <- createLayout "" + (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do + layoutSetMarkup layout $ "<span font='" ++ font ++ "'>" ++ (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 + +renderWindow :: WindowState -> TaskStyle -> Int -> Int -> StateT WindowCache IO Surface +renderWindow state style w h = do + let h' = h - (borderV $ margin $ taskBorder style) + + scaledIcon <- cached createScaledIconCached' (windowIcons state, h') + cached renderWindowCached' (windowTitle state, scaledIcon, style, w, h) + +doRenderWindow :: (String, Maybe Icon, TaskStyle, Int, Int) -> IO Surface +doRenderWindow (title, scaledIcon, style, w, h) = do + let (r, g, b, a) = taskColor style + leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style) + rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style) + h' = h - (borderV $ margin $ taskBorder style) + + surface <- createImageSurface FormatARGB32 (w+10) (h+10) + renderWith surface $ do + translate 5 5 + + save + drawBorder (taskBorder style) 0 0 w h + clip + + setSourceRGBA r g b a + renderText (taskFont style) (fromIntegral (leftBorder + h' + 3)) 0 (w - leftBorder - h' - 3 - rightBorder) h title + + restore + + case scaledIcon of + Just (Icon _ _ icon) -> do + save + translate (fromIntegral leftBorder) (fromIntegral . borderTop . margin . taskBorder $ style) + withIconStyle (taskIconStyle style) icon + paint + restore + + _ -> return () + + return surface + + +createScaledIcon :: ([Icon], Int) -> IO (Maybe Icon) +createScaledIcon (icons, h) = do + case bestIcon of + Just (Icon _ _ icon) -> do + scaledIcon <- createSimilarSurface icon ContentColorAlpha h h + renderWith scaledIcon $ do + imageW <- imageSurfaceGetWidth icon + imageH <- imageSurfaceGetHeight icon + + let scalef = (fromIntegral h)/(fromIntegral $ max imageW imageH) + + case () of + _ | imageH < imageW -> translate 0 (fromIntegral (imageW-imageH)*scalef/2) + | otherwise -> translate (fromIntegral (imageH-imageW)*scalef/2) 0 + + downscaled scalef icon + paint + fmap Just $ createIcon h scaledIcon + + _ -> return Nothing + + where + bestIcon = listToMaybe $ sortBy compareIcons icons + compareIcons = flip (compare `on` (\(Icon _ size _) -> size)) + + +windowOnDesktop :: Int -> WindowState -> Bool +windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state) + + +taskbarRunner :: Phi -> X11 -> IO () +taskbarRunner phi x11 = do + (windows, states) <- liftIO $ do + (windows, states) <- getWindowStates x11 M.empty + desktopCount <- getDesktopCount x11 + current <- getCurrentDesktop x11 + names <- getDesktopNames x11 + activeWindow <- getActiveWindow x11 + sendMessage phi $ WindowListUpdate windows states + sendMessage phi $ DesktopCountUpdate desktopCount + sendMessage phi $ CurrentDesktopUpdate current + sendMessage phi $ DesktopNamesUpdate names + sendMessage phi $ ActiveWindowUpdate activeWindow + return (windows, states) + sendMessage phi Repaint + + flip evalStateT (windows, states) $ forever $ do + m <- receiveMessage phi + case (fromMessage m) of + Just (XEvent event) -> + handleEvent phi x11 event + _ -> + return () + + +handleEvent :: Phi -> X11 -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handleEvent phi x11 event = + case (fromEvent event) of + Just e -> handlePropertyNotifyEvent phi x11 e + Nothing -> case (fromEvent event) of + Just e -> handleConfigureNotifyEvent phi x11 e + Nothing -> return () + +handlePropertyNotifyEvent :: Phi -> X11 -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handlePropertyNotifyEvent phi x11 MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do + let atoms = x11Atoms x11 + rootwin = root_SCREEN . x11Screen $ x11 + + when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW + , atom_NET_NUMBER_OF_DESKTOPS + , atom_NET_CURRENT_DESKTOP + , atom_NET_DESKTOP_NAMES + , atom_NET_CLIENT_LIST + , atom_NET_WM_ICON + , atomWM_NAME + , atom_NET_WM_NAME + , atom_NET_WM_DESKTOP + , atom_NET_WM_STATE + ]) $ do + if (window == rootwin) + then do + when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do + activeWindow <- liftIO $ getActiveWindow x11 + sendMessage phi $ ActiveWindowUpdate activeWindow + sendMessage phi Repaint + when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do + desktopCount <- liftIO $ getDesktopCount x11 + sendMessage phi $ DesktopCountUpdate desktopCount + sendMessage phi Repaint + when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do + current <- liftIO $ getCurrentDesktop x11 + sendMessage phi $ CurrentDesktopUpdate current + sendMessage phi Repaint + when (atom == atom_NET_DESKTOP_NAMES atoms) $ do + names <- liftIO $ getDesktopNames x11 + sendMessage phi $ DesktopNamesUpdate names + sendMessage phi Repaint + when (atom == atom_NET_CLIENT_LIST atoms) $ do + (windows, windowStates) <- get + (windows', windowStates') <- liftIO $ getWindowStates x11 windowStates + + when (windows /= windows') $ do + sendMessage phi $ WindowListUpdate windows' windowStates' + sendMessage phi Repaint + put (windows', windowStates') + + else do + (windows, windowStates) <- get + when (elem window windows) $ do + case () of + _ | (atom == atom_NET_WM_ICON atoms) -> do + icons <- liftIO $ getWindowIcons x11 window + let windowStates' = M.update (\state -> Just state {windowIcons = icons}) window windowStates + sendMessage phi $ WindowListUpdate windows windowStates' + sendMessage phi Repaint + put (windows, windowStates') + + | otherwise -> do + (name, desktop, visible) <- liftIO $ getWindowInfo x11 window + let mwindowState = M.lookup window windowStates + case mwindowState of + Just windowState -> do + let windowState' = windowState {windowTitle = name, windowDesktop = desktop, windowVisible = visible} + + when (windowState /= windowState') $ do + let windowStates' = M.insert window windowState' windowStates + sendMessage phi $ WindowListUpdate windows windowStates' + sendMessage phi Repaint + put (windows, windowStates') + Nothing -> + return () + + +handleConfigureNotifyEvent :: Phi -> X11 -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handleConfigureNotifyEvent phi x11 MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do + let conn = x11Connection x11 + (windows, windowStates) <- get + when (elem window windows) $ do + let geom = fmap windowGeometry . M.lookup window $ windowStates + geom' <- liftIO $ getWindowGeometry x11 window + when (geom /= (Just geom')) $ do + let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates + sendMessage phi $ WindowListUpdate windows windowStates' + sendMessage phi Repaint + put (windows, windowStates') + + +getDesktopCount :: X11 -> IO Int +getDesktopCount x11 = + liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_NUMBER_OF_DESKTOPS . x11Atoms $ x11) + +getCurrentDesktop :: X11 -> IO Int +getCurrentDesktop x11 = + liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CURRENT_DESKTOP . x11Atoms $ x11) + +getDesktopNames :: X11 -> IO [String] +getDesktopNames x11 = + liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_DESKTOP_NAMES . x11Atoms $ x11) + where + break' l = case dropWhile (== 0) l of + [] -> [] + l' -> w : break' l'' + where (w, l'') = break (== 0) l' + +getActiveWindow :: X11 -> IO WINDOW +getActiveWindow x11 = + liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_ACTIVE_WINDOW . x11Atoms $ x11) + +getWindowStates :: X11 -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState) +getWindowStates x11 windowStates = do + windows <- getWindowList x11 + + let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows + + newWindowStates <- mapM getWindowState' windowStates' + + return (windows, M.fromList newWindowStates) + where + getWindowState' (window, Just windowState) = return (window, windowState) + getWindowState' (window, Nothing) = do + changeWindowAttributes (x11Connection x11) window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] + windowState <- getWindowState x11 window + return (window, windowState) + +getWindowState :: X11 -> WINDOW -> IO WindowState +getWindowState x11 window = do + (name, workspace, visible) <- getWindowInfo x11 window + icons <- getWindowIcons x11 window + geom <- getWindowGeometry x11 window + + return $ WindowState { windowTitle = name + , windowDesktop = workspace + , windowVisible = visible + , windowIcons = icons + , windowGeometry = geom + } + +getWindowInfo :: X11 -> WINDOW -> IO (String, Int, Bool) +getWindowInfo x11 window = do + let conn = x11Connection x11 + atoms = x11Atoms x11 + netwmname <- liftM (fmap (decode . map fromIntegral)) $ getProperty8 conn window (atom_NET_WM_NAME atoms) + wmname <- case netwmname of + Just name -> return name + Nothing -> liftM (map unsignedChr . fromMaybe []) $ getProperty8 conn window (atom_NET_WM_NAME atoms) + + workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ getProperty32 conn window (atom_NET_WM_DESKTOP atoms) + visible <- showWindow conn atoms window + + return (wmname, workspace, visible) + where + unsignedChr = chr . fromIntegral + +getWindowIcons :: X11 -> WINDOW -> IO [Icon] +getWindowIcons x11 window = getProperty32 (x11Connection x11) window (atom_NET_WM_ICON . x11Atoms $ x11) >>= readIcons . fromMaybe [] + + +readIcons :: [Word32] -> IO [Icon] +readIcons (width:height:iconData) = do + if ((fromIntegral $ length iconData) < (width*height)) then return [] else do + let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData + surface <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height) + surfaceData <- imageSurfaceGetPixels surface :: IO (SurfaceData Int Word32) + forM_ (zip thisIcon [0..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e + + surfaceMarkDirty surface + + liftM2 (:) (createIcon (fromIntegral $ max width height) surface) (readIcons rest) + +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 + + +getWindowGeometry :: X11 -> WINDOW -> IO Rectangle +getWindowGeometry x11 window = + getGeometry (x11Connection x11) (fromXid . toXid $ window) >>= getReply >>= + return . ((const $ Rectangle 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> Rectangle (fi x) (fi y) (fi width) (fi height))) + where + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral + +showWindow :: Connection -> Atoms -> WINDOW -> IO Bool +showWindow conn atoms window = do + states <- liftM (map (fromXid . toXid) . fromMaybe []) $ getProperty32 conn window (atom_NET_WM_STATE atoms) + transientFor <- liftM (map fromIntegral . fromMaybe []) $ getProperty32 conn window (atomWM_TRANSIENT_FOR atoms) + windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap (fromXid . toXid) . join . fmap listToMaybe) $ + getProperty32 conn window (atom_NET_WM_STATE atoms) + + return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states + , transientFor /= [] && transientFor /= [0] + , elem windowType $ map ($ atoms) [ atom_NET_WM_WINDOW_TYPE_DOCK + , atom_NET_WM_WINDOW_TYPE_DESKTOP + , atom_NET_WM_WINDOW_TYPE_TOOLBAR + , atom_NET_WM_WINDOW_TYPE_MENU + , atom_NET_WM_WINDOW_TYPE_SPLASH + ] + ] + + +getWindowList :: X11 -> IO [WINDOW] +getWindowList x11 = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CLIENT_LIST . x11Atoms $ x11) + +taskbar :: TaskbarConfig -> Taskbar +taskbar = Taskbar |