neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

SystrayHelper: initialization

Browse source
This commit is contained in:
Matthias Schiffer 2011-09-09 03:20:16 +02:00
parent 4d519acbd4
commit 2ae89a5e33
7 changed files with 123 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/Phi/Bindings/XCB.hsc
View file

@ -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 ()

12
lib/Phi/Widgets/X11/Systray.hs
View file

@ -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

3
lib/Phi/X11.hs
View file

@ -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 }

1
lib/Phi/X11/AtomList.hs
View file

@ -13,6 +13,7 @@ atoms :: [String]
atoms = [ "ATOM"
, "CARDINAL"
, "STRING"
, "VISUALID"
, "UTF8_STRING"
, "WM_NAME"
, "WM_CLASS"

37
lib/Phi/X11/Util.hs
View file

@ -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
@ -87,3 +96,31 @@ 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
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

12
phi.cabal
View file

@ -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

71
src/SystrayHelper.hs Normal file
View file

@ -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