90 lines
3.4 KiB
Haskell
90 lines
3.4 KiB
Haskell
{-# 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
|
|
|