Converted core to XHB/XCB

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