1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
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, true)
, (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
|
