From 15d9304e052d2e5d4416e54a6fd24fbd0a252964 Mon Sep 17 00:00:00 2001
From: Matthias Schiffer <mschiffer@universe-factory.net>
Date: Wed, 7 Sep 2011 16:38:36 +0200
Subject: Converted core to XHB/XCB

---
 lib/Phi/Bindings/XCB.hsc | 92 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 92 insertions(+)
 create mode 100644 lib/Phi/Bindings/XCB.hsc

(limited to 'lib/Phi/Bindings/XCB.hsc')

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
-- 
cgit v1.2.3