summaryrefslogtreecommitdiffstats
path: root/lib/Phi/Bindings
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi/Bindings')
-rw-r--r--lib/Phi/Bindings/SystrayErrorHandler.hsc17
-rw-r--r--lib/Phi/Bindings/Util.hsc90
-rw-r--r--lib/Phi/Bindings/XCB.hsc92
3 files changed, 92 insertions, 107 deletions
diff --git a/lib/Phi/Bindings/SystrayErrorHandler.hsc b/lib/Phi/Bindings/SystrayErrorHandler.hsc
deleted file mode 100644
index 73fedbb..0000000
--- a/lib/Phi/Bindings/SystrayErrorHandler.hsc
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-
-module Phi.Bindings.SystrayErrorHandler ( setSystrayErrorHandler
- , getLastErrorWindow
- ) where
-
-#include <SystrayErrorHandler.h>
-
-
-import Graphics.X11.Xlib
-
-
-foreign import ccall unsafe "SystrayErrorHandler.h setSystrayErrorHandler"
- setSystrayErrorHandler :: IO ()
-
-foreign import ccall unsafe "SystrayErrorHandler.h getLastErrorWindow"
- getLastErrorWindow :: IO Window
diff --git a/lib/Phi/Bindings/Util.hsc b/lib/Phi/Bindings/Util.hsc
deleted file mode 100644
index bae6c71..0000000
--- a/lib/Phi/Bindings/Util.hsc
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-
-module Phi.Bindings.Util ( setClassHint
- , visualIDFromVisual
- , putClientMessage
- , Phi.Bindings.Util.getEvent
- , createXlibSurface
- ) where
-
-
-#include <X11/Xlib.h>
-#include <X11/Xutil.h>
-#include <cairo.h>
-#include <cairo-xlib.h>
-
-
-import Foreign.C.String (withCString)
-import Foreign.C.Types
-import Foreign.Ptr
-import Foreign.Marshal.Alloc (alloca, allocaBytes)
-import Foreign.Marshal.Array
-import Foreign.Storable
-
-import Graphics.X11.Xlib
-import Graphics.X11.Xlib.Extras
-
-import Graphics.Rendering.Cairo.Types
-
-
-foreign import ccall unsafe "X11/Xutil.h XSetClassHint"
- xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO ()
-
-setClassHint :: Display -> Window -> ClassHint -> IO ()
-setClassHint disp wnd hint = allocaBytes (#size XClassHint) $ \p ->
- withCString (resName hint) $ \res_name ->
- withCString (resClass hint) $ \res_class -> do
- (#poke XClassHint, res_name) p res_name
- (#poke XClassHint, res_class) p res_class
- xSetClassHint disp wnd p
-
-foreign import ccall unsafe "X11/Xlib.h XVisualIDFromVisual"
- visualIDFromVisual :: Visual -> VisualID
-
-putClientMessage :: XEventPtr -> Window -> Atom -> [CLong] -> IO ()
-putClientMessage event window message_type messageData = do
- setEventType event clientMessage
- (#poke XClientMessageEvent, window) event window
- (#poke XClientMessageEvent, message_type) event message_type
- (#poke XClientMessageEvent, format) event (32 :: CInt)
- pokeArray ((#ptr XClientMessageEvent, data.l) event) $ take 5 messageData
-
-foreign import ccall unsafe "cairo-xlib.h cairo_xlib_surface_create"
- xlibSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> IO (Ptr Surface)
-
-getEvent :: Display -> XEventPtr -> IO Event
-getEvent display p = do
- eventType <- get_EventType p
- case True of
- _ | eventType == clientMessage -> do
- serial <- (#peek XClientMessageEvent, serial) p
- send_event <- (#peek XClientMessageEvent, send_event) p
- window <- (#peek XClientMessageEvent, window) p
- message_type <- (#peek XClientMessageEvent, message_type) p
- format <- (#peek XClientMessageEvent, format) p
- let datPtr = (#ptr XClientMessageEvent, data) p
- dat <- case (format::CInt) of
- 8 -> do a <- peekArray 20 datPtr
- return $ map fromIntegral (a::[CUChar])
- 16 -> do a <- peekArray 10 datPtr
- return $ map fromIntegral (a::[CUShort])
- 32 -> do a <- peekArray 5 datPtr
- return $ map fromIntegral (a::[CULong])
- return $ ClientMessageEvent { ev_event_type = eventType
- , ev_serial = serial
- , ev_send_event = send_event
- , ev_event_display = display
- , ev_window = window
- , ev_message_type = message_type
- , ev_data = dat
- }
- | otherwise -> Graphics.X11.Xlib.Extras.getEvent p
-
-
-createXlibSurface :: Display -> Drawable -> Visual -> CInt -> CInt -> IO Surface
-createXlibSurface dpy drawable visual width height = do
- surfacePtr <- xlibSurfaceCreate dpy drawable visual width height
- surface <- mkSurface surfacePtr
- manageSurface surface
- return surface
-
diff --git a/lib/Phi/Bindings/XCB.hsc b/lib/Phi/Bindings/XCB.hsc
new file mode 100644
index 0000000..33aff03
--- /dev/null
+++ b/lib/Phi/Bindings/XCB.hsc
@@ -0,0 +1,92 @@
+{-# 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 <xcb/xcb.h>
+#include <xcb/xproto.h>
+#include <cairo-xcb.h>
+
+
+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 "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
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-17 05:03:20 +0200