{-# OPTIONS -fglasgow-exts #-}
-- |interface to GLX - the glue layer between and X and OpenGL
module GLX where

#include "GL/glx.h"

import Data.Int
import Data.Word
import Data.Maybe
import Foreign.Ptr
import Foreign.Marshal.Array
import Foreign.Storable
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Types

import GLX.Constants

type AttribList = Ptr (#type int)

newtype XVisualInfo = XVisualInfo (Ptr XVisualInfo)
newtype Context = Context (Ptr Context)
type Drawable = (#type GLXDrawable)

foreign import ccall unsafe "glXChooseVisual" c_glXChooseVisual :: Display -> ScreenNumber -> AttribList -> IO XVisualInfo
foreign import ccall unsafe "glXCreateContext" c_glXCreateContext :: Display -> XVisualInfo -> Context -> Bool -> IO Context
foreign import ccall unsafe "glXMakeCurrent" makeCurrent :: Display -> GLX.Drawable -> GLX.Context -> IO Bool
foreign import ccall unsafe "glXSwapBuffers" swapBuffers :: Display -> GLX.Drawable -> IO ()

toAttribList :: [Attribute] -> [Int32]
toAttribList [] = []
toAttribList ((BufferSize v) : rest)   = (#const GLX_BUFFER_SIZE)      : v : (toAttribList rest)
toAttribList ((Level v) : rest)        = (#const GLX_LEVEL)            : v : (toAttribList rest)
toAttribList (RGBA : rest)             = (#const GLX_RGBA)                 : (toAttribList rest)
toAttribList (DoubleBuffer : rest)     = (#const GLX_DOUBLEBUFFER)         : (toAttribList rest)
toAttribList (Stereo : rest)           = (#const GLX_STEREO)               : (toAttribList rest)
toAttribList (AuxBuffers v : rest)     = (#const GLX_AUX_BUFFERS)      : v : (toAttribList rest)
toAttribList (RedSize v : rest)        = (#const GLX_RED_SIZE)         : v : (toAttribList rest)
toAttribList (GreenSize v : rest)      = (#const GLX_GREEN_SIZE)       : v : (toAttribList rest)
toAttribList (BlueSize v : rest)       = (#const GLX_BLUE_SIZE)        : v : (toAttribList rest)
toAttribList (AlphaSize v : rest)      = (#const GLX_ALPHA_SIZE)       : v : (toAttribList rest)
toAttribList (DepthSize v : rest)      = (#const GLX_DEPTH_SIZE)       : v : (toAttribList rest)
toAttribList (StencilSize v : rest)    = (#const GLX_STENCIL_SIZE)     : v : (toAttribList rest)
toAttribList (AccumRedSize v : rest)   = (#const GLX_ACCUM_RED_SIZE)   : v : (toAttribList rest)
toAttribList (AccumGreenSize v : rest) = (#const GLX_ACCUM_GREEN_SIZE) : v : (toAttribList rest)
toAttribList (AccumBlueSize v : rest)  = (#const GLX_ACCUM_BLUE_SIZE)  : v : (toAttribList rest)
toAttribList (AccumAlphaSize v : rest) = (#const GLX_ACCUM_ALPHA_SIZE) : v : (toAttribList rest)

-- |chooseVisual - return a visual matching the specified attributes
-- returns Nothing if no conforming visual exists
-- TODO: data should be freed with XFree
chooseVisual :: Display -> ScreenNumber -> [Attribute] -> IO (Maybe XVisualInfo)
chooseVisual dpy scn attrs = 
    do xvi@(XVisualInfo xviPtr) <- withArray0 (#const None) (toAttribList attrs) $ \attribList -> c_glXChooseVisual dpy scn attribList
       if xviPtr == nullPtr
          then return Nothing
          else return (Just xvi)

-- |createContext - create a new GLX rendering context
-- returns Nothing if execution failed on the client-side
createContext :: Display -- ^ display
              -> XVisualInfo -- ^ visual that defines the frame buffer resources available to the rendering context
              -> Maybe Context -- ^ context with which to share display lists
              -> Bool -- ^ use direct rendering (if possible)
              -> IO (Maybe Context)
createContext dpy vis ctx direct = 
    do ctx@(Context ptr) <- c_glXCreateContext dpy vis (fromMaybe (Context nullPtr) ctx) direct
       if ptr == nullPtr
          then return Nothing
          else return (Just ctx)

-- * Access functions for members of XVisualInfo

visual :: XVisualInfo -> Visual
visual (XVisualInfo xvi) = Visual ((#ptr XVisualInfo, visual) xvi)

depth :: XVisualInfo -> IO Int
depth (XVisualInfo xvi) = (#peek XVisualInfo, depth) xvi

visualId :: XVisualInfo -> IO VisualID
visualId (XVisualInfo xvi) = ((#peek XVisualInfo, visualid) xvi)