From 9ca9555fede912e5a3c9cebaa2050bb2c7cc7b1c Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Thu, 25 Feb 2010 04:49:30 +0100 Subject: Renamed some files and added Makefile --- Bindings/GLX.hsc | 265 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 265 insertions(+) create mode 100644 Bindings/GLX.hsc (limited to 'Bindings/GLX.hsc') diff --git a/Bindings/GLX.hsc b/Bindings/GLX.hsc new file mode 100644 index 0000000..d5fed4d --- /dev/null +++ b/Bindings/GLX.hsc @@ -0,0 +1,265 @@ +{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +module Bindings.GLX ( createColormap + , createWindow + , setClassHint + , chooseFBConfig + , getVisualFromFBConfig + , VisualInfo(..) + , SetWindowAttributes(..) + , nullSetWindowAttributes + , renderType + , rgbaBit + , drawableType + , windowBit + , xRenderable + , doublebuffer + , depthSize + , stencilSize + , createContext + , makeCurrent + , destroyContext + , swapBuffers + , Context(..) + , Drawable + ) where + +import Data.Generics +import Data.Int +import Data.Word + +import Foreign.C.String (withCString) +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Marshal.Array (peekArray, withArray0) +import Foreign.Storable + +import Graphics.X11.Types (AttributeMask, Colormap, ColormapAlloc, Cursor, EventMask, Pixmap, Window, WindowClass, VisualID, XID) +import Graphics.X11.Xlib.Extras (none, xFree, ClassHint, resName, resClass, TextProperty) +import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position) + + +#include + + +type Drawable = XID + +newtype FBConfig = FBConfig (Ptr FBConfig) + deriving (Eq, Ord, Show, Typeable, Data, Storable) + +newtype Context = Context (Ptr Context) + deriving (Eq, Ord, Show, Typeable, Data, Storable) + +newtype Visual = Visual (Ptr Visual) + deriving (Eq, Ord, Show, Typeable, Data, Storable) + +data VisualInfo = VisualInfo + { viVisual :: !Visual + , viVisualid :: !VisualID + , viScreen :: !CInt + , viDepth :: !CInt + , viClass :: !CInt + , viRedMask :: !CULong + , viGreenMask :: !CULong + , viBlueMask :: !CULong + , viColormapSize :: !CInt + , viBitsPerRgb :: !CInt + } deriving (Eq, Ord, Show, Typeable) + +instance Storable VisualInfo where + sizeOf _ = (#size XVisualInfo) + alignment _ = alignment (undefined :: CULong) + + peek vi = do + visual <- (#peek XVisualInfo, visual) vi + visualid <- (#peek XVisualInfo, visualid) vi + screen <- (#peek XVisualInfo, screen) vi + depth <- (#peek XVisualInfo, depth) vi + viclass <- (#peek XVisualInfo, class) vi + red_mask <- (#peek XVisualInfo, red_mask) vi + green_mask <- (#peek XVisualInfo, green_mask) vi + blue_mask <- (#peek XVisualInfo, blue_mask) vi + colormap_size <- (#peek XVisualInfo, colormap_size) vi + bits_per_rgb <- (#peek XVisualInfo, bits_per_rgb) vi + + return (VisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb) + + + poke vi (VisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb) = do + (#poke XVisualInfo, visual) vi visual + (#poke XVisualInfo, visualid) vi visualid + (#poke XVisualInfo, screen) vi screen + (#poke XVisualInfo, depth) vi depth + (#poke XVisualInfo, class) vi viclass + (#poke XVisualInfo, red_mask) vi red_mask + (#poke XVisualInfo, green_mask) vi green_mask + (#poke XVisualInfo, blue_mask) vi blue_mask + (#poke XVisualInfo, colormap_size) vi colormap_size + (#poke XVisualInfo, bits_per_rgb) vi bits_per_rgb + + +data SetWindowAttributes = SetWindowAttributes + { swaBackgroundPixmap :: !Pixmap + , swaBackgroundPixel :: !Pixel + , swaBorderPixmap :: !Pixmap + , swaBitGravity :: !CInt + , swaWinGravity :: !CInt + , swaBackingStore :: !CInt + , swaBackingPlanes :: !CULong + , swaBackingPixel :: !CULong + , swaSaveUnder :: !Bool + , swaEventMask :: !EventMask + , swaDoNotPropagateMask :: !CULong + , swaOverrideRedirect :: !Bool + , swaColormap :: !Colormap + , swaCursor :: !Cursor + } deriving (Eq, Ord, Show, Typeable) + +instance Storable SetWindowAttributes where + sizeOf _ = (#size XSetWindowAttributes) + alignment _ = alignment (undefined :: CULong) + + peek swa = do + background_pixmap <- (#peek XSetWindowAttributes, background_pixmap) swa + background_pixel <- (#peek XSetWindowAttributes, background_pixel) swa + border_pixmap <- (#peek XSetWindowAttributes, border_pixmap) swa + bit_gravity <- (#peek XSetWindowAttributes, bit_gravity) swa + win_gravity <- (#peek XSetWindowAttributes, win_gravity) swa + backing_store <- (#peek XSetWindowAttributes, backing_store) swa + backing_planes <- (#peek XSetWindowAttributes, backing_planes) swa + backing_pixel <- (#peek XSetWindowAttributes, backing_pixel) swa + save_under <- (#peek XSetWindowAttributes, save_under) swa + event_mask <- (#peek XSetWindowAttributes, event_mask) swa + do_not_propagate_mask <- (#peek XSetWindowAttributes, do_not_propagate_mask) swa + override_redirect <- (#peek XSetWindowAttributes, override_redirect) swa + colormap <- (#peek XSetWindowAttributes, colormap) swa + cursor <- (#peek XSetWindowAttributes, cursor) swa + + return (SetWindowAttributes + background_pixmap + background_pixel + border_pixmap + bit_gravity + win_gravity + backing_store + backing_planes + backing_pixel + save_under + event_mask + do_not_propagate_mask + override_redirect + colormap + cursor) + + poke swa (SetWindowAttributes + background_pixmap + background_pixel + border_pixmap + bit_gravity + win_gravity + backing_store + backing_planes + backing_pixel + save_under + event_mask + do_not_propagate_mask + override_redirect + colormap + cursor) = do + (#poke XSetWindowAttributes, background_pixmap) swa background_pixmap + (#poke XSetWindowAttributes, background_pixel) swa background_pixel + (#poke XSetWindowAttributes, border_pixmap) swa border_pixmap + (#poke XSetWindowAttributes, bit_gravity) swa bit_gravity + (#poke XSetWindowAttributes, win_gravity) swa win_gravity + (#poke XSetWindowAttributes, backing_store) swa backing_store + (#poke XSetWindowAttributes, backing_planes) swa backing_planes + (#poke XSetWindowAttributes, backing_pixel) swa backing_pixel + (#poke XSetWindowAttributes, save_under) swa save_under + (#poke XSetWindowAttributes, event_mask) swa event_mask + (#poke XSetWindowAttributes, do_not_propagate_mask) swa do_not_propagate_mask + (#poke XSetWindowAttributes, override_redirect) swa override_redirect + (#poke XSetWindowAttributes, colormap) swa colormap + (#poke XSetWindowAttributes, cursor) swa cursor + +nullSetWindowAttributes :: SetWindowAttributes +nullSetWindowAttributes = (SetWindowAttributes 0 0 0 0 0 0 0 0 False 0 0 False 0 0) + + +foreign import ccall unsafe "GL/glx.h XCreateColormap" + createColormap :: Display -> Window -> Visual -> ColormapAlloc -> IO Colormap + +foreign import ccall unsafe "GL/glx.h XCreateWindow" + createWindow :: Display -> Window -> Position -> Position -> + Dimension -> Dimension -> CInt -> CInt -> WindowClass -> + Visual -> AttributeMask -> Ptr SetWindowAttributes -> IO Window + +foreign import ccall unsafe "GL/glx.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 "GL/glx.h glXChooseFBConfig" + glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr FBConfig) + +chooseFBConfig :: Display -> CInt -> [(CInt, CInt)] -> IO [FBConfig] +chooseFBConfig disp sc attr = alloca $ \n -> withArray0 (fromIntegral none) (concatMap (\(a,b) -> [a,b]) attr) $ \attrp -> do + configs <- glXChooseFBConfig disp sc attrp n + nelements <- peek n + configlist <- peekArray (fromIntegral nelements) configs + xFree configs + return configlist + + +renderType :: CInt +renderType = (#const GLX_RENDER_TYPE) + +rgbaBit :: CInt +rgbaBit = (#const GLX_RGBA_BIT) + +drawableType :: CInt +drawableType = (#const GLX_DRAWABLE_TYPE) + +windowBit :: CInt +windowBit = (#const GLX_WINDOW_BIT) + +xRenderable :: CInt +xRenderable = (#const GLX_X_RENDERABLE) + +doublebuffer :: CInt +doublebuffer = (#const GLX_DOUBLEBUFFER) + +depthSize :: CInt +depthSize = (#const GLX_DEPTH_SIZE) + +stencilSize :: CInt +stencilSize = (#const GLX_STENCIL_SIZE) + +foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig" + glXGetVisualFromFBConfig :: Display -> FBConfig -> IO (Ptr VisualInfo) + +getVisualFromFBConfig :: Display -> FBConfig -> IO (VisualInfo) +getVisualFromFBConfig disp config = do + viptr <- glXGetVisualFromFBConfig disp config + vi <- peek viptr + xFree viptr + return vi + +foreign import ccall unsafe "GL/glx.h glXCreateContext" + createContext :: Display -> Ptr VisualInfo -> Context -> Bool -> IO Context + +foreign import ccall unsafe "GL/glx.h glXMakeCurrent" + makeCurrent :: Display -> Drawable -> Context -> IO Bool + +foreign import ccall unsafe "GL/glx.h glXDestroyContext" + destroyContext :: Display -> Context -> IO () + +foreign import ccall unsafe "GL/glx.h glXSwapBuffers" + swapBuffers :: Display -> Drawable -> IO () -- cgit v1.2.3