From 6746d60e3f23a2abe4abe8bb0d26821b8faef8bd Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Wed, 7 Sep 2011 19:35:59 +0200 Subject: [PATCH 01/10] Use new XHB backend for Taskbar --- lib/Phi/Widget.hs | 16 ++-- lib/Phi/Widgets/Taskbar.hs | 182 +++++++++++++++++++------------------ lib/Phi/X11.hs | 3 +- lib/Phi/X11/AtomList.hs | 1 + phi.cabal | 4 +- src/Phi.hs | 8 +- 6 files changed, 113 insertions(+), 101 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" diff --git a/phi.cabal b/phi.cabal index 75d633f..9d055f4 100644 --- a/phi.cabal +++ b/phi.cabal @@ -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 diff --git a/src/Phi.hs b/src/Phi.hs index 6ffff61..c5ba113 100644 --- a/src/Phi.hs +++ b/src/Phi.hs @@ -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 = "%R\n%A %d %B" , lineSpacing = (-3) From aadf8d978032db0305045d3cf9f2ef08cdec6197 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Wed, 7 Sep 2011 22:33:07 +0200 Subject: [PATCH 02/10] Add a short delay waiting for messages before starting rendering --- lib/Phi/X11.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index c66fa54..a4fd5c1 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -143,11 +143,13 @@ runPhi xconfig config widget = do forever $ do available <- messageAvailable phi - unless available $ do - repaint <- gets phiRepaint - when repaint $ do - updatePanels conn xcb - modify $ \state -> state {phiRepaint = False} + repaint <- gets phiRepaint + when (not available && repaint) $ liftIO $ threadDelay 30000 + + available <- messageAvailable phi + when (not available && repaint) $ do + updatePanels conn xcb + modify $ \state -> state {phiRepaint = False} message <- receiveMessage phi handleMessage conn xcb message From 234388ef387c92cc72f35cb309b9d0beea8d3a1a Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Thu, 8 Sep 2011 01:27:01 +0200 Subject: [PATCH 03/10] First render, then map panel windows --- lib/Phi/Widget.hs | 2 -- lib/Phi/X11.hs | 10 ++++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index 25b08d4..a598887 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -37,8 +37,6 @@ import Graphics.Rendering.Cairo import Phi.Phi import Phi.X11.Atoms -import Debug.Trace - data Display = Display !Connection !Atoms diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index a4fd5c1..7e0bfff 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -124,7 +124,7 @@ runPhi xconfig config widget = do } PhiState { phiRootImage = bg , phiPanels = [] - , phiRepaint = True + , phiRepaint = False , phiShutdown = False , phiShutdownHold = 0 , phiWidgetState = initialState @@ -133,12 +133,14 @@ runPhi xconfig config widget = do panels <- mapM (\(screen, window) -> createPanel conn window screen) screenPanels - forM_ panels $ \panel -> do - setPanelProperties conn panel - liftIO $ mapWindow conn (panelWindow panel) + forM_ panels $ setPanelProperties conn modify $ \state -> state { phiPanels = panels } + updatePanels conn xcb + + forM_ panels $ liftIO . mapWindow conn . panelWindow + liftIO $ forkIO $ receiveEvents phi conn forever $ do From 4d519acbd48fa400f09e4705251a0dbf45c6876e Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Thu, 8 Sep 2011 19:15:23 +0200 Subject: [PATCH 04/10] Core is independent of X11 now --- lib/Phi/Border.hs | 8 +- lib/Phi/Widget.hs | 86 ++++---- lib/Phi/Widgets/AlphaBox.hs | 8 +- lib/Phi/Widgets/Clock.hs | 8 +- lib/Phi/Widgets/{ => X11}/Systray.hs | 4 +- lib/Phi/Widgets/{ => X11}/Taskbar.hs | 156 +++++++------- lib/Phi/X11.hs | 306 +++++++++++++++------------ lib/Phi/X11/AtomList.hs | 2 +- phi.cabal | 2 +- src/Phi.hs | 6 +- 10 files changed, 308 insertions(+), 278 deletions(-) rename lib/Phi/Widgets/{ => X11}/Systray.hs (99%) rename lib/Phi/Widgets/{ => X11}/Taskbar.hs (83%) diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs index ca5e515..2e1e008 100644 --- a/lib/Phi/Border.hs +++ b/lib/Phi/Border.hs @@ -56,11 +56,11 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0 , borderWeight = 1 } -data Border w s c = (Widget w s c) => Border !BorderConfig !w +data Border w s c d = (Widget w s c d) => Border !BorderConfig !w -data BorderCache w s c = (Widget w s c) => BorderCache !c +data BorderCache w s c d = (Widget w s c d) => BorderCache !c -instance Eq s => Widget (Border w s c) s (BorderCache w s c) where +instance (Eq s, Display d) => Widget (Border w s c d) s (BorderCache w s c d) d where initWidget (Border _ w) = initWidget w initCache (Border _ w) = BorderCache $ initCache w @@ -165,5 +165,5 @@ roundRectangle x y width height radius = do arc (x + radius) (y + radius) radius pi (pi*3/2) closePath -border :: (Widget w s c) => BorderConfig -> w -> Border w s c +border :: (Widget w s c d) => BorderConfig -> w -> Border w s c d border = Border diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index a598887..3687630 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} -module Phi.Widget ( XEvent(..) +module Phi.Widget ( Rectangle(..) , Display(..) - , withDisplay - , getAtoms - , XMessage(..) , unionArea , SurfaceSlice(..) , Widget(..) @@ -23,7 +20,6 @@ module Phi.Widget ( XEvent(..) import Control.Arrow import Control.Arrow.Transformer import Control.CacheArrow -import Control.Concurrent.MVar import Control.Monad import Control.Monad.State.Strict hiding (lift) import Control.Monad.IO.Class @@ -31,67 +27,57 @@ import Control.Monad.IO.Class import Data.Maybe import Data.Typeable -import Graphics.XHB import Graphics.Rendering.Cairo import Phi.Phi import Phi.X11.Atoms -data Display = Display !Connection !Atoms +data Rectangle = Rectangle { rect_x :: !Int + , rect_y :: !Int + , rect_width :: !Int + , rect_height :: !Int + } deriving (Show, Eq) -newtype XEvent = XEvent SomeEvent deriving Typeable - -instance Show XEvent where - show _ = "XEvent (..)" +class Display d where + type Window d :: * -withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a -withDisplay (Display conn _) f = f conn - -getAtoms :: Display -> Atoms -getAtoms (Display _ atoms) = atoms - -data XMessage = UpdateScreens [(RECTANGLE, WINDOW)] deriving (Show, Typeable) - - -unionArea :: RECTANGLE -> RECTANGLE -> Int +unionArea :: Rectangle -> Rectangle -> Int unionArea a b = uw*uh where - uw = max 0 $ (min ax2 bx2) - fromIntegral (max ax1 bx1) - uh = max 0 $ (min ay2 by2) - fromIntegral (max ay1 by1) + uw = max 0 $ (min ax2 bx2) - (max ax1 bx1) + uh = max 0 $ (min ay2 by2) - (max ay1 by1) - MkRECTANGLE ax1 ay1 aw ah = a - MkRECTANGLE bx1 by1 bw bh = b + Rectangle ax1 ay1 aw ah = a + Rectangle bx1 by1 bw bh = b - ax2 = fromIntegral ax1 + fromIntegral aw - ay2 = fromIntegral ay1 + fromIntegral ah + ax2 = ax1 + aw + ay2 = ay1 + ah - bx2 = fromIntegral bx1 + fromIntegral bw - by2 = fromIntegral by1 + fromIntegral bh + bx2 = bx1 + bw + by2 = by1 + bh data SurfaceSlice = SurfaceSlice !Int !Surface -class Eq s => Widget w s c | w -> s, w -> c where - initWidget :: w -> Phi -> Display -> [(RECTANGLE, WINDOW)] -> IO s +class (Eq s, Display d) => Widget w s c d | w -> s, w -> c, w -> d where + initWidget :: w -> Phi -> d -> [(Rectangle, Window d)] -> IO s initCache :: w -> c - minSize :: w -> s -> Int -> RECTANGLE -> Int + minSize :: w -> s -> Int -> Rectangle -> Int weight :: w -> Float weight _ = 0 - render :: w -> s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT c IO [(Bool, SurfaceSlice)] + render :: w -> s -> Int -> Int -> Int -> Int -> Rectangle -> StateT c IO [(Bool, SurfaceSlice)] handleMessage :: w -> s -> Message -> s handleMessage _ priv _ = priv -deriving instance Eq RECTANGLE - type IOCache = CacheArrow (Kleisli IO) -type RenderCache s = IOCache (s, Int, Int, Int, Int, RECTANGLE) Surface +type RenderCache s = IOCache (s, Int, Int, Int, Int, Rectangle) Surface createIOCache :: Eq a => (a -> IO b) -> IOCache a b createIOCache = lift . Kleisli @@ -103,8 +89,8 @@ runIOCache a = do put cache' return b -createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ()) - -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, RECTANGLE) Surface +createRenderCache :: (s -> Int -> Int -> Int -> Int -> Rectangle -> Render ()) + -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Rectangle) Surface createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do surface <- createImageSurface FormatARGB32 w h renderWith surface $ do @@ -114,22 +100,22 @@ createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do f state x y w h screen return surface -renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)] +renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> Rectangle -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)] renderCached state x y w h screen = do cache <- get (surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen) put cache' return [(updated, SurfaceSlice 0 surf)] -data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b +data CompoundWidget a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundWidget !a !b -data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb -deriving instance Eq (CompoundState a sa ca b sb cb) +data CompoundState a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundState !sa !sb +deriving instance Eq (CompoundState a sa ca b sb cb d) -data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb +data CompoundCache a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundCache !ca !cb -instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where +instance Display d => Widget (CompoundWidget a sa ca b sb cb d) (CompoundState a sa ca b sb cb d) (CompoundCache a sa ca b sb cb d) d where initWidget (CompoundWidget a b) phi disp screens = liftM2 CompoundState (initWidget a phi disp screens) (initWidget b phi disp screens) initCache (CompoundWidget a b) = CompoundCache (initCache a) (initCache b) @@ -154,15 +140,15 @@ instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) handleMessage (CompoundWidget a b) (CompoundState sa sb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) -weight' :: (Widget a sa ca) => a -> Float +weight' :: (Widget a sa ca d) => a -> Float weight' = max 0 . weight -(<~>) :: (Widget a sa ca, Widget b sb cb) => a -> b -> CompoundWidget a sa ca b sb cb +(<~>) :: (Widget a sa ca d, Widget b sb cb d) => a -> b -> CompoundWidget a sa ca b sb cb d a <~> b = CompoundWidget a b -data Separator = Separator !Int !Float deriving (Show, Eq) +data Separator d = Separator !Int !Float deriving (Show, Eq) -instance Widget Separator () (RenderCache ()) where +instance Display d => Widget (Separator d) () (RenderCache ()) d where initWidget _ _ _ _ = return () initCache _ = createRenderCache $ \_ _ _ _ _ _ -> do setOperator OperatorClear @@ -173,5 +159,5 @@ instance Widget Separator () (RenderCache ()) where render _ = renderCached -separator :: Int -> Float -> Separator +separator :: Int -> Float -> Separator d separator = Separator diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs index 6f989ea..59f8aea 100644 --- a/lib/Phi/Widgets/AlphaBox.hs +++ b/lib/Phi/Widgets/AlphaBox.hs @@ -13,11 +13,11 @@ import Control.Monad.State.Strict import Graphics.Rendering.Cairo -data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w +data AlphaBox w s c d = (Widget w s c d) => AlphaBox !Double !w -data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c +data AlphaBoxCache w s c d = (Widget w s c d) => AlphaBoxCache !c -instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where +instance (Eq s, Display d) => Widget (AlphaBox w s c d) s (AlphaBoxCache w s c d) d where initWidget (AlphaBox _ w) = initWidget w initCache (AlphaBox _ w) = AlphaBoxCache $ initCache w @@ -47,6 +47,6 @@ instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where handleMessage (AlphaBox _ w) = handleMessage w -alphaBox :: (Widget w s c) => Double -> w -> AlphaBox w s c +alphaBox :: (Widget w s c d) => Double -> w -> AlphaBox w s c d alphaBox = AlphaBox diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs index 9282432..26b777f 100644 --- a/lib/Phi/Widgets/Clock.hs +++ b/lib/Phi/Widgets/Clock.hs @@ -34,7 +34,7 @@ data ClockConfig = ClockConfig { clockFormat :: !String defaultClockConfig :: ClockConfig defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50 -data Clock = Clock !ClockConfig deriving (Show, Eq) +data Clock d = Clock !ClockConfig deriving (Show, Eq) deriving instance Eq ZonedTime @@ -42,7 +42,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq) data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable) -instance Widget Clock ClockState (RenderCache ClockState) where +instance Display d => Widget (Clock d) ClockState (RenderCache ClockState) d where initWidget (Clock _) phi _ _ = do forkIO $ forever $ do time <- getZonedTime @@ -85,6 +85,6 @@ instance Widget Clock ClockState (RenderCache ClockState) where _ -> priv -clock :: ClockConfig -> Clock +clock :: ClockConfig -> Clock d clock config = do - Clock config \ No newline at end of file + Clock config diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/X11/Systray.hs similarity index 99% rename from lib/Phi/Widgets/Systray.hs rename to lib/Phi/Widgets/X11/Systray.hs index 27a5e34..fffb181 100644 --- a/lib/Phi/Widgets/Systray.hs +++ b/lib/Phi/Widgets/X11/Systray.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} -module Phi.Widgets.Systray ( systray - ) where +module Phi.Widgets.X11.Systray ( systray + ) where import Control.Concurrent import Control.Monad diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs similarity index 83% rename from lib/Phi/Widgets/Taskbar.hs rename to lib/Phi/Widgets/X11/Taskbar.hs index f0a8196..07a7292 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/X11/Taskbar.hs @@ -1,15 +1,15 @@ {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} -module Phi.Widgets.Taskbar ( IconStyle - , idIconStyle - , desaturateIconStyle - , TaskStyle(..) - , DesktopStyle(..) - , TaskbarConfig(..) - , defaultTaskbarConfig - , Taskbar - , taskbar - ) where +module Phi.Widgets.X11.Taskbar ( IconStyle + , idIconStyle + , desaturateIconStyle + , TaskStyle(..) + , DesktopStyle(..) + , TaskbarConfig(..) + , defaultTaskbarConfig + , Taskbar + , taskbar + ) where import Control.Arrow import Control.Concurrent @@ -48,6 +48,7 @@ import Phi.Phi import Phi.Types import Phi.Border import Phi.Widget +import Phi.X11 import Phi.X11.Atoms import Phi.X11.Util @@ -138,7 +139,7 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200 data Taskbar = Taskbar TaskbarConfig -data TaskbarState = TaskbarState { taskbarScreens :: ![RECTANGLE] +data TaskbarState = TaskbarState { taskbarScreens :: ![Rectangle] , taskbarActiveWindow :: !WINDOW , taskbarDesktopCount :: !Int , taskbarCurrentDesktop :: !Int @@ -161,7 +162,7 @@ data WindowState = WindowState { windowTitle :: !String , windowDesktop :: !Int , windowVisible :: !Bool , windowIcons :: ![Icon] - , windowGeometry :: !RECTANGLE + , windowGeometry :: !Rectangle } deriving (Eq, Show) data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon)) @@ -208,7 +209,7 @@ data TaskbarMessage = WindowListUpdate ![WINDOW] !(M.Map WINDOW WindowState) | ActiveWindowUpdate !WINDOW deriving (Typeable, Show) -instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) where +instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) X11 where initWidget (Taskbar _) phi dispvar screens = do phi' <- dupPhi phi forkIO $ taskbarRunner phi' dispvar @@ -398,14 +399,14 @@ 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) +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 @@ -418,23 +419,24 @@ taskbarRunner phi dispvar = do m <- receiveMessage phi case (fromMessage m) of Just (XEvent event) -> - handleEvent phi dispvar event + handleEvent phi x11 event _ -> return () -handleEvent :: Phi -> Display -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handleEvent phi dispvar event = +handleEvent :: Phi -> X11 -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handleEvent phi x11 event = case (fromEvent event) of - Just e -> handlePropertyNotifyEvent phi dispvar e + Just e -> handlePropertyNotifyEvent phi x11 e Nothing -> case (fromEvent event) of - Just e -> handleConfigureNotifyEvent phi dispvar e + Just e -> handleConfigureNotifyEvent phi x11 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 - +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 @@ -445,29 +447,28 @@ handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotify , atom_NET_WM_NAME , atom_NET_WM_DESKTOP , atom_NET_WM_STATE - ]) $ withDisplay dispvar $ \conn -> do - let rootwin = getRoot conn + ]) $ do if (window == rootwin) then do when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do - activeWindow <- liftIO $ getActiveWindow conn atoms + activeWindow <- liftIO $ getActiveWindow x11 sendMessage phi $ ActiveWindowUpdate activeWindow sendMessage phi Repaint when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do - desktopCount <- liftIO $ getDesktopCount conn atoms + desktopCount <- liftIO $ getDesktopCount x11 sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi Repaint when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do - current <- liftIO $ getCurrentDesktop conn atoms + current <- liftIO $ getCurrentDesktop x11 sendMessage phi $ CurrentDesktopUpdate current sendMessage phi Repaint when (atom == atom_NET_DESKTOP_NAMES atoms) $ do - names <- liftIO $ getDesktopNames conn atoms + 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 conn atoms windowStates + (windows', windowStates') <- liftIO $ getWindowStates x11 windowStates when (windows /= windows') $ do sendMessage phi $ WindowListUpdate windows' windowStates' @@ -479,14 +480,14 @@ handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotify when (elem window windows) $ do case () of _ | (atom == atom_NET_WM_ICON atoms) -> do - icons <- liftIO $ getWindowIcons conn atoms window + 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 conn atoms window + (name, desktop, visible) <- liftIO $ getWindowInfo x11 window let mwindowState = M.lookup window windowStates case mwindowState of Just windowState -> do @@ -501,12 +502,13 @@ handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotify return () -handleConfigureNotifyEvent :: Phi -> Display -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handleConfigureNotifyEvent phi dispvar MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do +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) $ withDisplay dispvar $ \conn -> do + when (elem window windows) $ do let geom = fmap windowGeometry . M.lookup window $ windowStates - geom' <- liftIO $ getWindowGeometry conn window + 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' @@ -514,30 +516,30 @@ handleConfigureNotifyEvent phi dispvar MkConfigureNotifyEvent {window_ConfigureN put (windows, windowStates') -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 :: 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 :: Connection -> Atoms -> IO Int -getCurrentDesktop conn atoms = - liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_CURRENT_DESKTOP atoms) +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 :: Connection -> Atoms -> IO [String] -getDesktopNames conn atoms = - liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 conn (getRoot conn) (atom_NET_DESKTOP_NAMES atoms) +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 :: Connection -> Atoms -> IO WINDOW -getActiveWindow conn atoms = - liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_ACTIVE_WINDOW atoms) +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 :: Connection -> Atoms -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState) -getWindowStates conn atoms windowStates = do - windows <- getWindowList conn atoms +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 @@ -547,15 +549,15 @@ getWindowStates conn atoms windowStates = do where getWindowState' (window, Just windowState) = return (window, windowState) getWindowState' (window, Nothing) = do - changeWindowAttributes conn window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] - windowState <- getWindowState conn atoms window + changeWindowAttributes (x11Connection x11) window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] + windowState <- getWindowState x11 window return (window, windowState) -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 +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 @@ -564,8 +566,10 @@ getWindowState conn atoms window = do , windowGeometry = geom } -getWindowInfo :: Connection -> Atoms -> WINDOW -> IO (String, Int, Bool) -getWindowInfo conn atoms window = do +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 @@ -578,8 +582,8 @@ getWindowInfo conn atoms window = do where unsignedChr = chr . fromIntegral -getWindowIcons :: Connection -> Atoms -> WINDOW -> IO [Icon] -getWindowIcons conn atoms window = getProperty32 conn window (atom_NET_WM_ICON atoms) >>= readIcons . fromMaybe [] +getWindowIcons :: X11 -> WINDOW -> IO [Icon] +getWindowIcons x11 window = getProperty32 (x11Connection x11) window (atom_NET_WM_ICON . x11Atoms $ x11) >>= readIcons . fromMaybe [] readIcons :: [Word32] -> IO [Icon] @@ -612,9 +616,13 @@ premultiply c = a .|. r .|. g .|. b b = pm bmask -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)) +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 @@ -634,8 +642,8 @@ showWindow conn atoms window = do ] -getWindowList :: Connection -> Atoms -> IO [WINDOW] -getWindowList conn atoms = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 conn (getRoot conn) (atom_NET_CLIENT_LIST atoms) +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 diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 7e0bfff..713b162 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, TypeFamilies, FlexibleContexts, DeriveDataTypeable #-} -module Phi.X11 ( XConfig(..) +module Phi.X11 ( X11(..) + , XEvent(..) + , XMessage(..) + , XConfig(..) , defaultXConfig , runPhi ) where -import Graphics.XHB +import Graphics.XHB hiding (Window) +import qualified Graphics.XHB.Connection.Open as CO import Graphics.XHB.Gen.Xinerama -import Graphics.XHB.Gen.Xproto +import Graphics.XHB.Gen.Xproto hiding (Window) import Graphics.Rendering.Cairo @@ -36,33 +40,51 @@ import Phi.Phi import Phi.X11.Util import qualified Phi.Types as Phi import qualified Phi.Panel as Panel -import qualified Phi.Widget as Widget -import Phi.Widget hiding (Display, handleMessage) +import qualified Phi.Widget as Widget (handleMessage) +import Phi.Widget hiding (handleMessage) import Phi.X11.Atoms -data XConfig = XConfig { phiXScreenInfo :: !(Connection -> IO [RECTANGLE]) +data X11 = X11 { x11Connection :: !Connection + , x11Atoms :: !Atoms + , x11Screen :: !SCREEN + } + +instance Display X11 where + type Window X11 = WINDOW + + +newtype XEvent = XEvent SomeEvent deriving Typeable + +instance Show XEvent where + show _ = "XEvent (..)" + +data XMessage = UpdateScreens [(Rectangle, WINDOW)] deriving (Show, Typeable) + + +data XConfig = XConfig { phiXScreenInfo :: !(X11 -> IO [Rectangle]) } -data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface - , phiPanels :: ![PanelState w s c] - , phiRepaint :: !Bool - , phiShutdown :: !Bool - , phiShutdownHold :: !Int - , phiWidgetState :: !s - } +data PhiState w s c = (Widget w s c X11) => PhiState { phiRootImage :: !Surface + , phiPanels :: ![PanelState w s c] + , phiRepaint :: !Bool + , phiShutdown :: !Bool + , phiShutdownHold :: !Int + , phiWidgetState :: !s + } -data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !WINDOW - , panelPixmap :: !PIXMAP - , panelArea :: !RECTANGLE - , panelScreenArea :: !RECTANGLE - , panelWidgetCache :: !c - } +data PanelState w s c = (Widget w s c X11) => PanelState { panelWindow :: !WINDOW + , panelPixmap :: !PIXMAP + , panelArea :: !Rectangle + , panelScreenArea :: !Rectangle + , panelWidgetCache :: !c + } data PhiConfig w s c = PhiConfig { phiPhi :: !Phi , phiPanelConfig :: !Panel.PanelConfig , phiXConfig :: !XConfig - , phiAtoms :: !Atoms + , phiX11 :: !X11 + , phiXCB :: !XCB.Connection , phiWidget :: !w } @@ -81,17 +103,22 @@ runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo } -getScreenInfo :: Connection -> IO [RECTANGLE] -getScreenInfo conn = do +getScreenInfo :: X11 -> IO [Rectangle] +getScreenInfo x11 = do + let conn = x11Connection x11 + screen = x11Screen x11 exs <- queryScreens conn >>= getReply case exs of Right xs -> return . map screenInfoToRect $ screen_info_QueryScreensReply xs - Left _ -> getGeometry conn (fromXid . toXid $ getRoot conn) >>= getReply' "getScreenInfo: getGeometry failed" >>= - return . (\(MkGetGeometryReply _ _ x y w h _) -> [MkRECTANGLE x y w h]) + Left _ -> getGeometry conn (fromXid . toXid $ root_SCREEN screen) >>= getReply' "getScreenInfo: getGeometry failed" >>= + return . (\(MkGetGeometryReply _ _ x y w h _) -> [Rectangle (fi x) (fi y) (fi w) (fi h)]) where - screenInfoToRect (MkScreenInfo x y w h) = MkRECTANGLE x y w h + screenInfoToRect (MkScreenInfo x y w h) = Rectangle (fi x) (fi y) (fi w) (fi h) + + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral -runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO () +runPhi :: (Widget w s c X11) => XConfig -> Panel.PanelConfig -> w -> IO () runPhi xconfig config widget = do phi <- initPhi @@ -102,24 +129,30 @@ runPhi xconfig config widget = do conn <- liftM fromJust connect xcb <- XCB.connect + let dispname = displayInfo conn + screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname + atoms <- initAtoms conn - changeWindowAttributes conn (getRoot conn) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] + changeWindowAttributes conn (root_SCREEN screen) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] bg <- createImageSurface FormatRGB24 1 1 - screens <- liftIO $ phiXScreenInfo xconfig conn - panelWindows <- mapM (createPanelWindow conn config) screens - let dispvar = Widget.Display conn atoms - widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1) + let x11 = X11 conn atoms screen + + screens <- liftIO $ phiXScreenInfo xconfig x11 + panelWindows <- mapM (createPanelWindow conn screen config) screens + + let widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1) screenPanels = zip screens panelWindows - initialState <- Widget.initWidget widget' phi dispvar screenPanels + initialState <- initWidget widget' phi x11 screenPanels runPhiX PhiConfig { phiPhi = phi , phiXConfig = xconfig , phiPanelConfig = config - , phiAtoms = atoms + , phiX11 = x11 + , phiXCB = xcb , phiWidget = widget' } PhiState { phiRootImage = bg @@ -129,15 +162,15 @@ runPhi xconfig config widget = do , phiShutdownHold = 0 , phiWidgetState = initialState } $ do - updateRootImage conn xcb + updateRootImage - panels <- mapM (\(screen, window) -> createPanel conn window screen) screenPanels + panels <- mapM (\(screen, window) -> createPanel window screen) screenPanels - forM_ panels $ setPanelProperties conn + forM_ panels setPanelProperties modify $ \state -> state { phiPanels = panels } - updatePanels conn xcb + updatePanels forM_ panels $ liftIO . mapWindow conn . panelWindow @@ -150,11 +183,11 @@ runPhi xconfig config widget = do available <- messageAvailable phi when (not available && repaint) $ do - updatePanels conn xcb + updatePanels modify $ \state -> state {phiRepaint = False} message <- receiveMessage phi - handleMessage conn xcb message + handleMessage message case (fromMessage message) of Just Shutdown -> @@ -179,8 +212,8 @@ termHandler :: Phi -> Handler termHandler phi = Catch $ sendMessage phi Shutdown -handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c () -handleMessage conn xcb m = do +handleMessage :: (Widget w s c X11) => Message -> PhiX w s c () +handleMessage m = do w <- asks phiWidget modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m} @@ -190,81 +223,86 @@ handleMessage conn xcb m = do _ -> case (fromMessage m) of Just (XEvent event) -> - handleEvent conn xcb event + handleEvent event _ -> return () -handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c () -handleEvent conn xcb event = +handleEvent :: (Widget w s c X11) => SomeEvent -> PhiX w s c () +handleEvent event = case (fromEvent event) of - Just e -> handlePropertyNotifyEvent conn xcb e + Just e -> handlePropertyNotifyEvent e Nothing -> case (fromEvent event) of - Just e -> handleConfigureNotifyEvent conn e + Just e -> handleConfigureNotifyEvent e Nothing -> return () -handlePropertyNotifyEvent :: (Widget w s c) => Connection -> XCB.Connection -> PropertyNotifyEvent -> PhiX w s c () -handlePropertyNotifyEvent conn xcb MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do +handlePropertyNotifyEvent :: (Widget w s c X11) => PropertyNotifyEvent -> PhiX w s c () +handlePropertyNotifyEvent MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do phi <- asks phiPhi - atoms <- asks phiAtoms + atoms <- asks (x11Atoms . phiX11) panels <- gets phiPanels when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do - updateRootImage conn xcb + updateRootImage sendMessage phi ResetBackground sendMessage phi Repaint -handleConfigureNotifyEvent :: (Widget w s c) => Connection -> ConfigureNotifyEvent -> PhiX w s c () -handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } | window == getRoot conn = do - phi <- asks phiPhi - xconfig <- asks phiXConfig - config <- asks phiPanelConfig - panels <- gets phiPanels - let screens = map panelScreenArea panels - screens' <- liftIO $ phiXScreenInfo xconfig conn - - when (screens /= screens') $ do - liftIO $ do - mapM_ (freePixmap conn . panelPixmap) panels - mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels +handleConfigureNotifyEvent :: (Widget w s c X11) => ConfigureNotifyEvent -> PhiX w s c () +handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } = do + x11 <- asks phiX11 + let conn = x11Connection x11 + screen = x11Screen x11 + rootWindow = root_SCREEN screen + when (window == rootWindow) $ do + phi <- asks phiPhi + xconfig <- asks phiXConfig + config <- asks phiPanelConfig + panels <- gets phiPanels + let screens = map panelScreenArea panels + screens' <- liftIO $ phiXScreenInfo xconfig x11 - let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing - - panels' <- forM panelsScreens $ \(screen, mpanel) -> - case mpanel of - Just panel -> do - let rect = panelBounds config screen - win = panelWindow panel - - liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ x_RECTANGLE rect) - , (ConfigWindowY, fromIntegral $ y_RECTANGLE rect) - , (ConfigWindowWidth, fromIntegral $ width_RECTANGLE rect) - , (ConfigWindowHeight, fromIntegral $ height_RECTANGLE rect) - ] - - panel' <- createPanel conn win screen - setPanelProperties conn panel' - - return panel' - Nothing -> do - win <- liftIO $ createPanelWindow conn config screen - panel <- createPanel conn win screen - setPanelProperties conn panel - liftIO $ mapWindow conn $ panelWindow panel - return panel - - modify $ \state -> state { phiPanels = panels' } - - sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' - sendMessage phi Repaint - -handleConfigureNotifyEvent _ _ = return () + when (screens /= screens') $ do + liftIO $ do + mapM_ (freePixmap conn . panelPixmap) panels + mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels + + let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing + + panels' <- forM panelsScreens $ \(screenarea, mpanel) -> + case mpanel of + Just panel -> do + let rect = panelBounds config screenarea + win = panelWindow panel + + liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ rect_x rect) + , (ConfigWindowY, fromIntegral $ rect_y rect) + , (ConfigWindowWidth, fromIntegral $ rect_width rect) + , (ConfigWindowHeight, fromIntegral $ rect_height rect) + ] + + panel' <- createPanel win screenarea + setPanelProperties panel' + + return panel' + Nothing -> do + win <- liftIO $ createPanelWindow conn screen config screenarea + panel <- createPanel win screenarea + setPanelProperties panel + liftIO $ mapWindow conn $ panelWindow panel + return panel + + modify $ \state -> state { phiPanels = panels' } + + sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' + sendMessage phi Repaint receiveEvents :: Phi -> Connection -> IO () receiveEvents phi conn = do forever $ waitForEvent conn >>= sendMessage phi . XEvent -updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c () -updatePanels conn xcb = do +updatePanels :: (Widget w s c X11) => PhiX w s c () +updatePanels = do + X11 conn _ screen <- asks phiX11 + xcb <- asks phiXCB w <- asks phiWidget s <- gets phiWidgetState rootImage <- gets phiRootImage @@ -275,17 +313,16 @@ updatePanels conn xcb = do area = panelArea panel (panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $ - (withDimension area $ Widget.render w s 0 0) (panelScreenArea panel) + (withDimension area $ render w s 0 0) (panelScreenArea panel) - let screen = head . roots_Setup . connectionSetup $ conn - visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) + let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do renderWith buffer $ do save - translate (-(fromIntegral $ x_RECTANGLE area)) (-(fromIntegral $ y_RECTANGLE area)) + translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area)) withPatternForSurface rootImage $ \pattern -> do patternSetExtend pattern ExtendRepeat setSource pattern @@ -313,12 +350,12 @@ updatePanels conn xcb = do modify $ \state -> state { phiPanels = panels' } -updateRootImage :: Connection -> XCB.Connection -> PhiX w s c () -updateRootImage conn xcb = do - atoms <- asks phiAtoms +updateRootImage :: PhiX w s c () +updateRootImage = do + X11 conn atoms screen <- asks phiX11 + xcb <- asks phiXCB - let screen = head . roots_Setup . connectionSetup $ conn - visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) + let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) rootwin = root_SCREEN screen pixmap <- liftM (fromXid . toXid . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $ @@ -355,12 +392,12 @@ updateRootImage conn xcb = do return () -createPanel :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c) -createPanel conn win screenRect = do +createPanel :: (Widget w s c X11) => WINDOW -> Rectangle -> PhiX w s c (PanelState w s c) +createPanel win screenRect = do + (conn, screen) <- asks $ (x11Connection &&& x11Screen) . phiX11 config <- asks phiPanelConfig w <- asks phiWidget let rect = panelBounds config screenRect - screen = head . roots_Setup . connectionSetup $ conn depth = root_depth_SCREEN screen pixmap <- liftIO $ newResource conn @@ -374,10 +411,9 @@ createPanel conn win screenRect = do , panelWidgetCache = initCache w } -createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW -createPanelWindow conn config screenRect = do +createPanelWindow :: Connection -> SCREEN -> Panel.PanelConfig -> Rectangle -> IO WINDOW +createPanelWindow conn screen config screenRect = do let rect = panelBounds config screenRect - screen = head . roots_Setup . connectionSetup $ conn depth = root_depth_SCREEN screen rootwin = root_SCREEN screen visual = root_visual_SCREEN screen @@ -387,9 +423,9 @@ createPanelWindow conn config screenRect = do return win -setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c () -setPanelProperties conn panel = do - atoms <- asks phiAtoms +setPanelProperties :: PanelState w s c -> PhiX w s c () +setPanelProperties panel = do + (conn, atoms) <- asks $ (x11Connection &&& x11Atoms) . phiX11 liftIO $ do let name = map (fromIntegral . ord) "Phi" changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_NAME atoms) (atomSTRING atoms) name @@ -408,28 +444,28 @@ setPanelProperties conn panel = do changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_CLASS atoms) (atomSTRING atoms) $ map (fromIntegral . ord) "phi\0Phi" - setStruts conn panel + setStruts panel -setStruts :: Connection -> PanelState w s c -> PhiX w s c () -setStruts conn panel = do - atoms <- asks phiAtoms +setStruts :: PanelState w s c -> PhiX w s c () +setStruts panel = do + X11 conn atoms screen <- asks phiX11 config <- asks phiPanelConfig - let rootwin = getRoot conn + let rootwin = root_SCREEN screen position = Panel.panelPosition config area = panelArea panel rootHeight <- liftIO $ getGeometry conn (fromXid . toXid $ rootwin) >>= getReply' "setStruts: getGeometry failed" >>= return . height_GetGeometryReply let struts = [makeStruts i | i <- [0..11]] where - makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area) - makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area) - makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1 + makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area) + makeTopStruts 8 = (fromIntegral $ rect_x area) + makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1 makeTopStruts _ = 0 - makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ y_RECTANGLE area) - makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area) - makeBottomStruts 11 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1 + makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area) + makeBottomStruts 10 = (fromIntegral $ rect_x area) + makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1 makeBottomStruts _ = 0 makeStruts = case position of @@ -441,17 +477,17 @@ setStruts conn panel = do changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) (atomCARDINAL atoms) struts -panelBounds :: Panel.PanelConfig -> RECTANGLE -> RECTANGLE +panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle panelBounds config screenBounds = case Panel.panelPosition config of - Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config } - Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config, - y_RECTANGLE = (y_RECTANGLE screenBounds) + (fromIntegral $ height_RECTANGLE screenBounds) - (fromIntegral $ Panel.panelSize config) } + Phi.Top -> screenBounds { rect_height = Panel.panelSize config } + Phi.Bottom -> screenBounds { rect_height = Panel.panelSize config, + rect_y = rect_y screenBounds + rect_height screenBounds - Panel.panelSize config } -withRectangle :: (Num x, Num y, Num w, Num h) => RECTANGLE -> (x -> y -> w -> h -> a) -> a +withRectangle :: (Num x, Num y, Num w, Num h) => Rectangle -> (x -> y -> w -> h -> a) -> a withRectangle r = withDimension r . withPosition r -withPosition :: (Num x, Num y) => RECTANGLE -> (x -> y -> a) -> a -withPosition r f = f (fromIntegral $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE r) +withPosition :: (Num x, Num y) => Rectangle -> (x -> y -> a) -> a +withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r) -withDimension :: (Num w, Num h) => RECTANGLE -> (w -> h -> a) -> a -withDimension r f = f (fromIntegral $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r) +withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a +withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r) diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index 5fbd98c..31a029a 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/lib/Phi/X11/AtomList.hs @@ -53,4 +53,4 @@ atoms = [ "ATOM" -- the expression must have the type (Connection -> String) specialAtoms :: [(String, Q Exp)] specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . screen . displayInfo|]) - ] \ No newline at end of file + ] diff --git a/phi.cabal b/phi.cabal index 9d055f4..d498176 100644 --- a/phi.cabal +++ b/phi.cabal @@ -14,7 +14,7 @@ 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.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.X11.Taskbar -- , Phi.Widgets.Systray other-modules: Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB include-dirs: include diff --git a/src/Phi.hs b/src/Phi.hs index c5ba113..5cab565 100644 --- a/src/Phi.hs +++ b/src/Phi.hs @@ -6,8 +6,8 @@ import Phi.X11 import Phi.Widgets.AlphaBox import Phi.Widgets.Clock -import Phi.Widgets.Taskbar ---import Phi.Widgets.Systray +import Phi.Widgets.X11.Taskbar +--import Phi.Widgets.X11.Systray main :: IO () @@ -52,5 +52,5 @@ main = do , lineSpacing = (-3) , clockSize = 75 } - brightBorder :: (Widget w s c) => w -> Border w s c + brightBorder :: (Widget w s c d) => w -> Border w s c d brightBorder = border normalDesktopBorder From 2ae89a5e3348fbe94b50a985de9766689c22d011 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Fri, 9 Sep 2011 03:20:16 +0200 Subject: [PATCH 05/10] SystrayHelper: initialization --- lib/Phi/Bindings/XCB.hsc | 2 +- lib/Phi/Widgets/X11/Systray.hs | 12 ------ lib/Phi/X11.hs | 3 +- lib/Phi/X11/AtomList.hs | 1 + lib/Phi/X11/Util.hs | 39 ++++++++++++++++++- phi.cabal | 12 +++++- src/SystrayHelper.hs | 71 ++++++++++++++++++++++++++++++++++ 7 files changed, 123 insertions(+), 17 deletions(-) create mode 100644 src/SystrayHelper.hs diff --git a/lib/Phi/Bindings/XCB.hsc b/lib/Phi/Bindings/XCB.hsc index 33aff03..1beb5f2 100644 --- a/lib/Phi/Bindings/XCB.hsc +++ b/lib/Phi/Bindings/XCB.hsc @@ -74,7 +74,7 @@ flush (Connection conn) = withForeignPtr conn xcb_flush type VOID_COOKIE = CUInt -foreign import ccall "xcb/xcb.h xcb_request_check" +foreign import ccall unsafe "xcb/xcb.h xcb_request_check" xcb_request_check :: Ptr Connection -> VOID_COOKIE -> IO (Ptr ()) requestCheck :: Ptr Connection -> VOID_COOKIE -> IO () diff --git a/lib/Phi/Widgets/X11/Systray.hs b/lib/Phi/Widgets/X11/Systray.hs index fffb181..8f10a60 100644 --- a/lib/Phi/Widgets/X11/Systray.hs +++ b/lib/Phi/Widgets/X11/Systray.hs @@ -178,18 +178,6 @@ initSystray disp atoms = do return $ Just xembedWin -sYSTEM_TRAY_REQUEST_DOCK :: CInt -sYSTEM_TRAY_REQUEST_DOCK = 0 - -sYSTEM_TRAY_BEGIN_MESSAGE :: CInt -sYSTEM_TRAY_BEGIN_MESSAGE = 1 - -sYSTEM_TRAY_CANCEL_MESSAGE :: CInt -sYSTEM_TRAY_CANCEL_MESSAGE = 2 - -xEMBED_EMBEDDED_NOTIFY :: CInt -xEMBED_EMBEDDED_NOTIFY = 0 - handleEvent :: Event -> Phi -> Display -> Window -> Window -> StateT (M.Map Window Window) IO () handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar panelWindow xembedWindow = do let atoms = getAtoms dispvar diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 713b162..9c213e0 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -179,7 +179,7 @@ runPhi xconfig config widget = do forever $ do available <- messageAvailable phi repaint <- gets phiRepaint - when (not available && repaint) $ liftIO $ threadDelay 30000 + when (not available && repaint) $ liftIO $ threadDelay 20000 available <- messageAvailable phi when (not available && repaint) $ do @@ -189,6 +189,7 @@ runPhi xconfig config widget = do message <- receiveMessage phi handleMessage message + case (fromMessage message) of Just Shutdown -> modify $ \state -> state { phiShutdown = True } diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index 31a029a..1d751bc 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/lib/Phi/X11/AtomList.hs @@ -13,6 +13,7 @@ atoms :: [String] atoms = [ "ATOM" , "CARDINAL" , "STRING" + , "VISUALID" , "UTF8_STRING" , "WM_NAME" , "WM_CLASS" diff --git a/lib/Phi/X11/Util.hs b/lib/Phi/X11/Util.hs index cadceeb..a86cafd 100644 --- a/lib/Phi/X11/Util.hs +++ b/lib/Phi/X11/Util.hs @@ -6,8 +6,10 @@ module Phi.X11.Util ( getReply' , getProperty16 , getProperty32 , findVisualtype + , serializeClientMessage ) where +import Control.Exception (assert) import Control.Monad import Data.Int @@ -15,8 +17,11 @@ import Data.List import Data.Maybe import Data.Word +import Foreign.C.Types import Foreign.Marshal.Array +import Foreign.Marshal.Utils import Foreign.Ptr +import Foreign.Storable import Graphics.XHB import Graphics.XHB.Gen.Xproto @@ -50,6 +55,10 @@ castWord8to32 input = unsafePerformIO $ withArray input $ \ptr -> peekArray (length input `div` 4) (castPtr ptr) +castToCChar :: Storable s => s -> [CChar] +castToCChar input = unsafePerformIO $ + with input $ \ptr -> + peekArray (sizeOf input) (castPtr ptr) changeProperty8 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO () changeProperty8 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 8 (genericLength propdata) propdata @@ -86,4 +95,32 @@ getProperty32 conn win prop = getProperty' 32 conn win prop >>= return . fmap ca findVisualtype :: SCREEN -> VISUALID -> Maybe VISUALTYPE -findVisualtype screen id = listToMaybe . filter ((== id) . visual_id_VISUALTYPE) . join . map visuals_DEPTH . allowed_depths_SCREEN $ screen \ No newline at end of file +findVisualtype screen id = listToMaybe . filter ((== id) . visual_id_VISUALTYPE) . join . map visuals_DEPTH . allowed_depths_SCREEN $ screen + + +instance Storable ClientMessageData where + sizeOf _ = 20 + alignment _ = 1 + peek _ = error "ClientMessageData: peek not implemented" + poke ptr (ClientData8 d) = assert (length d == 20) $ pokeArray (castPtr ptr) d + poke ptr (ClientData16 d) = assert (length d == 10) $ pokeArray (castPtr ptr) d + poke ptr (ClientData32 d) = assert (length d == 5) $ pokeArray (castPtr ptr) d + +instance Storable ClientMessageEvent where + sizeOf _ = 32 + alignment _ = 1 + peek _ = error "ClientMessageEvent: peek not implemented" + poke ptr ev = do + poke' 0 (33 :: Word8) -- ClientMessage == 33 -- response_type + poke' 1 (format_ClientMessageEvent ev) -- format + poke' 2 (0 :: Word16) -- sequence + poke' 4 (fromXid . toXid . window_ClientMessageEvent $ ev :: Word32) -- window + poke' 8 (fromXid . toXid . type_ClientMessageEvent $ ev :: Word32) -- type + poke' 12 (data_ClientMessageEvent ev) -- data + where + poke' :: Storable s => Int -> s -> IO () + poke' = poke . plusPtr ptr + + +serializeClientMessage :: ClientMessageEvent -> [CChar] +serializeClientMessage = castToCChar diff --git a/phi.cabal b/phi.cabal index d498176..0070ea5 100644 --- a/phi.cabal +++ b/phi.cabal @@ -10,20 +10,28 @@ author: Matthias Schiffer maintainer: mschiffer@universe-factory.net build-type: Simple + 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.X11.Taskbar -- , Phi.Widgets.Systray - other-modules: Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB + other-modules: Phi.X11.AtomList, Phi.Bindings.XCB, Phi.X11.Atoms, Phi.X11.Util include-dirs: include hs-source-dirs: lib - extra-libraries: X11 pkgconfig-depends: xcb, cairo >= 1.2.0, cairo-xcb ghc-options: -fspec-constr-count=16 -threaded +executable PhiSystrayHelper + build-depends: base >= 4, template-haskell, xhb + hs-source-dirs: src, lib + main-is: SystrayHelper.hs + other-modules: Phi.X11.AtomList, Phi.X11.Atoms, Phi.X11.Util + ghc-options: -threaded + executable Phi build-depends: base >= 4, phi hs-source-dirs: src main-is: Phi.hs + ghc-options: -threaded diff --git a/src/SystrayHelper.hs b/src/SystrayHelper.hs new file mode 100644 index 0000000..962d45d --- /dev/null +++ b/src/SystrayHelper.hs @@ -0,0 +1,71 @@ +import Control.Monad + +import Data.Maybe + +import Graphics.XHB +import Graphics.XHB.Gen.Xproto +import qualified Graphics.XHB.Connection.Open as CO + +import System.Exit + +import Phi.X11.Atoms +import Phi.X11.Util + + +{-sYSTEM_TRAY_REQUEST_DOCK :: CInt +sYSTEM_TRAY_REQUEST_DOCK = 0 + +sYSTEM_TRAY_BEGIN_MESSAGE :: CInt +sYSTEM_TRAY_BEGIN_MESSAGE = 1 + +sYSTEM_TRAY_CANCEL_MESSAGE :: CInt +sYSTEM_TRAY_CANCEL_MESSAGE = 2 + +xEMBED_EMBEDDED_NOTIFY :: CInt +xEMBED_EMBEDDED_NOTIFY = 0-} + + +main :: IO () +main = do + conn <- liftM fromJust connect + atoms <- initAtoms conn + + let dispname = displayInfo conn + screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname + + xembedWindow <- initSystray conn atoms screen + + return () + + +initSystray :: Connection -> Atoms -> SCREEN -> IO WINDOW +initSystray conn atoms screen = do + currentSystrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed" + when (currentSystrayWin /= fromXid xidNone) $ do + putStrLn "PhiSystrayHelper: another systray is running." + exitFailure + + let rootwin = root_SCREEN screen + depth = root_depth_SCREEN screen + visual = root_visual_SCREEN screen + xembedWin <- newResource conn + createWindow conn $ MkCreateWindow depth xembedWin rootwin (-1) (-1) 1 1 0 WindowClassInputOutput visual emptyValueParam + + -- orient horizontally + changeProperty32 conn PropModeReplace xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) (atomCARDINAL atoms) [0] + + -- set visual + changeProperty32 conn PropModeReplace xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) (atomVISUALID atoms) [fromIntegral visual] + + setSelectionOwner conn $ MkSetSelectionOwner xembedWin (atom_NET_SYSTEM_TRAY_SCREEN atoms) 0 + systrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed" + when (systrayWin /= xembedWin) $ do + destroyWindow conn xembedWin + putStrLn $ "PhiSystrayHelper: can't initialize systray." + exitFailure + + sendEvent conn $ MkSendEvent False rootwin [EventMaskStructureNotify] $ + serializeClientMessage $ MkClientMessageEvent 32 rootwin (atomMANAGER atoms) $ + ClientData32 [0, fromXid . toXid $ atom_NET_SYSTEM_TRAY_SCREEN atoms, fromXid . toXid $ xembedWin, 0, 0] + + return xembedWin From 5cb4744d4f8bae31c17802f1e57fe31bf747f469 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Thu, 22 Sep 2011 18:38:53 +0200 Subject: [PATCH 06/10] Small taskbar fix --- lib/Phi/Widgets/X11/Taskbar.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Phi/Widgets/X11/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs index 07a7292..964fd39 100644 --- a/lib/Phi/Widgets/X11/Taskbar.hs +++ b/lib/Phi/Widgets/X11/Taskbar.hs @@ -573,7 +573,7 @@ getWindowInfo x11 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 []) $ getProperty8 conn window (atom_NET_WM_NAME atoms) + Nothing -> liftM (map unsignedChr . fromMaybe []) $ getProperty8 conn window (atomWM_NAME atoms) workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ getProperty32 conn window (atom_NET_WM_DESKTOP atoms) visible <- showWindow conn atoms window From 579552b29b396943c3a2c97456c37c8005729ce1 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Fri, 7 Oct 2011 05:31:23 +0200 Subject: [PATCH 07/10] Send X message batched --- lib/Phi/Phi.hs | 4 ++++ lib/Phi/X11.hs | 23 ++++++++++++++++++++--- 2 files changed, 24 insertions(+), 3 deletions(-) diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs index df71a1c..4a896c7 100644 --- a/lib/Phi/Phi.hs +++ b/lib/Phi/Phi.hs @@ -7,6 +7,7 @@ module Phi.Phi ( Phi , initPhi , dupPhi , sendMessage + , sendMessages , receiveMessage , messageAvailable ) where @@ -36,6 +37,9 @@ dupPhi (Phi chan) = liftM Phi $ liftIO $ atomically $ dupTChan chan sendMessage :: (MonadIO m, Typeable a, Show a) => Phi -> a -> m () sendMessage (Phi chan) = liftIO . atomically . writeTChan chan . Message +sendMessages :: (MonadIO m, Typeable a, Show a) => Phi -> [a] -> m () +sendMessages (Phi chan) = liftIO . atomically . mapM_ (writeTChan chan . Message) + receiveMessage :: MonadIO m => Phi -> m Message receiveMessage (Phi chan) = liftIO $ atomically $ readTChan chan diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 9c213e0..e08c990 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -179,7 +179,7 @@ runPhi xconfig config widget = do forever $ do available <- messageAvailable phi repaint <- gets phiRepaint - when (not available && repaint) $ liftIO $ threadDelay 20000 + when (not available && repaint) $ liftIO $ threadDelay 30000 available <- messageAvailable phi when (not available && repaint) $ do @@ -296,9 +296,26 @@ handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' sendMessage phi Repaint + +maybeReceiveEvents' :: Connection -> IO [XEvent] +maybeReceiveEvents' conn = do + yield + mevent <- pollForEvent conn + case mevent of + Just event -> + liftM2 (:) (return . XEvent $ event) (maybeReceiveEvents' conn) + Nothing -> + return [] + + +receiveEvents' :: Connection -> IO [XEvent] +receiveEvents' conn = do + liftM2 (:) (liftM XEvent $ waitForEvent conn) (maybeReceiveEvents' conn) + + receiveEvents :: Phi -> Connection -> IO () -receiveEvents phi conn = do - forever $ waitForEvent conn >>= sendMessage phi . XEvent +receiveEvents phi conn = + forever $ receiveEvents' conn >>= sendMessages phi updatePanels :: (Widget w s c X11) => PhiX w s c () updatePanels = do From 456f9fb6e6d743702fcca79f4d23e1e5f40c530d Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Sat, 8 Oct 2011 05:12:41 +0200 Subject: [PATCH 08/10] Adjust to patched xhb version --- lib/Phi/Widgets/X11/Taskbar.hs | 3 ++- lib/Phi/X11.hs | 17 ++++++++--------- lib/Phi/X11/AtomList.hs | 2 +- lib/Phi/X11/Atoms.hs | 1 + lib/Phi/X11/Util.hs | 16 ++++++++-------- phi.cabal | 4 ++-- src/SystrayHelper.hs | 1 + 7 files changed, 23 insertions(+), 21 deletions(-) diff --git a/lib/Phi/Widgets/X11/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs index 964fd39..359fbc6 100644 --- a/lib/Phi/Widgets/X11/Taskbar.hs +++ b/lib/Phi/Widgets/X11/Taskbar.hs @@ -40,6 +40,7 @@ import Graphics.Rendering.Pango.Layout import Graphics.Rendering.Pango.Font import Graphics.XHB +import Graphics.XHB.Connection import Graphics.XHB.Gen.Xproto import Codec.Binary.UTF8.String @@ -624,7 +625,7 @@ getWindowGeometry x11 window = fi :: (Integral a, Num b) => a -> b fi = fromIntegral -showWindow :: Connection -> Atoms -> WINDOW -> IO Bool +showWindow :: ConnectionClass c r => c -> 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) diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index e08c990..9b93328 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -9,6 +9,7 @@ module Phi.X11 ( X11(..) ) where import Graphics.XHB hiding (Window) +import Graphics.XHB.Connection import qualified Graphics.XHB.Connection.Open as CO import Graphics.XHB.Gen.Xinerama import Graphics.XHB.Gen.Xproto hiding (Window) @@ -54,11 +55,8 @@ instance Display X11 where type Window X11 = WINDOW -newtype XEvent = XEvent SomeEvent deriving Typeable +newtype XEvent = XEvent SomeEvent deriving (Show, Typeable) -instance Show XEvent where - show _ = "XEvent (..)" - data XMessage = UpdateScreens [(Rectangle, WINDOW)] deriving (Show, Typeable) @@ -274,11 +272,12 @@ handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent let rect = panelBounds config screenarea win = panelWindow panel - liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ rect_x rect) - , (ConfigWindowY, fromIntegral $ rect_y rect) - , (ConfigWindowWidth, fromIntegral $ rect_width rect) - , (ConfigWindowHeight, fromIntegral $ rect_height rect) - ] + liftIO $ configureWindow conn $ MkConfigureWindow win (toMask [ConfigWindowX, ConfigWindowY, ConfigWindowWidth, ConfigWindowHeight]) $ + toValueParam [ (ConfigWindowX, fromIntegral $ rect_x rect) + , (ConfigWindowY, fromIntegral $ rect_y rect) + , (ConfigWindowWidth, fromIntegral $ rect_width rect) + , (ConfigWindowHeight, fromIntegral $ rect_height rect) + ] panel' <- createPanel win screenarea setPanelProperties panel' diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index 1d751bc..0ab3372 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/lib/Phi/X11/AtomList.hs @@ -6,7 +6,7 @@ module Phi.X11.AtomList ( atoms import Language.Haskell.TH -import Graphics.XHB +import Graphics.XHB.Connection import Graphics.XHB.Connection.Open atoms :: [String] diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs index 0a8f66a..16945bf 100644 --- a/lib/Phi/X11/Atoms.hs +++ b/lib/Phi/X11/Atoms.hs @@ -10,6 +10,7 @@ import Data.List import Language.Haskell.TH import Graphics.XHB +import Graphics.XHB.Connection import Graphics.XHB.Gen.Xproto import Phi.X11.AtomList diff --git a/lib/Phi/X11/Util.hs b/lib/Phi/X11/Util.hs index a86cafd..e1daba5 100644 --- a/lib/Phi/X11/Util.hs +++ b/lib/Phi/X11/Util.hs @@ -29,7 +29,7 @@ import Graphics.XHB.Gen.Xproto import System.IO.Unsafe -getReply' :: String -> Receipt a -> IO a +getReply' :: ConnectionClass c r => String -> r a -> IO a getReply' m = getReply >=> return . fromRight where fromRight (Left _) = error m @@ -60,17 +60,17 @@ castToCChar input = unsafePerformIO $ with input $ \ptr -> peekArray (sizeOf input) (castPtr ptr) -changeProperty8 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO () +changeProperty8 :: ConnectionClass c r => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO () changeProperty8 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 8 (genericLength propdata) propdata -changeProperty16 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO () +changeProperty16 :: ConnectionClass c r => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO () changeProperty16 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 16 (genericLength propdata) (castWord16to8 propdata) -changeProperty32 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO () +changeProperty32 :: ConnectionClass c r => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO () changeProperty32 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 32 (genericLength propdata) (castWord32to8 propdata) -getProperty' :: Word8 -> Connection -> WINDOW -> ATOM -> IO (Maybe [Word8]) +getProperty' :: ConnectionClass c r => Word8 -> c -> WINDOW -> ATOM -> IO (Maybe [Word8]) getProperty' format conn win prop = do reply <- getProperty conn (MkGetProperty False win prop (fromXid xidNone) 0 4) >>= getReply case reply of @@ -84,13 +84,13 @@ getProperty' format conn win prop = do Right (MkGetPropertyReply {format_GetPropertyReply = format'}) | format' /= format -> return Nothing Right (MkGetPropertyReply {value_GetPropertyReply = value}) -> return $ Just value -getProperty8 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word8]) +getProperty8 :: ConnectionClass c r => c -> WINDOW -> ATOM -> IO (Maybe [Word8]) getProperty8 = getProperty' 8 -getProperty16 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word16]) +getProperty16 :: ConnectionClass c r => c -> WINDOW -> ATOM -> IO (Maybe [Word16]) getProperty16 conn win prop = getProperty' 16 conn win prop >>= return . fmap castWord8to16 -getProperty32 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word32]) +getProperty32 :: ConnectionClass c r => c -> WINDOW -> ATOM -> IO (Maybe [Word32]) getProperty32 conn win prop = getProperty' 32 conn win prop >>= return . fmap castWord8to32 diff --git a/phi.cabal b/phi.cabal index 0070ea5..b2e43f0 100644 --- a/phi.cabal +++ b/phi.cabal @@ -12,7 +12,7 @@ build-type: Simple library - build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb, + build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb >= 0.5, xhb-native, 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.X11.Taskbar @@ -24,7 +24,7 @@ library ghc-options: -fspec-constr-count=16 -threaded executable PhiSystrayHelper - build-depends: base >= 4, template-haskell, xhb + build-depends: base >= 4, template-haskell, xhb >= 0.5, xhb-native hs-source-dirs: src, lib main-is: SystrayHelper.hs other-modules: Phi.X11.AtomList, Phi.X11.Atoms, Phi.X11.Util diff --git a/src/SystrayHelper.hs b/src/SystrayHelper.hs index 962d45d..fb9adcf 100644 --- a/src/SystrayHelper.hs +++ b/src/SystrayHelper.hs @@ -3,6 +3,7 @@ import Control.Monad import Data.Maybe import Graphics.XHB +import Graphics.XHB.Connection import Graphics.XHB.Gen.Xproto import qualified Graphics.XHB.Connection.Open as CO From 33cd402ae968587d256e11004dac9ed52d1c3cc5 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Mon, 10 Oct 2011 23:22:59 +0200 Subject: [PATCH 09/10] Use XCB backend --- lib/Phi/Bindings/Cairo.hsc | 51 +++++++++++++++++++ lib/Phi/Bindings/XCB.hsc | 92 ---------------------------------- lib/Phi/Widgets/X11/Taskbar.hs | 3 +- lib/Phi/X11.hs | 21 +++----- lib/Phi/X11/AtomList.hs | 7 ++- lib/Phi/X11/Atoms.hs | 3 +- lib/Phi/X11/Util.hs | 16 +++--- phi.cabal | 8 +-- src/Phi.hs | 4 +- src/SystrayHelper.hs | 6 +-- 10 files changed, 80 insertions(+), 131 deletions(-) create mode 100644 lib/Phi/Bindings/Cairo.hsc delete mode 100644 lib/Phi/Bindings/XCB.hsc diff --git a/lib/Phi/Bindings/Cairo.hsc b/lib/Phi/Bindings/Cairo.hsc new file mode 100644 index 0000000..246bc13 --- /dev/null +++ b/lib/Phi/Bindings/Cairo.hsc @@ -0,0 +1,51 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Phi.Bindings.Cairo ( createXCBSurface + ) where + +import Control.Monad + +import Data.Int +import Data.Word + +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils +import Foreign.Ptr +import Foreign.Storable + +import Graphics.Rendering.Cairo.Types +import Graphics.XHB (toValue) +import Graphics.XHB.Connection.XCB +import Graphics.XHB.Gen.Xproto (DRAWABLE, VISUALTYPE(..)) + + +#include + + +foreign import ccall "cairo-xlib.h cairo_xcb_surface_create" + cairo_xcb_surface_create :: Ptr XCBConnection -> DRAWABLE -> Ptr VISUALTYPE -> CInt -> CInt -> IO (Ptr Surface) + +instance Storable VISUALTYPE where + sizeOf _ = (#size xcb_visualtype_t) + alignment _ = alignment (undefined :: CInt) + + peek _ = error "VISUALTYPE: peek not implemented" + + poke vt (MkVISUALTYPE visual_id _class bits_per_rgb_value colormap_entries red_mask green_mask blue_mask) = do + (#poke xcb_visualtype_t, visual_id) vt visual_id + (#poke xcb_visualtype_t, _class) vt (toValue _class :: Word8) + (#poke xcb_visualtype_t, bits_per_rgb_value) vt bits_per_rgb_value + (#poke xcb_visualtype_t, colormap_entries) vt colormap_entries + (#poke xcb_visualtype_t, red_mask) vt red_mask + (#poke xcb_visualtype_t, green_mask) vt green_mask + (#poke xcb_visualtype_t, blue_mask) vt blue_mask + +createXCBSurface :: Connection -> DRAWABLE -> VISUALTYPE -> CInt -> CInt -> IO Surface +createXCBSurface conn drawable visual width height = + with visual $ \visualptr -> withConnection conn $ \connptr -> do + surfacePtr <- cairo_xcb_surface_create connptr drawable visualptr width height + surface <- mkSurface surfacePtr + manageSurface surface + return surface diff --git a/lib/Phi/Bindings/XCB.hsc b/lib/Phi/Bindings/XCB.hsc deleted file mode 100644 index 1beb5f2..0000000 --- a/lib/Phi/Bindings/XCB.hsc +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module Phi.Bindings.XCB ( Connection - , connect - , createXCBSurface - , flush - , clearArea - ) where - -import Control.Monad - -import Data.Int -import Data.Word - -import Foreign.C.String -import Foreign.C.Types -import Foreign.ForeignPtr -import Foreign.Marshal.Alloc -import Foreign.Marshal.Utils -import Foreign.Ptr -import Foreign.Storable - -import Graphics.Rendering.Cairo.Types -import Graphics.XHB (toValue) -import Graphics.XHB.Gen.Xproto (DRAWABLE, WINDOW, VISUALTYPE(..)) - - -#include -#include -#include - - -data Connection = Connection (ForeignPtr Connection) - -foreign import ccall "xcb/xcb.h xcb_connect" xcb_connect :: CString -> Ptr CInt -> IO (Ptr Connection) -foreign import ccall "xcb/xcb.h &xcb_disconnect" p_xcb_disconnect :: FunPtr (Ptr Connection -> IO ()) - -connect :: IO Connection -connect = do - conn <- xcb_connect nullPtr nullPtr - newForeignPtr p_xcb_disconnect conn >>= return . Connection - -foreign import ccall "cairo-xlib.h cairo_xcb_surface_create" - cairo_xcb_surface_create :: Ptr Connection -> DRAWABLE -> Ptr VISUALTYPE -> CInt -> CInt -> IO (Ptr Surface) - -instance Storable VISUALTYPE where - sizeOf _ = (#size xcb_visualtype_t) - alignment _ = alignment (undefined :: CInt) - - peek _ = error "VISUALTYPE: peek not implemented" - - poke vt (MkVISUALTYPE visual_id _class bits_per_rgb_value colormap_entries red_mask green_mask blue_mask) = do - (#poke xcb_visualtype_t, visual_id) vt visual_id - (#poke xcb_visualtype_t, _class) vt (toValue _class :: Word8) - (#poke xcb_visualtype_t, bits_per_rgb_value) vt bits_per_rgb_value - (#poke xcb_visualtype_t, colormap_entries) vt colormap_entries - (#poke xcb_visualtype_t, red_mask) vt red_mask - (#poke xcb_visualtype_t, green_mask) vt green_mask - (#poke xcb_visualtype_t, blue_mask) vt blue_mask - -createXCBSurface :: Connection -> DRAWABLE -> VISUALTYPE -> CInt -> CInt -> IO Surface -createXCBSurface (Connection conn) drawable visual width height = - with visual $ \visualptr -> withForeignPtr conn $ \connptr -> do - surfacePtr <- cairo_xcb_surface_create connptr drawable visualptr width height - surface <- mkSurface surfacePtr - manageSurface surface - return surface - -foreign import ccall "xcb/xcb.h xcb_flush" - xcb_flush :: Ptr Connection -> IO () - -flush :: Connection -> IO () -flush (Connection conn) = withForeignPtr conn xcb_flush - -type VOID_COOKIE = CUInt - -foreign import ccall unsafe "xcb/xcb.h xcb_request_check" - xcb_request_check :: Ptr Connection -> VOID_COOKIE -> IO (Ptr ()) - -requestCheck :: Ptr Connection -> VOID_COOKIE -> IO () -requestCheck conn cookie = do - ret <- xcb_request_check conn cookie - when (ret /= nullPtr) $ - free ret - -foreign import ccall "xcb/xproto.h xcb_clear_area" - xcb_clear_area :: Ptr Connection -> Word8 -> WINDOW -> Int16 -> Int16 -> Word16 -> Word16 -> IO VOID_COOKIE - -clearArea :: Connection -> Bool -> WINDOW -> Int16 -> Int16 -> Word16 -> Word16 -> IO () -clearArea (Connection conn) exposures window x y width height = withForeignPtr conn $ \connptr -> do - cookie <- xcb_clear_area connptr (if exposures then 1 else 0) window x y width height - requestCheck connptr cookie diff --git a/lib/Phi/Widgets/X11/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs index 359fbc6..d52d600 100644 --- a/lib/Phi/Widgets/X11/Taskbar.hs +++ b/lib/Phi/Widgets/X11/Taskbar.hs @@ -40,7 +40,6 @@ import Graphics.Rendering.Pango.Layout import Graphics.Rendering.Pango.Font import Graphics.XHB -import Graphics.XHB.Connection import Graphics.XHB.Gen.Xproto import Codec.Binary.UTF8.String @@ -625,7 +624,7 @@ getWindowGeometry x11 window = fi :: (Integral a, Num b) => a -> b fi = fromIntegral -showWindow :: ConnectionClass c r => c -> Atoms -> WINDOW -> IO Bool +showWindow :: ConnectionClass c => c -> 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) diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 9b93328..af4cb0b 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -9,8 +9,7 @@ module Phi.X11 ( X11(..) ) where import Graphics.XHB hiding (Window) -import Graphics.XHB.Connection -import qualified Graphics.XHB.Connection.Open as CO +import Graphics.XHB.Connection.XCB import Graphics.XHB.Gen.Xinerama import Graphics.XHB.Gen.Xproto hiding (Window) @@ -35,7 +34,7 @@ import System.Exit import System.Posix.Signals import System.Posix.Types -import qualified Phi.Bindings.XCB as XCB +import Phi.Bindings.Cairo import Phi.Phi import Phi.X11.Util @@ -82,7 +81,6 @@ data PhiConfig w s c = PhiConfig { phiPhi :: !Phi , phiPanelConfig :: !Panel.PanelConfig , phiXConfig :: !XConfig , phiX11 :: !X11 - , phiXCB :: !XCB.Connection , phiWidget :: !w } @@ -125,10 +123,8 @@ runPhi xconfig config widget = do installHandler sigQUIT (termHandler phi) Nothing conn <- liftM fromJust connect - xcb <- XCB.connect - let dispname = displayInfo conn - screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname + let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn atoms <- initAtoms conn changeWindowAttributes conn (root_SCREEN screen) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] @@ -150,7 +146,6 @@ runPhi xconfig config widget = do , phiXConfig = xconfig , phiPanelConfig = config , phiX11 = x11 - , phiXCB = xcb , phiWidget = widget' } PhiState { phiRootImage = bg @@ -319,7 +314,6 @@ receiveEvents phi conn = updatePanels :: (Widget w s c X11) => PhiX w s c () updatePanels = do X11 conn _ screen <- asks phiX11 - xcb <- asks phiXCB w <- asks phiWidget s <- gets phiWidgetState rootImage <- gets phiRootImage @@ -334,7 +328,7 @@ updatePanels = do let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) - xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype + xbuffer <- liftIO $ withDimension area $ createXCBSurface conn (fromXid . toXid $ pixmap) visualtype liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do renderWith buffer $ do @@ -360,7 +354,9 @@ updatePanels = do surfaceFinish xbuffer -- update window - liftIO $ withDimension area $ XCB.clearArea xcb True (panelWindow panel) 0 0 + liftIO $ do + clearArea conn $ withDimension area $ MkClearArea True (panelWindow panel) 0 0 + flush conn return $ panel { panelWidgetCache = cache' } @@ -370,7 +366,6 @@ updatePanels = do updateRootImage :: PhiX w s c () updateRootImage = do X11 conn atoms screen <- asks phiX11 - xcb <- asks phiXCB let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) rootwin = root_SCREEN screen @@ -399,7 +394,7 @@ updateRootImage = do setSourceRGB 0 0 0 paint _ -> do - rootSurface <- liftIO $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype (fromIntegral pixmapWidth) (fromIntegral pixmapHeight) + rootSurface <- liftIO $ createXCBSurface conn (fromXid . toXid $ pixmap) visualtype (fromIntegral pixmapWidth) (fromIntegral pixmapHeight) renderWith bg $ withPatternForSurface rootSurface $ \pattern -> do setSource pattern diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index 0ab3372..cad753a 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/lib/Phi/X11/AtomList.hs @@ -6,8 +6,7 @@ module Phi.X11.AtomList ( atoms import Language.Haskell.TH -import Graphics.XHB.Connection -import Graphics.XHB.Connection.Open +import Graphics.XHB atoms :: [String] atoms = [ "ATOM" @@ -51,7 +50,7 @@ atoms = [ "ATOM" , "_XROOTMAP_ID" ] --- the expression must have the type (Connection -> String) +-- the expression must have the type (ConnectionClass c => c -> String) specialAtoms :: [(String, Q Exp)] -specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . screen . displayInfo|]) +specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . connectionScreen|]) ] diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs index 16945bf..6e69b37 100644 --- a/lib/Phi/X11/Atoms.hs +++ b/lib/Phi/X11/Atoms.hs @@ -10,7 +10,6 @@ import Data.List import Language.Haskell.TH import Graphics.XHB -import Graphics.XHB.Connection import Graphics.XHB.Gen.Xproto import Phi.X11.AtomList @@ -22,7 +21,7 @@ $(let atomsName = mkName "Atoms" in return [DataD [] atomsName [] [RecC atomsName fields] []] ) -initAtoms :: Connection -> IO Atoms +initAtoms :: ConnectionClass c => c -> IO Atoms initAtoms conn = $(do normalAtomNames <- mapM (\atom -> do diff --git a/lib/Phi/X11/Util.hs b/lib/Phi/X11/Util.hs index e1daba5..07eb1cf 100644 --- a/lib/Phi/X11/Util.hs +++ b/lib/Phi/X11/Util.hs @@ -29,7 +29,7 @@ import Graphics.XHB.Gen.Xproto import System.IO.Unsafe -getReply' :: ConnectionClass c r => String -> r a -> IO a +getReply' :: String -> Receipt a -> IO a getReply' m = getReply >=> return . fromRight where fromRight (Left _) = error m @@ -60,17 +60,17 @@ castToCChar input = unsafePerformIO $ with input $ \ptr -> peekArray (sizeOf input) (castPtr ptr) -changeProperty8 :: ConnectionClass c r => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO () +changeProperty8 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO () changeProperty8 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 8 (genericLength propdata) propdata -changeProperty16 :: ConnectionClass c r => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO () +changeProperty16 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO () changeProperty16 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 16 (genericLength propdata) (castWord16to8 propdata) -changeProperty32 :: ConnectionClass c r => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO () +changeProperty32 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO () changeProperty32 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 32 (genericLength propdata) (castWord32to8 propdata) -getProperty' :: ConnectionClass c r => Word8 -> c -> WINDOW -> ATOM -> IO (Maybe [Word8]) +getProperty' :: ConnectionClass c => Word8 -> c -> WINDOW -> ATOM -> IO (Maybe [Word8]) getProperty' format conn win prop = do reply <- getProperty conn (MkGetProperty False win prop (fromXid xidNone) 0 4) >>= getReply case reply of @@ -84,13 +84,13 @@ getProperty' format conn win prop = do Right (MkGetPropertyReply {format_GetPropertyReply = format'}) | format' /= format -> return Nothing Right (MkGetPropertyReply {value_GetPropertyReply = value}) -> return $ Just value -getProperty8 :: ConnectionClass c r => c -> WINDOW -> ATOM -> IO (Maybe [Word8]) +getProperty8 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word8]) getProperty8 = getProperty' 8 -getProperty16 :: ConnectionClass c r => c -> WINDOW -> ATOM -> IO (Maybe [Word16]) +getProperty16 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word16]) getProperty16 conn win prop = getProperty' 16 conn win prop >>= return . fmap castWord8to16 -getProperty32 :: ConnectionClass c r => c -> WINDOW -> ATOM -> IO (Maybe [Word32]) +getProperty32 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word32]) getProperty32 conn win prop = getProperty' 32 conn win prop >>= return . fmap castWord8to32 diff --git a/phi.cabal b/phi.cabal index b2e43f0..5100bda 100644 --- a/phi.cabal +++ b/phi.cabal @@ -12,19 +12,19 @@ build-type: Simple library - build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb >= 0.5, xhb-native, + build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb >= 0.5, xhb-xcb, 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.X11.Taskbar -- , Phi.Widgets.Systray - other-modules: Phi.X11.AtomList, Phi.Bindings.XCB, Phi.X11.Atoms, Phi.X11.Util + other-modules: Phi.X11.AtomList, Phi.Bindings.Cairo, Phi.X11.Atoms, Phi.X11.Util include-dirs: include hs-source-dirs: lib pkgconfig-depends: xcb, cairo >= 1.2.0, cairo-xcb ghc-options: -fspec-constr-count=16 -threaded executable PhiSystrayHelper - build-depends: base >= 4, template-haskell, xhb >= 0.5, xhb-native + build-depends: base >= 4, template-haskell, xhb >= 0.5, xhb-xcb hs-source-dirs: src, lib main-is: SystrayHelper.hs other-modules: Phi.X11.AtomList, Phi.X11.Atoms, Phi.X11.Util @@ -34,4 +34,4 @@ executable Phi build-depends: base >= 4, phi hs-source-dirs: src main-is: Phi.hs - ghc-options: -threaded + ghc-options: -threaded diff --git a/src/Phi.hs b/src/Phi.hs index 5cab565..e20ef97 100644 --- a/src/Phi.hs +++ b/src/Phi.hs @@ -48,9 +48,9 @@ main = do --theSystray = systray - theClock = clock defaultClockConfig { clockFormat = "%R\n%A %d %B" + theClock = clock defaultClockConfig { clockFormat = "%R\n%a, %b %d" , lineSpacing = (-3) - , clockSize = 75 + , clockSize = 60 } brightBorder :: (Widget w s c d) => w -> Border w s c d brightBorder = border normalDesktopBorder diff --git a/src/SystrayHelper.hs b/src/SystrayHelper.hs index fb9adcf..02d97df 100644 --- a/src/SystrayHelper.hs +++ b/src/SystrayHelper.hs @@ -3,9 +3,8 @@ import Control.Monad import Data.Maybe import Graphics.XHB -import Graphics.XHB.Connection +import Graphics.XHB.Connection.XCB import Graphics.XHB.Gen.Xproto -import qualified Graphics.XHB.Connection.Open as CO import System.Exit @@ -31,8 +30,7 @@ main = do conn <- liftM fromJust connect atoms <- initAtoms conn - let dispname = displayInfo conn - screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname + let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn xembedWindow <- initSystray conn atoms screen From 3e1ca8091269fcd30a7d89cbe2f9d68d7447b0fc Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Mon, 17 Oct 2011 21:16:01 +0200 Subject: [PATCH 10/10] Renamed binaries to lowercase --- lib/Phi/X11.hs | 10 ++++++-- lib/Phi/X11/AtomList.hs | 1 + phi.cabal | 8 +++--- src/Phi.hs | 6 ++--- src/SystrayHelper.hs | 56 +++++++++++++++++++++++++++++++++-------- 5 files changed, 62 insertions(+), 19 deletions(-) diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index af4cb0b..7a673c3 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -167,12 +167,14 @@ runPhi xconfig config widget = do forM_ panels $ liftIO . mapWindow conn . panelWindow - liftIO $ forkIO $ receiveEvents phi conn + liftIO $ do + forkIO $ receiveEvents phi conn + forkIO $ receiveErrors phi conn forever $ do available <- messageAvailable phi repaint <- gets phiRepaint - when (not available && repaint) $ liftIO $ threadDelay 30000 + when (not available && repaint) $ liftIO $ threadDelay 20000 available <- messageAvailable phi when (not available && repaint) $ do @@ -311,6 +313,10 @@ receiveEvents :: Phi -> Connection -> IO () receiveEvents phi conn = forever $ receiveEvents' conn >>= sendMessages phi +receiveErrors :: Phi -> Connection -> IO () +receiveErrors phi conn = + forever $ waitForError conn >>= putStrLn . ("XHB error: " ++) . show + updatePanels :: (Widget w s c X11) => PhiX w s c () updatePanels = do X11 conn _ screen <- asks phiX11 diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index cad753a..bc91efa 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/lib/Phi/X11/AtomList.hs @@ -48,6 +48,7 @@ atoms = [ "ATOM" , "_XEMBED" , "_XROOTPMAP_ID" , "_XROOTMAP_ID" + , "PHI_SYSTRAY_HELPER" ] -- the expression must have the type (ConnectionClass c => c -> String) diff --git a/phi.cabal b/phi.cabal index 5100bda..2938ee6 100644 --- a/phi.cabal +++ b/phi.cabal @@ -20,17 +20,17 @@ library other-modules: Phi.X11.AtomList, Phi.Bindings.Cairo, Phi.X11.Atoms, Phi.X11.Util include-dirs: include hs-source-dirs: lib - pkgconfig-depends: xcb, cairo >= 1.2.0, cairo-xcb + pkgconfig-depends: cairo >= 1.2.0, cairo-xcb ghc-options: -fspec-constr-count=16 -threaded -executable PhiSystrayHelper - build-depends: base >= 4, template-haskell, xhb >= 0.5, xhb-xcb +executable phi-systray-helper + build-depends: base >= 4, template-haskell, mtl, xhb >= 0.5, xhb-xcb hs-source-dirs: src, lib main-is: SystrayHelper.hs other-modules: Phi.X11.AtomList, Phi.X11.Atoms, Phi.X11.Util ghc-options: -threaded -executable Phi +executable phi build-depends: base >= 4, phi hs-source-dirs: src main-is: Phi.hs diff --git a/src/Phi.hs b/src/Phi.hs index e20ef97..3f476f8 100644 --- a/src/Phi.hs +++ b/src/Phi.hs @@ -48,9 +48,9 @@ main = do --theSystray = systray - theClock = clock defaultClockConfig { clockFormat = "%R\n%a, %b %d" - , lineSpacing = (-3) - , clockSize = 60 + theClock = clock defaultClockConfig { clockFormat = "%R\n%a, %b %d" + , lineSpacing = (-1) + , clockSize = 55 } brightBorder :: (Widget w s c d) => w -> Border w s c d brightBorder = border normalDesktopBorder diff --git a/src/SystrayHelper.hs b/src/SystrayHelper.hs index 02d97df..f39176f 100644 --- a/src/SystrayHelper.hs +++ b/src/SystrayHelper.hs @@ -1,5 +1,8 @@ +import Control.Concurrent import Control.Monad +import Control.Monad.State.Strict +import Data.Word import Data.Maybe import Graphics.XHB @@ -12,38 +15,55 @@ import Phi.X11.Atoms import Phi.X11.Util -{-sYSTEM_TRAY_REQUEST_DOCK :: CInt +sYSTEM_TRAY_REQUEST_DOCK :: Word32 sYSTEM_TRAY_REQUEST_DOCK = 0 -sYSTEM_TRAY_BEGIN_MESSAGE :: CInt +sYSTEM_TRAY_BEGIN_MESSAGE :: Word32 sYSTEM_TRAY_BEGIN_MESSAGE = 1 -sYSTEM_TRAY_CANCEL_MESSAGE :: CInt +sYSTEM_TRAY_CANCEL_MESSAGE :: Word32 sYSTEM_TRAY_CANCEL_MESSAGE = 2 -xEMBED_EMBEDDED_NOTIFY :: CInt -xEMBED_EMBEDDED_NOTIFY = 0-} +xEMBED_EMBEDDED_NOTIFY :: Word32 +xEMBED_EMBEDDED_NOTIFY = 0 + + +data SystrayState = SystrayState + { systrayIcons :: [(WINDOW, WINDOW)] + } main :: IO () main = do conn <- liftM fromJust connect + forkIO $ receiveErrors conn + atoms <- initAtoms conn let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn - xembedWindow <- initSystray conn atoms screen + (xembedWin, systrayWin) <- initSystray conn atoms screen + + execStateT (runSystray xembedWin systrayWin) $ SystrayState [] return () +receiveErrors :: Connection -> IO () +receiveErrors conn = + forever $ waitForError conn >>= putStrLn . ("XHB error: " ++) . show -initSystray :: Connection -> Atoms -> SCREEN -> IO WINDOW +initSystray :: Connection -> Atoms -> SCREEN -> IO (WINDOW, WINDOW) initSystray conn atoms screen = do currentSystrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed" when (currentSystrayWin /= fromXid xidNone) $ do - putStrLn "PhiSystrayHelper: another systray is running." + putStrLn "phi-systray-helper: another systray is running." exitFailure + currentSystrayHelperWin <- getSelectionOwner conn (atomPHI_SYSTRAY_HELPER atoms) >>= getReply' "initSystray: getSelectionOwner failed" + when (currentSystrayHelperWin /= fromXid xidNone) $ do + putStrLn "phi-systray-helper: another systray helper is running." + exitFailure + let rootwin = root_SCREEN screen depth = root_depth_SCREEN screen visual = root_visual_SCREEN screen @@ -60,11 +80,27 @@ initSystray conn atoms screen = do systrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed" when (systrayWin /= xembedWin) $ do destroyWindow conn xembedWin - putStrLn $ "PhiSystrayHelper: can't initialize systray." + putStrLn $ "phi-systray-helper: can't initialize systray." exitFailure + systrayWin <- newResource conn + createWindow conn $ MkCreateWindow depth systrayWin rootwin (-1) (-1) 1 1 0 WindowClassInputOutput visual emptyValueParam + + setSelectionOwner conn $ MkSetSelectionOwner systrayWin (atomPHI_SYSTRAY_HELPER atoms) 0 + systrayHelperWin <- getSelectionOwner conn (atomPHI_SYSTRAY_HELPER atoms) >>= getReply' "initSystray: getSelectionOwner failed" + when (systrayHelperWin /= systrayWin) $ do + destroyWindow conn systrayHelperWin + destroyWindow conn xembedWin + putStrLn $ "phi-systray-helper: can't initialize systray helper." + exitFailure + sendEvent conn $ MkSendEvent False rootwin [EventMaskStructureNotify] $ serializeClientMessage $ MkClientMessageEvent 32 rootwin (atomMANAGER atoms) $ ClientData32 [0, fromXid . toXid $ atom_NET_SYSTEM_TRAY_SCREEN atoms, fromXid . toXid $ xembedWin, 0, 0] - return xembedWin + return (xembedWin, systrayWin) + + +runSystray :: WINDOW -> WINDOW -> StateT SystrayState IO () +runSystray xembedWin systrayWin = do + return ()