331 lines
12 KiB
Haskell
331 lines
12 KiB
Haskell
{-# INCLUDE <GL/glx.h> #-}
|
|
{-# LINE 1 "GLX.chs" #-}
|
|
{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
|
|
{-# LINE 2 "GLX.chs" #-}
|
|
|
|
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.ForeignPtr
|
|
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)
|
|
|
|
|
|
|
|
{-# LINE 45 "GLX.chs" #-}
|
|
|
|
|
|
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 _ = ((40))
|
|
{-# LINE 73 "GLX.chs" #-}
|
|
alignment _ = alignment (undefined :: CULong)
|
|
|
|
peek vi = do
|
|
visual <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) vi
|
|
{-# LINE 77 "GLX.chs" #-}
|
|
visualid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) vi
|
|
{-# LINE 78 "GLX.chs" #-}
|
|
screen <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) vi
|
|
{-# LINE 79 "GLX.chs" #-}
|
|
depth <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) vi
|
|
{-# LINE 80 "GLX.chs" #-}
|
|
viclass <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) vi
|
|
{-# LINE 81 "GLX.chs" #-}
|
|
red_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) vi
|
|
{-# LINE 82 "GLX.chs" #-}
|
|
green_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) vi
|
|
{-# LINE 83 "GLX.chs" #-}
|
|
blue_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) vi
|
|
{-# LINE 84 "GLX.chs" #-}
|
|
colormap_size <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) vi
|
|
{-# LINE 85 "GLX.chs" #-}
|
|
bits_per_rgb <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) vi
|
|
{-# LINE 86 "GLX.chs" #-}
|
|
|
|
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
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) vi visual
|
|
{-# LINE 92 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) vi visualid
|
|
{-# LINE 93 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) vi screen
|
|
{-# LINE 94 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) vi depth
|
|
{-# LINE 95 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) vi viclass
|
|
{-# LINE 96 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) vi red_mask
|
|
{-# LINE 97 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) vi green_mask
|
|
{-# LINE 98 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) vi blue_mask
|
|
{-# LINE 99 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) vi colormap_size
|
|
{-# LINE 100 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) vi bits_per_rgb
|
|
{-# LINE 101 "GLX.chs" #-}
|
|
|
|
|
|
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 _ = ((60))
|
|
{-# LINE 122 "GLX.chs" #-}
|
|
alignment _ = alignment (undefined :: CULong)
|
|
|
|
peek swa = do
|
|
background_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) swa
|
|
{-# LINE 126 "GLX.chs" #-}
|
|
background_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) swa
|
|
{-# LINE 127 "GLX.chs" #-}
|
|
border_pixmap <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) swa
|
|
{-# LINE 128 "GLX.chs" #-}
|
|
bit_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) swa
|
|
{-# LINE 129 "GLX.chs" #-}
|
|
win_gravity <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) swa
|
|
{-# LINE 130 "GLX.chs" #-}
|
|
backing_store <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) swa
|
|
{-# LINE 131 "GLX.chs" #-}
|
|
backing_planes <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) swa
|
|
{-# LINE 132 "GLX.chs" #-}
|
|
backing_pixel <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) swa
|
|
{-# LINE 133 "GLX.chs" #-}
|
|
save_under <- ((\hsc_ptr -> peekByteOff hsc_ptr 36)) swa
|
|
{-# LINE 134 "GLX.chs" #-}
|
|
event_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 40)) swa
|
|
{-# LINE 135 "GLX.chs" #-}
|
|
do_not_propagate_mask <- ((\hsc_ptr -> peekByteOff hsc_ptr 44)) swa
|
|
{-# LINE 136 "GLX.chs" #-}
|
|
override_redirect <- ((\hsc_ptr -> peekByteOff hsc_ptr 48)) swa
|
|
{-# LINE 137 "GLX.chs" #-}
|
|
colormap <- ((\hsc_ptr -> peekByteOff hsc_ptr 52)) swa
|
|
{-# LINE 138 "GLX.chs" #-}
|
|
cursor <- ((\hsc_ptr -> peekByteOff hsc_ptr 56)) swa
|
|
{-# LINE 139 "GLX.chs" #-}
|
|
|
|
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
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) swa background_pixmap
|
|
{-# LINE 172 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) swa background_pixel
|
|
{-# LINE 173 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) swa border_pixmap
|
|
{-# LINE 174 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) swa bit_gravity
|
|
{-# LINE 175 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) swa win_gravity
|
|
{-# LINE 176 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) swa backing_store
|
|
{-# LINE 177 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) swa backing_planes
|
|
{-# LINE 178 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) swa backing_pixel
|
|
{-# LINE 179 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) swa save_under
|
|
{-# LINE 180 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) swa event_mask
|
|
{-# LINE 181 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) swa do_not_propagate_mask
|
|
{-# LINE 182 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 48)) swa override_redirect
|
|
{-# LINE 183 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 52)) swa colormap
|
|
{-# LINE 184 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 56)) swa cursor
|
|
{-# LINE 185 "GLX.chs" #-}
|
|
|
|
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 ((8)) $ \p ->
|
|
{-# LINE 203 "GLX.chs" #-}
|
|
withCString (resName hint) $ \res_name ->
|
|
withCString (resClass hint) $ \res_class -> do
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p res_name
|
|
{-# LINE 206 "GLX.chs" #-}
|
|
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p res_class
|
|
{-# LINE 207 "GLX.chs" #-}
|
|
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 = (32785)
|
|
{-# LINE 224 "GLX.chs" #-}
|
|
|
|
rgbaBit :: CInt
|
|
rgbaBit = (1)
|
|
{-# LINE 227 "GLX.chs" #-}
|
|
|
|
drawableType :: CInt
|
|
drawableType = (32784)
|
|
{-# LINE 230 "GLX.chs" #-}
|
|
|
|
windowBit :: CInt
|
|
windowBit = (1)
|
|
{-# LINE 233 "GLX.chs" #-}
|
|
|
|
xRenderable :: CInt
|
|
xRenderable = (32786)
|
|
{-# LINE 236 "GLX.chs" #-}
|
|
|
|
doublebuffer :: CInt
|
|
doublebuffer = (5)
|
|
{-# LINE 239 "GLX.chs" #-}
|
|
|
|
depthSize :: CInt
|
|
depthSize = (12)
|
|
{-# LINE 242 "GLX.chs" #-}
|
|
|
|
stencilSize :: CInt
|
|
stencilSize = (13)
|
|
{-# LINE 245 "GLX.chs" #-}
|
|
|
|
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 ()
|