{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Bindings.GLX ( createColormap , createWindow , chooseFBConfig , getVisualFromFBConfig , XVisualInfo(..) , XSetWindowAttributes(..) , nullSetWindowAttributes , glXGetVisualFromFBConfig , glxRenderType , glxRgbaBit , glxDrawableType , glxWindowBit , glxXRenderable , glxDoublebuffer , glxDepthSize , glxStencilSize , glxTrue , glXCreateContext , glXMakeCurrent , GLXContext(..) ) where import Data.Generics import Data.Int import Data.Word import Foreign.C.Types import Foreign.Ptr import Foreign.Marshal.Alloc (alloca) 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) import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position) #include newtype GLXFBConfig = GLXFBConfig (Ptr GLXFBConfig) deriving (Eq, Ord, Show, Typeable, Data, Storable) newtype GLXContext = GLXContext (Ptr GLXContext) deriving (Eq, Ord, Show, Typeable, Data, Storable) newtype Visual = Visual (Ptr Visual) deriving (Eq, Ord, Show, Typeable, Data, Storable) data XVisualInfo = XVisualInfo { vi_visual :: !Visual , vi_visualid :: !VisualID , vi_screen :: !CInt , vi_depth :: !CInt , vi_class :: !CInt , vi_red_mask :: !CULong , vi_green_mask :: !CULong , vi_blue_mask :: !CULong , vi_colormap_size :: !CInt , vi_bits_per_rgb :: !CInt } deriving (Eq, Ord, Show, Typeable) instance Storable XVisualInfo 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 (XVisualInfo visual visualid screen depth viclass red_mask green_mask blue_mask colormap_size bits_per_rgb) poke vi (XVisualInfo 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 XSetWindowAttributes = XSetWindowAttributes { swa_background_pixmap :: !Pixmap , swa_packground_pixel :: !Pixel , swa_border_pixmap :: !Pixmap , swa_bit_gravity :: !CInt , swa_win_gravity :: !CInt , swa_backing_store :: !CInt , swa_backing_planes :: !CULong , swa_backing_pixel :: !CULong , swa_save_under :: !Bool , swa_event_mask :: !EventMask , swa_do_not_propagate_mask :: !CULong , swa_override_redirect :: !Bool , swa_colormap :: !Colormap , swa_cursor :: !Cursor } deriving (Eq, Ord, Show, Typeable) instance Storable XSetWindowAttributes 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 (XSetWindowAttributes 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 (XSetWindowAttributes 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 :: XSetWindowAttributes nullSetWindowAttributes = (XSetWindowAttributes 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 XSetWindowAttributes -> IO Window foreign import ccall unsafe "GL/glx.h glXChooseFBConfig" glXChooseFBConfig :: Display -> CInt -> Ptr CInt -> Ptr CInt -> IO (Ptr GLXFBConfig) chooseFBConfig :: Display -> CInt -> [(CInt, CInt)] -> IO [GLXFBConfig] 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 peekArray (fromIntegral nelements) configs glxRenderType :: CInt glxRenderType = (#const GLX_RENDER_TYPE) glxRgbaBit :: CInt glxRgbaBit = (#const GLX_RGBA_BIT) glxDrawableType :: CInt glxDrawableType = (#const GLX_DRAWABLE_TYPE) glxWindowBit :: CInt glxWindowBit = (#const GLX_WINDOW_BIT) glxXRenderable :: CInt glxXRenderable = (#const GLX_X_RENDERABLE) glxDoublebuffer :: CInt glxDoublebuffer = (#const GLX_DOUBLEBUFFER) glxDepthSize :: CInt glxDepthSize = (#const GLX_DEPTH_SIZE) glxStencilSize :: CInt glxStencilSize = (#const GLX_STENCIL_SIZE) glxTrue :: CInt glxTrue = (#const True) foreign import ccall unsafe "GL/glx.h glXGetVisualFromFBConfig" glXGetVisualFromFBConfig :: Display -> GLXFBConfig -> IO (Ptr XVisualInfo) getVisualFromFBConfig :: Display -> GLXFBConfig -> IO (XVisualInfo) getVisualFromFBConfig disp config = do vi <- glXGetVisualFromFBConfig disp config peek vi foreign import ccall unsafe "GL/glx.h glXCreateContext" glXCreateContext :: Display -> Ptr XVisualInfo -> GLXContext -> Bool -> IO GLXContext foreign import ccall unsafe "GL/glx.h glXMakeCurrent" glXMakeCurrent :: Display -> XID -> GLXContext -> IO Bool