summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Phi/X11.hs10
-rw-r--r--lib/Phi/X11/AtomList.hs1
-rw-r--r--phi.cabal8
-rw-r--r--src/Phi.hs6
-rw-r--r--src/SystrayHelper.hs56
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 = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%a, %b %d</span>"
- , lineSpacing = (-3)
- , clockSize = 60
+ theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 7'>%R</span>\n<span font='Sans 6'>%a, %b %d</span>"
+ , 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 ()
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 09:30:56 +0100