phi/lib/Phi/Bindings/Util.hsc

{-# LANGUAGE ForeignFunctionInterface #-}

module Phi.Bindings.Util ( setClassHint
                         , visualIDFromVisual
                         , putClientMessage
                         , Phi.Bindings.Util.getEvent
                         , 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)

getEvent :: Display -> XEventPtr -> IO Event
getEvent display p = do
  eventType <- get_EventType p
  case True of
    _ | eventType == clientMessage -> do
      serial       <- (#peek XClientMessageEvent, serial) p
      send_event   <- (#peek XClientMessageEvent, send_event) p
      window       <- (#peek XClientMessageEvent, window) p
      message_type <- (#peek XClientMessageEvent, message_type) p
      format       <- (#peek XClientMessageEvent, format) p
      let datPtr =    (#ptr XClientMessageEvent, data) p
      dat          <- case (format::CInt) of
        8  -> do a <- peekArray 20 datPtr
                 return $ map fromIntegral (a::[CUChar])
        16 -> do a <- peekArray 10 datPtr
                 return $ map fromIntegral (a::[CUShort])
        32 -> do a <- peekArray 5 datPtr
                 return $ map fromIntegral (a::[CULong])
      return $ ClientMessageEvent { ev_event_type    = eventType
                                  , ev_serial        = serial
                                  , ev_send_event    = send_event
                                  , ev_event_display = display
                                  , ev_window        = window
                                  , ev_message_type  = message_type
                                  , ev_data          = dat
                                  }
      | otherwise -> Graphics.X11.Xlib.Extras.getEvent p


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