{-# 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