74 lines
No EOL
2.2 KiB
Haskell
74 lines
No EOL
2.2 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 Driver GLX where
|
|
initialized (GLX inited) = inited
|
|
|
|
initGL (GLX inited) = do
|
|
when (inited) $ fail "GLX already initialized"
|
|
|
|
disp <- openDisplay ""
|
|
fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp)
|
|
[(renderType, rgbaBit)
|
|
, (drawableType, windowBit)
|
|
, (xRenderable, 1)
|
|
, (depthSize, 1)
|
|
, (stencilSize, 1)
|
|
]
|
|
visualinfo <- getVisualFromFBConfig disp (head fbconfigs)
|
|
rootwindow <- rootWindow disp (fromIntegral $ viScreen visualinfo)
|
|
cmap <- createColormap disp rootwindow (viVisual visualinfo) allocNone
|
|
|
|
let swa = nullSetWindowAttributes {swaColormap = cmap, swaEventMask = structureNotifyMask .|. keyPressMask .|. keyReleaseMask}
|
|
|
|
wnd <- with swa $ \swaptr -> createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr
|
|
mapWindow disp wnd
|
|
|
|
waitForMapNotify disp wnd
|
|
|
|
ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True
|
|
makeCurrent 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
|
|
|
|
|