From 2ae89a5e3348fbe94b50a985de9766689c22d011 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Fri, 9 Sep 2011 03:20:16 +0200 Subject: 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 -- cgit v1.2.3