blob: 32737ff19260ec3b261d325f215d164ad7185779 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
{-# 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
|
