93 lines
3.2 KiB
Text
93 lines
3.2 KiB
Text
|
{-# 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
|