summaryrefslogtreecommitdiffstats
path: root/src/Bindings/GLX.hsc
diff options
context:
space:
mode:
Diffstat (limited to 'src/Bindings/GLX.hsc')
-rw-r--r--src/Bindings/GLX.hsc265
1 files changed, 265 insertions, 0 deletions
diff --git a/src/Bindings/GLX.hsc b/src/Bindings/GLX.hsc
new file mode 100644
index 0000000..d5fed4d
--- /dev/null
+++ b/src/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 <GL/glx.h>
+
+
+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 ()
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-06 00:41:07 +0200