74 lines
2.3 KiB
Haskell
74 lines
2.3 KiB
Haskell
|
module GLX ( glxDriver
|
||
|
|
) where
|
||
|
|
|
||
|
|
import GLDriver
|
||
|
|
import Bindings.GLX
|
||
|
|
|
||
|
|
import Control.Monad (when, unless)
|
||
|
|
|
||
|
|
import Data.Bits ((.|.))
|
||
|
|
|
||
|
|
import Graphics.X11.Types
|
||
|
|
import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow)
|
||
|
|
import Graphics.X11.Xlib.Event (allocaXEvent, nextEvent, get_Window, get_EventType)
|
||
|
|
import Graphics.X11.Xlib.Types
|
||
|
|
import Graphics.X11.Xlib.Window (mapWindow)
|
||
|
|
|
||
|
|
import Foreign.Marshal.Utils (with)
|
||
|
|
import Foreign.Ptr
|
||
|
|
import Foreign.Storable
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
data GLX = GLX Bool
|
||
|
|
|
||
|
|
glxDriver :: GLX
|
||
|
|
glxDriver = GLX False
|
||
|
|
|
||
|
|
|
||
|
|
instance GLDriver GLX where
|
||
|
|
initialized (GLX inited) = inited
|
||
|
|
|
||
|
|
initGL (GLX inited) = do
|
||
|
|
when (inited) $ fail "GLX already initialized"
|
||
|
|
|
||
|
|
disp <- openDisplay ""
|
||
|
|
fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp)
|
||
|
|
[(glxRenderType, glxRgbaBit)
|
||
|
|
, (glxDrawableType, glxWindowBit)
|
||
|
|
, (glxXRenderable, glxTrue)
|
||
|
|
, (glxDepthSize, 1)
|
||
|
|
, (glxStencilSize, 1)
|
||
|
|
]
|
||
|
|
visualinfo <- getVisualFromFBConfig disp (head fbconfigs)
|
||
|
|
rootwindow <- rootWindow disp (fromIntegral $ vi_screen visualinfo)
|
||
|
|
cmap <- createColormap disp rootwindow (vi_visual visualinfo) allocNone
|
||
|
|
|
||
|
|
let swa = nullSetWindowAttributes {swa_colormap = cmap, swa_event_mask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask}
|
||
|
|
|
||
|
|
wnd <- with swa $ \swaptr -> createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ vi_depth visualinfo) inputOutput (vi_visual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr
|
||
|
|
mapWindow disp wnd
|
||
|
|
|
||
|
|
waitForMapNotify disp wnd
|
||
|
|
|
||
|
|
ctx <- with visualinfo $ \vi -> glXCreateContext disp vi (GLXContext nullPtr) True
|
||
|
|
glXMakeCurrent disp wnd ctx
|
||
|
|
|
||
|
|
return (GLX True)
|
||
|
|
|
||
|
|
deinitGL _ = return ()
|
||
|
|
|
||
|
|
nextEvent _ = return Nothing
|
||
|
|
|
||
|
|
|
||
|
|
waitForMapNotify :: Display -> Window -> IO ()
|
||
|
|
waitForMapNotify disp wnd = allocaXEvent waitForMapNotify'
|
||
|
|
where
|
||
|
|
waitForMapNotify' event = do
|
||
|
|
Graphics.X11.Xlib.Event.nextEvent disp event
|
||
|
|
window <- get_Window event
|
||
|
|
eventType <- get_EventType event
|
||
|
|
unless (window == wnd && eventType == mapNotify) $
|
||
|
|
waitForMapNotify' event
|
||
|
|
|
||
|
|
|