633 lines
27 KiB
Haskell
633 lines
27 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
|
|
|
|
module Phi.Widgets.Taskbar ( IconStyle
|
|
, idIconStyle
|
|
, desaturateIconStyle
|
|
, TaskStyle(..)
|
|
, DesktopStyle(..)
|
|
, TaskbarConfig(..)
|
|
, defaultTaskbarConfig
|
|
, Taskbar
|
|
, taskbar
|
|
) where
|
|
|
|
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.X11.Xlib (Window)
|
|
import qualified Graphics.X11.Xlib as Xlib
|
|
import qualified Graphics.X11.Xlib.Extras as XExtras
|
|
|
|
import Codec.Binary.UTF8.String
|
|
|
|
import Phi.Phi
|
|
import Phi.Types
|
|
import Phi.Border
|
|
import Phi.Widget
|
|
import Phi.X11.Atoms
|
|
|
|
|
|
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 :: ![Xlib.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 :: !Xlib.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 ![Xlib.Window] !(M.Map Window WindowState)
|
|
| DesktopCountUpdate !Int
|
|
| CurrentDesktopUpdate !Int
|
|
| DesktopNamesUpdate ![String]
|
|
| ActiveWindowUpdate !Window
|
|
deriving (Typeable, Show)
|
|
|
|
instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
|
|
initWidget (Taskbar _) phi dispvar screens = do
|
|
phi' <- dupPhi phi
|
|
forkIO $ taskbarRunner phi' dispvar
|
|
|
|
return $ TaskbarState (map fst screens) 0 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 -> Display -> IO ()
|
|
taskbarRunner phi dispvar = do
|
|
(windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do
|
|
(windows, states) <- getWindowStates disp (getAtoms dispvar) M.empty
|
|
desktopCount <- getDesktopCount disp (getAtoms dispvar)
|
|
current <- getCurrentDesktop disp (getAtoms dispvar)
|
|
names <- getDesktopNames disp (getAtoms dispvar)
|
|
activeWindow <- getActiveWindow disp (getAtoms dispvar)
|
|
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 event ->
|
|
handleEvent phi dispvar event
|
|
_ ->
|
|
return ()
|
|
|
|
handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
|
|
handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
|
|
let atoms = getAtoms dispvar
|
|
|
|
when (elem atom $ Xlib.wM_NAME : 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
|
|
, atom_NET_WM_NAME
|
|
, atom_NET_WM_DESKTOP
|
|
, atom_NET_WM_STATE
|
|
]) $ withDisplay dispvar $ \disp -> do
|
|
let rootwin = Xlib.defaultRootWindow disp
|
|
if (window == rootwin)
|
|
then do
|
|
when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do
|
|
activeWindow <- liftIO $ getActiveWindow disp atoms
|
|
sendMessage phi $ ActiveWindowUpdate activeWindow
|
|
sendMessage phi Repaint
|
|
when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
|
|
desktopCount <- liftIO $ getDesktopCount disp atoms
|
|
sendMessage phi $ DesktopCountUpdate desktopCount
|
|
sendMessage phi Repaint
|
|
when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do
|
|
current <- liftIO $ getCurrentDesktop disp atoms
|
|
sendMessage phi $ CurrentDesktopUpdate current
|
|
sendMessage phi Repaint
|
|
when (atom == atom_NET_DESKTOP_NAMES atoms) $ do
|
|
names <- liftIO $ getDesktopNames disp atoms
|
|
sendMessage phi $ DesktopNamesUpdate names
|
|
sendMessage phi Repaint
|
|
when (atom == atom_NET_CLIENT_LIST atoms) $ do
|
|
(windows, windowStates) <- get
|
|
(windows', windowStates') <- liftIO $ getWindowStates disp atoms 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 disp atoms 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 disp atoms 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 ()
|
|
|
|
handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
|
|
(windows, windowStates) <- get
|
|
when (elem window windows) $ withDisplay dispvar $ \disp -> do
|
|
let geom = fmap windowGeometry . M.lookup window $ windowStates
|
|
geom' <- liftIO $ getWindowGeometry disp 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')
|
|
|
|
handleEvent _ _ _ = return ()
|
|
|
|
|
|
getDesktopCount :: Xlib.Display -> Atoms -> IO Int
|
|
getDesktopCount disp atoms =
|
|
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_NUMBER_OF_DESKTOPS atoms) $ Xlib.defaultRootWindow disp
|
|
|
|
getCurrentDesktop :: Xlib.Display -> Atoms -> IO Int
|
|
getCurrentDesktop disp atoms =
|
|
liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_CURRENT_DESKTOP atoms) $ Xlib.defaultRootWindow disp
|
|
|
|
getDesktopNames :: Xlib.Display -> Atoms -> IO [String]
|
|
getDesktopNames disp atoms =
|
|
liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ XExtras.getWindowProperty8 disp (atom_NET_DESKTOP_NAMES atoms) $ Xlib.defaultRootWindow disp
|
|
where
|
|
break' l = case dropWhile (== 0) l of
|
|
[] -> []
|
|
l' -> w : break' l''
|
|
where (w, l'') = break (== 0) l'
|
|
|
|
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 -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
|
|
getWindowStates disp atoms windowStates = do
|
|
windows <- getWindowList disp atoms
|
|
|
|
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
|
|
Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask
|
|
windowState <- getWindowState disp atoms window
|
|
return (window, windowState)
|
|
|
|
getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
|
|
getWindowState disp atoms window = do
|
|
(name, workspace, visible) <- getWindowInfo disp atoms window
|
|
icons <- getWindowIcons disp atoms window
|
|
geom <- getWindowGeometry disp window
|
|
|
|
return $ WindowState { windowTitle = name
|
|
, windowDesktop = workspace
|
|
, windowVisible = visible
|
|
, windowIcons = icons
|
|
, windowGeometry = geom
|
|
}
|
|
|
|
getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool)
|
|
getWindowInfo disp atoms window = do
|
|
netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window
|
|
wmname <- case netwmname of
|
|
Just name -> return name
|
|
Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp Xlib.wM_NAME window
|
|
|
|
workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
|
|
visible <- showWindow disp atoms window
|
|
|
|
return (wmname, workspace, visible)
|
|
where
|
|
unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
|
|
|
|
getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Icon]
|
|
getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
|
|
|
|
|
|
readIcons :: [CLong] -> 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 :: Xlib.Display -> Window -> IO Xlib.Rectangle
|
|
getWindowGeometry disp window = flip catch (\_ -> return $ Xlib.Rectangle 0 0 0 0) $ do
|
|
(_, _, _, width, height, _, _) <- Xlib.getGeometry disp window
|
|
(ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0
|
|
|
|
return $ if ret then Xlib.Rectangle x y width height else Xlib.Rectangle 0 0 0 0
|
|
|
|
|
|
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
|
|
transientForHint <- XExtras.getTransientForHint disp window
|
|
windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap fromIntegral . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
|
|
|
|
return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states
|
|
, transientForHint /= Nothing
|
|
, 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 :: Xlib.Display -> Atoms -> IO [Window]
|
|
getWindowList disp atoms = liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp
|
|
|
|
taskbar :: TaskbarConfig -> Taskbar
|
|
taskbar = Taskbar
|