summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/Bindings/XCB.hsc2
-rw-r--r--lib/Phi/Widgets/X11/Systray.hs12
-rw-r--r--lib/Phi/X11.hs3
-rw-r--r--lib/Phi/X11/AtomList.hs1
-rw-r--r--lib/Phi/X11/Util.hs39
5 files changed, 42 insertions, 15 deletions
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