phi/lib/Phi/Bindings/Util.hsc

{-# LANGUAGE ForeignFunctionInterface #-}

module Phi.Bindings.Util ( setClassHint
                         , visualIDFromVisual
                         , putClientMessage
                         , createXlibSurface
                         ) where


#include <X11/Xlib.h>
#include <X11/Xutil.h>
#include <cairo.h>
#include <cairo-xlib.h>


import Foreign.C.String (withCString)
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Marshal.Array
import Foreign.Storable

import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras

import Graphics.Rendering.Cairo.Types


foreign import ccall unsafe "X11/Xutil.h XSetClassHint"
  xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO ()

setClassHint :: Display -> Window -> ClassHint -> IO ()
setClassHint disp wnd hint = allocaBytes (#size XClassHint) $ \p ->
  withCString (resName hint) $ \res_name ->
  withCString (resClass hint) $ \res_class -> do
    (#poke XClassHint, res_name) p res_name
    (#poke XClassHint, res_class) p res_class
    xSetClassHint disp wnd p

foreign import ccall unsafe "X11/Xlib.h XVisualIDFromVisual"
  visualIDFromVisual :: Visual -> VisualID

putClientMessage :: XEventPtr -> Window -> Atom -> [CLong] -> IO ()
putClientMessage event window message_type messageData = do
  setEventType event clientMessage
  (#poke XClientMessageEvent, window) event window
  (#poke XClientMessageEvent, message_type) event message_type
  (#poke XClientMessageEvent, format) event (32 :: CInt)
  pokeArray ((#ptr XClientMessageEvent, data.l) event) $ take 5 messageData

foreign import ccall unsafe "cairo-xlib.h cairo_xlib_surface_create"
  xlibSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> IO (Ptr Surface)

createXlibSurface :: Display -> Drawable -> Visual -> CInt -> CInt -> IO Surface
createXlibSurface dpy drawable visual width height = do
  surfacePtr <- xlibSurfaceCreate dpy drawable visual width height
  surface <- mkSurface surfacePtr
  manageSurface surface
  return surface