htanks/GLX.hs

module GLX ( glxDriver
           ) where

import GLDriver
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 (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 (destroyWindow, mapWindow)

import Foreign.Marshal.Utils (with)
import Foreign.Ptr
import Foreign.Storable



data GLX = GLX
    { glxDisplay :: !Display
    , glxWindow  :: !Window
    , glxContext :: !Context
    , glxDeleteWindow :: !Atom
    }

glxDriver :: GLX
glxDriver = GLX
            { glxDisplay = Display nullPtr
            , glxWindow = 0
            , glxContext = Context nullPtr
            , glxDeleteWindow = 0
            }


instance Driver GLX where
    initialized glx = ((glxContext glx) == (Context nullPtr))
    
    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)
                       , (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
      
      setWMProtocols disp wnd [delwnd]

      mapWindow disp wnd
      
      waitForMapNotify disp wnd
      
      ctx <- with visualinfo $ \vi -> createContext disp vi (Context nullPtr) True
      makeCurrent disp wnd ctx
      
      return GLX
                 { glxDisplay = disp
                 , glxWindow = wnd
                 , glxContext = ctx
                 , glxDeleteWindow = delwnd
                 }

    deinitGL glx = do
                      destroyWindow (glxDisplay glx) (glxWindow glx)
                      destroyContext (glxDisplay glx) (glxContext glx)
    
    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 ()
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