{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Bindings.GLX ( createColormap , createWindow , chooseFBConfig , getVisualFromFBConfig , VisualInfo(..) , SetWindowAttributes(..) , nullSetWindowAttributes , renderType , rgbaBit , drawableType , windowBit , xRenderable , doublebuffer , depthSize , stencilSize , createContext , makeCurrent , Context(..) ) where import Data.Generics import Data.Int import Data.Word import Foreign.C.Types import Foreign.ForeignPtr 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, xFree) import Graphics.X11.Xlib.Types (Dimension, Display, Pixel, Position) #include 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 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 -> XID -> Context -> IO Bool