1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
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
|
