Converted core to XHB/XCB
This commit is contained in:
parent
42d5f27d32
commit
15d9304e05
11 changed files with 433 additions and 368 deletions
|
|
@ -1,17 +0,0 @@
|
|||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||
|
||||
module Phi.Bindings.SystrayErrorHandler ( setSystrayErrorHandler
|
||||
, getLastErrorWindow
|
||||
) where
|
||||
|
||||
#include <SystrayErrorHandler.h>
|
||||
|
||||
|
||||
import Graphics.X11.Xlib
|
||||
|
||||
|
||||
foreign import ccall unsafe "SystrayErrorHandler.h setSystrayErrorHandler"
|
||||
setSystrayErrorHandler :: IO ()
|
||||
|
||||
foreign import ccall unsafe "SystrayErrorHandler.h getLastErrorWindow"
|
||||
getLastErrorWindow :: IO Window
|
||||
|
|
@ -1,90 +0,0 @@
|
|||
{-# 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
|
||||
|
||||
92
lib/Phi/Bindings/XCB.hsc
Normal file
92
lib/Phi/Bindings/XCB.hsc
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
{-# 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
|
||||
Reference in a new issue