Use new XHB backend for Taskbar

This commit is contained in:
Matthias Schiffer 2011-09-07 19:35:59 +02:00
parent 15d9304e05
commit 6746d60e3f
6 changed files with 113 additions and 101 deletions

View file

@ -37,6 +37,8 @@ import Graphics.Rendering.Cairo
import Phi.Phi
import Phi.X11.Atoms
import Debug.Trace
data Display = Display !Connection !Atoms
@ -56,19 +58,19 @@ data XMessage = UpdateScreens [(RECTANGLE, WINDOW)] deriving (Show, Typeable)
unionArea :: RECTANGLE -> RECTANGLE -> Int
unionArea a b = fromIntegral $ uw*uh
unionArea a b = uw*uh
where
uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
uh = max 0 $ (min ay2 by2) - (max ay1 by1)
uw = max 0 $ (min ax2 bx2) - fromIntegral (max ax1 bx1)
uh = max 0 $ (min ay2 by2) - fromIntegral (max ay1 by1)
MkRECTANGLE ax1 ay1 aw ah = a
MkRECTANGLE bx1 by1 bw bh = b
ax2 = ax1 + fromIntegral aw
ay2 = ay1 + fromIntegral ah
ax2 = fromIntegral ax1 + fromIntegral aw
ay2 = fromIntegral ay1 + fromIntegral ah
bx2 = bx1 + fromIntegral bw
by2 = by1 + fromIntegral bh
bx2 = fromIntegral bx1 + fromIntegral bw
by2 = fromIntegral by1 + fromIntegral bh
data SurfaceSlice = SurfaceSlice !Int !Surface

View file

@ -11,6 +11,7 @@ module Phi.Widgets.Taskbar ( IconStyle
, taskbar
) where
import Control.Arrow
import Control.Concurrent
import Control.Monad
import Control.Monad.State.Strict
@ -38,9 +39,8 @@ 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 Graphics.XHB
import Graphics.XHB.Gen.Xproto
import Codec.Binary.UTF8.String
@ -49,6 +49,7 @@ import Phi.Types
import Phi.Border
import Phi.Widget
import Phi.X11.Atoms
import Phi.X11.Util
newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () }
@ -137,13 +138,13 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
data Taskbar = Taskbar TaskbarConfig
data TaskbarState = TaskbarState { taskbarScreens :: ![Xlib.Rectangle]
, taskbarActiveWindow :: !Window
data TaskbarState = TaskbarState { taskbarScreens :: ![RECTANGLE]
, taskbarActiveWindow :: !WINDOW
, taskbarDesktopCount :: !Int
, taskbarCurrentDesktop :: !Int
, taskbarDesktopNames :: ![String]
, taskbarWindows :: ![Window]
, taskbarWindowStates :: !(M.Map Window WindowState)
, taskbarWindows :: ![WINDOW]
, taskbarWindowStates :: !(M.Map WINDOW WindowState)
} deriving Eq
data Icon = Icon !Unique !Int !Surface
@ -160,7 +161,7 @@ data WindowState = WindowState { windowTitle :: !String
, windowDesktop :: !Int
, windowVisible :: !Bool
, windowIcons :: ![Icon]
, windowGeometry :: !Xlib.Rectangle
, windowGeometry :: !RECTANGLE
} deriving (Eq, Show)
data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon))
@ -179,7 +180,7 @@ emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createSc
}
data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache)
, windowCaches :: !(M.Map Window WindowCache)
, windowCaches :: !(M.Map WINDOW WindowCache)
}
-- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant
@ -200,19 +201,19 @@ liftIOStateT m = do
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)
data TaskbarMessage = WindowListUpdate ![WINDOW] !(M.Map WINDOW WindowState)
| DesktopCountUpdate !Int
| CurrentDesktopUpdate !Int
| DesktopNamesUpdate ![String]
| ActiveWindowUpdate !Window
| ActiveWindowUpdate !WINDOW
deriving (Typeable, Show)
instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
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
return $ TaskbarState (map fst screens) (fromXid xidNone) 0 (-1) [] [] M.empty
initCache _ = M.empty
@ -416,47 +417,57 @@ taskbarRunner phi dispvar = do
flip evalStateT (windows, states) $ forever $ do
m <- receiveMessage phi
case (fromMessage m) of
Just event ->
Just (XEvent 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
handleEvent :: Phi -> Display -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
handleEvent phi dispvar event =
case (fromEvent event) of
Just e -> handlePropertyNotifyEvent phi dispvar e
Nothing -> case (fromEvent event) of
Just e -> handleConfigureNotifyEvent phi dispvar e
Nothing -> return ()
handlePropertyNotifyEvent :: Phi -> Display -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do
let atoms = getAtoms dispvar
when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW
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
]) $ withDisplay dispvar $ \disp -> do
let rootwin = Xlib.defaultRootWindow disp
]) $ withDisplay dispvar $ \conn -> do
let rootwin = getRoot conn
if (window == rootwin)
then do
when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do
activeWindow <- liftIO $ getActiveWindow disp atoms
activeWindow <- liftIO $ getActiveWindow conn atoms
sendMessage phi $ ActiveWindowUpdate activeWindow
sendMessage phi Repaint
when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
desktopCount <- liftIO $ getDesktopCount disp atoms
desktopCount <- liftIO $ getDesktopCount conn atoms
sendMessage phi $ DesktopCountUpdate desktopCount
sendMessage phi Repaint
when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do
current <- liftIO $ getCurrentDesktop disp atoms
current <- liftIO $ getCurrentDesktop conn atoms
sendMessage phi $ CurrentDesktopUpdate current
sendMessage phi Repaint
when (atom == atom_NET_DESKTOP_NAMES atoms) $ do
names <- liftIO $ getDesktopNames disp atoms
names <- liftIO $ getDesktopNames conn 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
(windows', windowStates') <- liftIO $ getWindowStates conn atoms windowStates
when (windows /= windows') $ do
sendMessage phi $ WindowListUpdate windows' windowStates'
@ -468,14 +479,14 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
when (elem window windows) $ do
case () of
_ | (atom == atom_NET_WM_ICON atoms) -> do
icons <- liftIO $ getWindowIcons disp atoms window
icons <- liftIO $ getWindowIcons conn 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
(name, desktop, visible) <- liftIO $ getWindowInfo conn atoms window
let mwindowState = M.lookup window windowStates
case mwindowState of
Just windowState -> do
@ -489,44 +500,44 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
Nothing ->
return ()
handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
handleConfigureNotifyEvent :: Phi -> Display -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
handleConfigureNotifyEvent phi dispvar MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do
(windows, windowStates) <- get
when (elem window windows) $ withDisplay dispvar $ \disp -> do
when (elem window windows) $ withDisplay dispvar $ \conn -> do
let geom = fmap windowGeometry . M.lookup window $ windowStates
geom' <- liftIO $ getWindowGeometry disp window
geom' <- liftIO $ getWindowGeometry conn 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 :: Connection -> Atoms -> IO Int
getDesktopCount conn atoms =
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_NUMBER_OF_DESKTOPS atoms)
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 :: Connection -> Atoms -> IO Int
getCurrentDesktop conn atoms =
liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_CURRENT_DESKTOP atoms)
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
getDesktopNames :: Connection -> Atoms -> IO [String]
getDesktopNames conn atoms =
liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 conn (getRoot conn) (atom_NET_DESKTOP_NAMES atoms)
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
getActiveWindow :: Connection -> Atoms -> IO WINDOW
getActiveWindow conn atoms =
liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_ACTIVE_WINDOW atoms)
getWindowStates :: Xlib.Display -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
getWindowStates disp atoms windowStates = do
windows <- getWindowList disp atoms
getWindowStates :: Connection -> Atoms -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState)
getWindowStates conn atoms windowStates = do
windows <- getWindowList conn atoms
let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
@ -536,15 +547,15 @@ getWindowStates disp atoms windowStates = do
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
changeWindowAttributes conn window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
windowState <- getWindowState conn 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
getWindowState :: Connection -> Atoms -> WINDOW -> IO WindowState
getWindowState conn atoms window = do
(name, workspace, visible) <- getWindowInfo conn atoms window
icons <- getWindowIcons conn atoms window
geom <- getWindowGeometry conn window
return $ WindowState { windowTitle = name
, windowDesktop = workspace
@ -553,25 +564,25 @@ getWindowState disp atoms window = do
, 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
getWindowInfo :: Connection -> Atoms -> WINDOW -> IO (String, Int, Bool)
getWindowInfo conn atoms window = do
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 []) $ XExtras.getWindowProperty8 disp Xlib.wM_NAME window
Nothing -> liftM (map unsignedChr . fromMaybe []) $ getProperty8 conn window (atom_NET_WM_NAME atoms)
workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
visible <- showWindow disp atoms window
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 . (fromIntegral :: (CChar -> CUChar))
unsignedChr = chr . fromIntegral
getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Icon]
getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
getWindowIcons :: Connection -> Atoms -> WINDOW -> IO [Icon]
getWindowIcons conn atoms window = getProperty32 conn window (atom_NET_WM_ICON atoms) >>= readIcons . fromMaybe []
readIcons :: [CLong] -> IO [Icon]
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
@ -601,22 +612,19 @@ premultiply c = a .|. r .|. g .|. b
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
getWindowGeometry :: Connection -> WINDOW -> IO RECTANGLE
getWindowGeometry conn window =
getGeometry conn (fromXid . toXid $ window) >>= getReply >>= return . ((const $ MkRECTANGLE 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> MkRECTANGLE x y width height))
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
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
, transientForHint /= Nothing
, 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
@ -626,8 +634,8 @@ showWindow disp atoms window = do
]
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
getWindowList :: Connection -> Atoms -> IO [WINDOW]
getWindowList conn atoms = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 conn (getRoot conn) (atom_NET_CLIENT_LIST atoms)
taskbar :: TaskbarConfig -> Taskbar
taskbar = Taskbar

View file

@ -191,7 +191,7 @@ handleMessage conn xcb m = do
return ()
handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c ()
handleEvent conn xcb event = do
handleEvent conn xcb event =
case (fromEvent event) of
Just e -> handlePropertyNotifyEvent conn xcb e
Nothing -> case (fromEvent event) of
@ -253,6 +253,7 @@ handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyE
sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
sendMessage phi Repaint
handleConfigureNotifyEvent _ _ = return ()
receiveEvents :: Phi -> Connection -> IO ()
receiveEvents phi conn = do

View file

@ -16,6 +16,7 @@ atoms = [ "ATOM"
, "UTF8_STRING"
, "WM_NAME"
, "WM_CLASS"
, "WM_TRANSIENT_FOR"
, "MANAGER"
, "_NET_WM_NAME"
, "_NET_WM_WINDOW_TYPE"

View file

@ -14,8 +14,8 @@ library
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb,
cairo, pango, unix, data-accessor, arrows, CacheArrow
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
Phi.Widgets.AlphaBox, Phi.Widgets.Clock
-- , Phi.Widgets.Taskbar, Phi.Widgets.Systray
Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar
-- , Phi.Widgets.Systray
other-modules: Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB
include-dirs: include
hs-source-dirs: lib

View file

@ -6,13 +6,13 @@ import Phi.X11
import Phi.Widgets.AlphaBox
import Phi.Widgets.Clock
--import Phi.Widgets.Taskbar
import Phi.Widgets.Taskbar
--import Phi.Widgets.Systray
main :: IO ()
main = do
runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom } $ alphaBox 0.9 $ {- theTaskbar <~> brightBorder theSystray <~> -} brightBorder theClock
runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom } $ alphaBox 0.9 $ theTaskbar <~> {-brightBorder theSystray <~> -} brightBorder theClock
where
normalTaskBorder = BorderConfig (BorderWidth (-1) (-3) (-1) 7) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.8) (0.45, 0.45, 0.45, 0.8) 5 0
activeTaskBorder = normalTaskBorder { borderColor = (1, 1, 1, 0.8)
@ -25,7 +25,7 @@ main = do
}
currentDesktopBorder = normalDesktopBorder { backgroundColor = (0.2, 0.2, 0.2, 0.9)
}
{-taskStyle = TaskStyle { taskFont = "Sans 7"
taskStyle = TaskStyle { taskFont = "Sans 7"
, taskColor = (1, 1, 1, 1)
, taskBorder = normalTaskBorder
, taskIconStyle = idIconStyle
@ -46,7 +46,7 @@ main = do
, desktopStyle = Just (normalDesktopStyle, currentDesktopStyle)
}
theSystray = systray-}
--theSystray = systray
theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
, lineSpacing = (-3)