diff options
Diffstat (limited to 'lib/Phi')
| -rw-r--r-- | lib/Phi/Widget.hs | 16 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Taskbar.hs | 182 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 3 | ||||
| -rw-r--r-- | lib/Phi/X11/AtomList.hs | 1 |
4 files changed, 107 insertions, 95 deletions
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index 788abc2..25b08d4 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -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 diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs index 34ec0a5..f0a8196 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/Taskbar.hs @@ -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 - , 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 + 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 $ \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 - let geom = fmap windowGeometry . M.lookup window $ windowStates - geom' <- liftIO $ getWindowGeometry disp window + when (elem window windows) $ withDisplay dispvar $ \conn -> do + let geom = fmap windowGeometry . M.lookup window $ windowStates + 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 - - return $ if ret then Xlib.Rectangle x y width height else Xlib.Rectangle 0 0 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)) -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 diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index cc53cea..c66fa54 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -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 diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index d05bad2..5fbd98c 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/lib/Phi/X11/AtomList.hs @@ -16,6 +16,7 @@ atoms = [ "ATOM" , "UTF8_STRING" , "WM_NAME" , "WM_CLASS" + , "WM_TRANSIENT_FOR" , "MANAGER" , "_NET_WM_NAME" , "_NET_WM_WINDOW_TYPE" |