diff options
Diffstat (limited to 'lib/Phi/Bindings/Cairo.hsc')
-rw-r--r-- | lib/Phi/Bindings/Cairo.hsc | 51 |
1 files changed, 51 insertions, 0 deletions
diff --git a/lib/Phi/Bindings/Cairo.hsc b/lib/Phi/Bindings/Cairo.hsc new file mode 100644 index 0000000..246bc13 --- /dev/null +++ b/lib/Phi/Bindings/Cairo.hsc @@ -0,0 +1,51 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Phi.Bindings.Cairo ( createXCBSurface + ) where + +import Control.Monad + +import Data.Int +import Data.Word + +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.Connection.XCB +import Graphics.XHB.Gen.Xproto (DRAWABLE, VISUALTYPE(..)) + + +#include <cairo-xcb.h> + + +foreign import ccall "cairo-xlib.h cairo_xcb_surface_create" + cairo_xcb_surface_create :: Ptr XCBConnection -> 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 conn drawable visual width height = + with visual $ \visualptr -> withConnection conn $ \connptr -> do + surfacePtr <- cairo_xcb_surface_create connptr drawable visualptr width height + surface <- mkSurface surfacePtr + manageSurface surface + return surface |