diff options
Diffstat (limited to 'GLX.hs')
| -rw-r--r-- | GLX.hs | 84 |
1 files changed, 72 insertions, 12 deletions
@@ -7,12 +7,16 @@ import Bindings.GLX import Control.Monad (when, unless) import Data.Bits ((.|.)) +import Data.Maybe (isJust) import Graphics.X11.Types +import Graphics.X11.Xlib.Atom (internAtom) import Graphics.X11.Xlib.Display (defaultScreen, openDisplay, rootWindow) -import Graphics.X11.Xlib.Event (allocaXEvent, nextEvent, get_Window, get_EventType) +import Graphics.X11.Xlib.Event (XEventPtr, allocaXEvent, nextEvent, get_Window, get_EventType, pending) +import Graphics.X11.Xlib.Extras (getEvent, ev_event_type, ev_keycode, ev_data) +import Graphics.X11.Xlib.Misc (keycodeToKeysym, setWMProtocols) import Graphics.X11.Xlib.Types -import Graphics.X11.Xlib.Window (mapWindow) +import Graphics.X11.Xlib.Window (destroyWindow, mapWindow) import Foreign.Marshal.Utils (with) import Foreign.Ptr @@ -20,19 +24,30 @@ import Foreign.Storable -data GLX = GLX Bool +data GLX = GLX + { glxDisplay :: !Display + , glxWindow :: !Window + , glxContext :: !Context + , glxDeleteWindow :: !Atom + } glxDriver :: GLX -glxDriver = GLX False +glxDriver = GLX + { glxDisplay = Display nullPtr + , glxWindow = 0 + , glxContext = Context nullPtr + , glxDeleteWindow = 0 + } instance Driver GLX where - initialized (GLX inited) = inited + initialized glx = ((glxContext glx) == (Context nullPtr)) - initGL (GLX inited) = do - when (inited) $ fail "GLX already initialized" + initGL glx = do + when ((glxContext glx) /= (Context nullPtr)) $ fail "GLX already initialized" disp <- openDisplay "" + delwnd <- internAtom disp "WM_DELETE_WINDOW" False fbconfigs <- chooseFBConfig disp (fromIntegral . defaultScreen $ disp) [(renderType, rgbaBit) , (drawableType, windowBit) @@ -46,7 +61,11 @@ instance Driver GLX where 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 + wnd <- with swa $ \swaptr -> + createWindow disp rootwindow 0 0 800 600 0 (fromIntegral $ viDepth visualinfo) inputOutput (viVisual visualinfo) (cWBorderPixel.|.cWColormap.|.cWEventMask) swaptr + + setWMProtocols disp wnd [delwnd] + mapWindow disp wnd waitForMapNotify disp wnd @@ -54,11 +73,52 @@ instance Driver GLX where ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True makeCurrent disp wnd ctx - return (GLX True) - - deinitGL _ = return () + return GLX + { glxDisplay = disp + , glxWindow = wnd + , glxContext = ctx + , glxDeleteWindow = delwnd + } + + deinitGL glx = do + destroyWindow (glxDisplay glx) (glxWindow glx) + destroyContext (glxDisplay glx) (glxContext glx) - nextEvent _ = return Nothing + nextEvent glx = allocaXEvent $ nextEvent' glx $ glxDisplay glx + + +nextEvent' :: GLX -> Display -> XEventPtr -> IO (Maybe SomeEvent) +nextEvent' glx disp xevent = do + p <- pending disp + if (p > 0) then do + Graphics.X11.Xlib.Event.nextEvent disp xevent + ev <- handleEvent glx disp xevent + + if isJust ev then + return ev + else + nextEvent' glx disp xevent + else + return Nothing + + +handleEvent :: GLX -> Display -> XEventPtr -> IO (Maybe SomeEvent) +handleEvent glx disp xevent = do + event <- getEvent xevent + let evtype = ev_event_type event + case () of + _ | evtype == keyPress -> do + keysym <- keycodeToKeysym disp (ev_keycode event) 0 + case () of + _ | keysym == xK_Escape -> return $ Just $ SomeEvent QuitEvent + | otherwise -> return Nothing + | evtype == clientMessage -> do + if ((glxDeleteWindow glx) == (fromIntegral . head . ev_data $ event)) + then + return $ Just $ SomeEvent QuitEvent + else + return Nothing + | otherwise -> return Nothing waitForMapNotify :: Display -> Window -> IO () |