From 15d9304e052d2e5d4416e54a6fd24fbd0a252964 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Wed, 7 Sep 2011 16:38:36 +0200 Subject: Converted core to XHB/XCB --- lib/Phi/Bindings/SystrayErrorHandler.hsc | 17 ------ lib/Phi/Bindings/Util.hsc | 90 ------------------------------- lib/Phi/Bindings/XCB.hsc | 92 ++++++++++++++++++++++++++++++++ 3 files changed, 92 insertions(+), 107 deletions(-) delete mode 100644 lib/Phi/Bindings/SystrayErrorHandler.hsc delete mode 100644 lib/Phi/Bindings/Util.hsc create mode 100644 lib/Phi/Bindings/XCB.hsc (limited to 'lib/Phi/Bindings') diff --git a/lib/Phi/Bindings/SystrayErrorHandler.hsc b/lib/Phi/Bindings/SystrayErrorHandler.hsc deleted file mode 100644 index 73fedbb..0000000 --- a/lib/Phi/Bindings/SystrayErrorHandler.hsc +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module Phi.Bindings.SystrayErrorHandler ( setSystrayErrorHandler - , getLastErrorWindow - ) where - -#include - - -import Graphics.X11.Xlib - - -foreign import ccall unsafe "SystrayErrorHandler.h setSystrayErrorHandler" - setSystrayErrorHandler :: IO () - -foreign import ccall unsafe "SystrayErrorHandler.h getLastErrorWindow" - getLastErrorWindow :: IO Window diff --git a/lib/Phi/Bindings/Util.hsc b/lib/Phi/Bindings/Util.hsc deleted file mode 100644 index bae6c71..0000000 --- a/lib/Phi/Bindings/Util.hsc +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module Phi.Bindings.Util ( setClassHint - , visualIDFromVisual - , putClientMessage - , Phi.Bindings.Util.getEvent - , createXlibSurface - ) where - - -#include -#include -#include -#include - - -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 - diff --git a/lib/Phi/Bindings/XCB.hsc b/lib/Phi/Bindings/XCB.hsc new file mode 100644 index 0000000..33aff03 --- /dev/null +++ b/lib/Phi/Bindings/XCB.hsc @@ -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 +#include +#include + + +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 -- cgit v1.2.3