module Graphics.Rendering.OpenGL.GL.BufferObjects (
module Data.ObjectName,
BufferObject(BufferObject),
BufferTarget(..), bindBuffer, arrayBufferBinding,
vertexAttribArrayBufferBinding,
BufferUsage(..), bufferData, TransferDirection(..), bufferSubData,
BufferAccess(..), MappingFailure(..), withMappedBuffer,
mapBuffer, unmapBuffer,
bufferAccess, bufferMapped
) where
import Data.ObjectName
import Data.StateVar
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Graphics.Rendering.OpenGL.GL.Exception
import Graphics.Rendering.OpenGL.GL.GLboolean
import Graphics.Rendering.OpenGL.GL.PeekPoke
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.Rendering.OpenGL.GL.VertexArrays
import Graphics.Rendering.OpenGL.GLU.ErrorsInternal
import Graphics.Rendering.OpenGL.Raw.Core31
newtype BufferObject = BufferObject { bufferID :: GLuint }
deriving ( Eq, Ord, Show )
instance ObjectName BufferObject where
genObjectNames n =
allocaArray n $ \buf -> do
glGenBuffers (fromIntegral n) buf
fmap (map BufferObject) $ peekArray n buf
deleteObjectNames bufferObjects =
withArrayLen (map bufferID bufferObjects) $
glDeleteBuffers . fromIntegral
isObjectName = fmap unmarshalGLboolean . glIsBuffer . bufferID
data BufferTarget =
ArrayBuffer
| CopyReadBuffer
| CopyWriteBuffer
| ElementArrayBuffer
| PixelPackBuffer
| PixelUnpackBuffer
deriving ( Eq, Ord, Show )
marshalBufferTarget :: BufferTarget -> GLenum
marshalBufferTarget x = case x of
ArrayBuffer -> gl_ARRAY_BUFFER
CopyReadBuffer -> gl_COPY_READ_BUFFER
CopyWriteBuffer -> gl_COPY_WRITE_BUFFER
ElementArrayBuffer -> gl_ELEMENT_ARRAY_BUFFER
PixelPackBuffer -> gl_PIXEL_PACK_BUFFER
PixelUnpackBuffer -> gl_PIXEL_UNPACK_BUFFER
bufferTargetToGetPName :: BufferTarget -> GetPName
bufferTargetToGetPName x = case x of
ArrayBuffer -> GetArrayBufferBinding
ElementArrayBuffer -> GetElementArrayBufferBinding
CopyReadBuffer -> GetCopyReadBuffer
CopyWriteBuffer -> GetCopyWriteBuffer
PixelPackBuffer -> GetPixelPackBufferBinding
PixelUnpackBuffer -> GetPixelUnpackBufferBinding
data BufferUsage =
StreamDraw
| StreamRead
| StreamCopy
| StaticDraw
| StaticRead
| StaticCopy
| DynamicDraw
| DynamicRead
| DynamicCopy
deriving ( Eq, Ord, Show )
marshalBufferUsage :: BufferUsage -> GLenum
marshalBufferUsage x = case x of
StreamDraw -> gl_STREAM_DRAW
StreamRead -> gl_STREAM_READ
StreamCopy -> gl_STREAM_COPY
StaticDraw -> gl_STATIC_DRAW
StaticRead -> gl_STATIC_READ
StaticCopy -> gl_STATIC_COPY
DynamicDraw -> gl_DYNAMIC_DRAW
DynamicRead -> gl_DYNAMIC_READ
DynamicCopy -> gl_DYNAMIC_COPY
unmarshalBufferUsage :: GLenum -> BufferUsage
unmarshalBufferUsage x
| x == gl_STREAM_DRAW = StreamDraw
| x == gl_STREAM_READ = StreamRead
| x == gl_STREAM_COPY = StreamCopy
| x == gl_STATIC_DRAW = StaticDraw
| x == gl_STATIC_READ = StaticRead
| x == gl_STATIC_COPY = StaticCopy
| x == gl_DYNAMIC_DRAW = DynamicDraw
| x == gl_DYNAMIC_READ = DynamicRead
| x == gl_DYNAMIC_COPY = DynamicCopy
| otherwise = error ("unmarshalBufferUsage: illegal value " ++ show x)
data BufferAccess =
ReadOnly
| WriteOnly
| ReadWrite
deriving ( Eq, Ord, Show )
marshalBufferAccess :: BufferAccess -> GLenum
marshalBufferAccess x = case x of
ReadOnly -> gl_READ_ONLY
WriteOnly -> gl_WRITE_ONLY
ReadWrite -> gl_READ_WRITE
unmarshalBufferAccess :: GLenum -> BufferAccess
unmarshalBufferAccess x
| x == gl_READ_ONLY = ReadOnly
| x == gl_WRITE_ONLY = WriteOnly
| x == gl_READ_WRITE = ReadWrite
| otherwise = error ("unmarshalBufferAccess: illegal value " ++ show x)
bindBuffer :: BufferTarget -> StateVar (Maybe BufferObject)
bindBuffer t = makeStateVar (getBindBuffer t) (setBindBuffer t)
getBindBuffer :: BufferTarget -> IO (Maybe BufferObject)
getBindBuffer = bufferQuery bufferTargetToGetPName
bufferQuery :: (a -> GetPName) -> a -> IO (Maybe BufferObject)
bufferQuery func t = do
buf <- getInteger1 (BufferObject . fromIntegral) (func t)
return $ if buf == noBufferObject then Nothing else Just buf
noBufferObject :: BufferObject
noBufferObject = BufferObject 0
setBindBuffer :: BufferTarget -> Maybe BufferObject -> IO ()
setBindBuffer t =
glBindBuffer (marshalBufferTarget t) . bufferID . maybe noBufferObject id
clientArrayTypeToGetPName :: ClientArrayType -> GetPName
clientArrayTypeToGetPName x = case x of
VertexArray -> GetVertexArrayBufferBinding
NormalArray -> GetNormalArrayBufferBinding
ColorArray -> GetColorArrayBufferBinding
IndexArray -> GetIndexArrayBufferBinding
TextureCoordArray -> GetTextureCoordArrayBufferBinding
EdgeFlagArray -> GetEdgeFlagArrayBufferBinding
FogCoordArray -> GetFogCoordArrayBufferBinding
SecondaryColorArray -> GetSecondaryColorArrayBufferBinding
MatrixIndexArray -> error "clientArrayTypeToGetPName: impossible"
arrayBufferBinding :: ClientArrayType -> GettableStateVar (Maybe BufferObject)
arrayBufferBinding t =
makeGettableStateVar $ case t of
MatrixIndexArray -> do recordInvalidEnum ; return Nothing
_ -> bufferQuery clientArrayTypeToGetPName t
vertexAttribArrayBufferBinding :: AttribLocation -> GettableStateVar (Maybe BufferObject)
vertexAttribArrayBufferBinding location =
makeGettableStateVar $ do
buf <- getVertexAttribInteger1 (BufferObject . fromIntegral) location GetVertexAttribArrayBufferBinding
return $ if buf == noBufferObject then Nothing else Just buf
bufferData :: BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData t = makeStateVar (getBufferData t) (setBufferData t)
getBufferData :: BufferTarget -> IO (GLsizeiptr, Ptr a, BufferUsage)
getBufferData t = do
s <- getBufferParameter t fromIntegral GetBufferSize
p <- getBufferPointer t
u <- getBufferParameter t unmarshalBufferUsage GetBufferUsage
return (s, p, u)
setBufferData :: BufferTarget -> (GLsizeiptr, Ptr a, BufferUsage) -> IO ()
setBufferData t (s, p, u) =
glBufferData (marshalBufferTarget t) s p (marshalBufferUsage u)
data TransferDirection =
ReadFromBuffer
| WriteToBuffer
deriving ( Eq, Ord, Show )
bufferSubData ::
BufferTarget -> TransferDirection -> GLintptr -> GLsizeiptr -> Ptr a -> IO ()
bufferSubData t WriteToBuffer = glBufferSubData (marshalBufferTarget t)
bufferSubData t ReadFromBuffer = glGetBufferSubData (marshalBufferTarget t)
data GetBufferPName =
GetBufferSize
| GetBufferUsage
| GetBufferAccess
| GetBufferMapped
marshalGetBufferPName :: GetBufferPName -> GLenum
marshalGetBufferPName x = case x of
GetBufferSize -> gl_BUFFER_SIZE
GetBufferUsage -> gl_BUFFER_USAGE
GetBufferAccess -> gl_BUFFER_ACCESS
GetBufferMapped -> gl_BUFFER_MAPPED
getBufferParameter :: BufferTarget -> (GLenum -> a) -> GetBufferPName -> IO a
getBufferParameter t f p = alloca $ \buf -> do
glGetBufferParameteriv (marshalBufferTarget t)
(marshalGetBufferPName p) buf
peek1 (f . fromIntegral) buf
getBufferPointer :: BufferTarget -> IO (Ptr a)
getBufferPointer t = alloca $ \buf -> do
glGetBufferPointerv (marshalBufferTarget t) gl_BUFFER_MAP_POINTER buf
peek buf
data MappingFailure =
MappingFailed
| UnmappingFailed
deriving ( Eq, Ord, Show )
withMappedBuffer :: BufferTarget -> BufferAccess -> (Ptr a -> IO b) -> (MappingFailure -> IO b) -> IO b
withMappedBuffer t a action err = do
maybeBuf <- mapBuffer t a
case maybeBuf of
Nothing -> err MappingFailed
Just buf -> do (ret, ok) <- action buf `finallyRet` unmapBuffer t
if ok
then return ret
else err UnmappingFailed
mapBuffer :: BufferTarget -> BufferAccess -> IO (Maybe (Ptr a))
mapBuffer t = fmap (maybeNullPtr Nothing Just) . mapBuffer_ t
mapBuffer_ :: BufferTarget -> BufferAccess -> IO (Ptr a)
mapBuffer_ t = glMapBuffer (marshalBufferTarget t) . marshalBufferAccess
unmapBuffer :: BufferTarget -> IO Bool
unmapBuffer = fmap unmarshalGLboolean . glUnmapBuffer . marshalBufferTarget
bufferAccess :: BufferTarget -> GettableStateVar BufferAccess
bufferAccess t = makeGettableStateVar $
getBufferParameter t unmarshalBufferAccess GetBufferAccess
bufferMapped :: BufferTarget -> GettableStateVar Bool
bufferMapped t = makeGettableStateVar $
getBufferParameter t unmarshalGLboolean GetBufferMapped