caramia 0.6.0.0 → 0.7.0.0
raw patch · 23 files changed
+1098/−214 lines, 23 filesdep +HUnitdep +test-frameworkdep +test-framework-hunitdep ~basedep ~containersdep ~sdl2
Dependencies added: HUnit, test-framework, test-framework-hunit
Dependency ranges changed: base, containers, sdl2
Files
- README.md +12/−12
- caramia.cabal +56/−21
- src/Graphics/Caramia/Buffer.hs +32/−12
- src/Graphics/Caramia/Buffer/Internal.hs +10/−0
- src/Graphics/Caramia/Context.hs +14/−26
- src/Graphics/Caramia/Framebuffer.hs +22/−13
- src/Graphics/Caramia/Framebuffer/Internal.hs +19/−4
- src/Graphics/Caramia/Internal/Exception.hs +64/−0
- src/Graphics/Caramia/Internal/OpenGLCApi.hs +135/−38
- src/Graphics/Caramia/Internal/OpenGLVersion.hs +125/−0
- src/Graphics/Caramia/OpenGLResource.hs +23/−0
- src/Graphics/Caramia/Query.hs +37/−3
- src/Graphics/Caramia/Render.hs +96/−52
- src/Graphics/Caramia/Resource.hs +26/−5
- src/Graphics/Caramia/Shader.hs +45/−10
- src/Graphics/Caramia/Shader/Internal.hs +19/−1
- src/Graphics/Caramia/Sync.hs +22/−9
- src/Graphics/Caramia/Texture.hs +13/−0
- src/Graphics/Caramia/Texture/Internal.hs +15/−0
- src/Graphics/Caramia/VAO.hs +18/−8
- src/Graphics/Caramia/VAO/Internal.hs +10/−0
- tests/buffer/Main.hs +236/−0
- tests/shader/Main.hs +49/−0
README.md view
@@ -1,13 +1,17 @@ [](https://travis-ci.org/Noeda/caramia) This is a highish-level OpenGL bindings library for real-time graphics for-Haskell, using OpenGL 3.3.+Haskell, with minimum OpenGL version being 2.1. Requirements: * GHC 7.8+- * OpenGL 3.3+ * OpenGL 2.1 (with some extensions) +If the target system has OpenGL 3.3, then all features in this library should+be available unless stated otherwise. OpenGL contexts with 3.x or later+versions can be a core profile; this library does not care.+ You need to use `-threaded` flag in executables that use this library. Here are the most important features of this library:@@ -28,8 +32,9 @@ * This library does not create an OpenGL context. You can use whatever library you want to create an OpenGL context as long as it can get an- OpenGL 3.3 context. You may be interested at looking at the tests in this- package to see how to use this with the `sdl2` package.+ OpenGL 2.1 (or any later version) context. You may be interested at looking+ at the tests in this package to see how to use this with the `sdl2`+ package. * Operations are generalized over `MonadIO`. Works on top of pure `IO` and also in your custom monad stacks, if they have `MonadIO` at bottom.@@ -57,13 +62,8 @@ * Query objects -Some notable missing features:-- * Tesselation shaders. This is an OpenGL 4.x feature but we could add it.-- * Using shaders with transform feedback.-- * Multi-threaded rendering.- This library tries to avoid including obsolete or redundant features of OpenGL.++Note that the library is in flux and API-breaking changes tend to happen+often.
caramia.cabal view
@@ -1,6 +1,6 @@ name: caramia-version: 0.6.0.0-synopsis: Less painful OpenGL 3.3 rendering+version: 0.7.0.0+synopsis: High-level OpenGL bindings homepage: https://github.com/Noeda/caramia/ license: MIT license-file: LICENSE@@ -15,13 +15,16 @@ description: This is a highish-level OpenGL bindings library for real-time graphics for- Haskell, using OpenGL 3.3.+ Haskell, with minimum OpenGL version being 2.1. . Requirements: .- * GHC 7.8++ * GHC 7.8++ * OpenGL 2.1 (with some extensions) .- * OpenGL 3.3+ If the target system has OpenGL 3.3, then all features in this library should+ be available unless stated otherwise. OpenGL contexts with 3.x or later+ versions can be a core profile; this library does not care. . You need to use `-threaded` flag in executables that use this library. .@@ -30,11 +33,8 @@ * Safe and automatic finalization of OpenGL resources . * No implicit state (that is, no glBind* mess or equivalent). There is a- monad for mass-rendering that has implicit state but the state is localized- to running of that monad. (see Caramia.Render).- .- * Only vanilla OpenGL 3.3 required. Some extensions will be used if they are- available.+ monad for mass-rendering that has implicit state but the state is localized+ to running of that monad. (see Caramia.Render). . Here are some curious features that you might find useful. .@@ -43,11 +43,12 @@ . * This library does not create an OpenGL context. You can use whatever library you want to create an OpenGL context as long as it can get an- OpenGL 3.3 context. You may be interested at looking at the tests in- this package to see how to use this with the `sdl2` package.+ OpenGL 2.1 (or any later version) context. You may be interested at looking+ at the tests in this package to see how to use this with the `sdl2`+ package. . * Operations are generalized over `MonadIO`. Works on top of pure `IO` and- also in your custom monad stacks, if they have `MonadIO` at bottom.+ also in your custom monad stacks, as long as they implement `MonadIO`. . (At least) the following OpenGL concepts are present in this library: .@@ -72,20 +73,20 @@ . * Query objects .- Some notable missing features:- .- * Tesselation shaders. This is an OpenGL 4.x feature but we could add it.- .- * Using shaders with transform feedback.- .- * Multi-threaded rendering.- . This library tries to avoid including obsolete or redundant features of OpenGL.+ .+ Note that the library is in flux and API-breaking changes tend to happen+ often. flag build-toys default: False description: Build some toy programs to test and play with. +flag fix-opengl21+ default: False+ description: Makes the library think only OpenGL 2.1 is available. This+ can be useful for debugging.+ source-repository head type: git location: https://github.com/Noeda/caramia.git@@ -103,10 +104,13 @@ Graphics.Caramia.ImageFormats Graphics.Caramia.ImageFormats.Internal Graphics.Caramia.Internal.ContextLocalData+ Graphics.Caramia.Internal.Exception Graphics.Caramia.Internal.OpenGLCApi Graphics.Caramia.Internal.OpenGLDebug+ Graphics.Caramia.Internal.OpenGLVersion Graphics.Caramia.Internal.TexStorage Graphics.Caramia.Memory+ Graphics.Caramia.OpenGLResource Graphics.Caramia.Prelude Graphics.Caramia.Query Graphics.Caramia.Render@@ -134,6 +138,10 @@ ,vector >=0.10 && <1.0 ,gl >=0.6.2 && <0.7 + if flag(fix-opengl21)+ cpp-options: -DFIXED_OPENGL_MAJOR_VERSION=2+ -DFIXED_OPENGL_MINOR_VERSION=1+ if !os(windows) build-depends: unix >=2.7 && <3.0 @@ -142,6 +150,33 @@ if os(darwin) frameworks: OpenGL++test-suite buffer+ type: exitcode-stdio-1.0+ main-is: Main.hs+ ghc-options: -Wall -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs: tests/buffer+ build-depends: base, caramia+ ,containers >=0.5.5 && <1.0+ ,HUnit >=1.2.5.2 && <2.0+ ,linear >=1.15 && <2.0+ ,sdl2 >= 2.0 && <3.0+ ,test-framework >=0.8.1 && <1.0+ ,test-framework-hunit >=0.3.0.1 && <1.0+ default-language: Haskell2010++test-suite shader+ type: exitcode-stdio-1.0+ main-is: Main.hs+ ghc-options: -Wall -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs: tests/shader+ build-depends: base, caramia+ ,HUnit >=1.2.5.2 && <2.0+ ,linear >=1.15 && <2.0+ ,sdl2 >= 2.0 && <3.0+ ,test-framework >=0.8.1 && <1.0+ ,test-framework-hunit >=0.3.0.1 && <1.0+ default-language: Haskell2010 -- This is just a dumping ground test that does stupid things. It's used to -- check if things work at all.
src/Graphics/Caramia/Buffer.hs view
@@ -52,6 +52,7 @@ import Graphics.Caramia.Prelude hiding ( map ) import Graphics.Caramia.Resource import Graphics.GL.Ext.ARB.BufferStorage+import Graphics.GL.Ext.ARB.CopyBuffer import Graphics.GL.Ext.ARB.InvalidateSubdata -- | The frequency of access to a buffer.@@ -266,20 +267,26 @@ | offset < 0 || offset >= viewSize buffer || num_bytes <= 0 || offset + num_bytes > viewSize buffer =- error $ "map: requested mapping has invalid offset " <>+ error $ "bufferMap2: requested mapping has invalid offset " <> "and/or range. " <> "Buffer size is " <> show (viewSize buffer) <> ", " <> "requested mapping was [" <> show offset <> ".." <> show (offset + num_bytes - 1) <> "]."+ | access_flags == NoAccess =+ error "bufferMap2: cannot map with NoAccess access flags."+ | S.member UnSynchronized map_flags &&+ (access_flags == ReadWriteAccess ||+ access_flags == ReadAccess) =+ error "bufferMap2: cannot map for reading with unsynchronized flag." | otherwise = liftIO $ withResource (resource buffer) $ \(Buffer_ buf) -> mask_ $ do bufstatus <- readIORef (status buffer) -- make sure buffer has not been already mapped when (mapped bufstatus) $- error "map: buffer is already mapped."+ error "bufferMap2: buffer is already mapped." -- can we really map with these access flags unless (canMapWith (viewAllowedMappings buffer) access_flags) $- error $ "map: attempted to map buffer with " <> show access_flags+ error $ "bufferMap2: attempted to map buffer with " <> show access_flags <> ", allowed mappings are: " <> show (viewAllowedMappings buffer) @@ -294,7 +301,7 @@ -- depending on external factors. I hope. when (ptr == nullPtr) $ -- I am so sorry for any user who sees this error message.- error $ "map: for some reason, mapping a buffer failed. " <>+ error $ "bufferMap2: for some reason, mapping a buffer failed. " <> "You might want to check OpenGL debug log." atomicModifyIORef' (status buffer) $ \old ->@@ -413,10 +420,17 @@ -- | Copies bytes from one buffer to another. --+-- This will use @ GL_ARB_copy_buffer @ extension if it is available (this+-- became available in OpenGL 3.1).+-- -- The buffers must not be mapped; however this call can bypass the access--- flags set in `newBuffer`. That is, you can copy data even to a buffer that--- was set as not writable or copy from a buffer that was set as not readable.+-- flags set in `newBuffer`, if the above extension is available. That is, you+-- can copy data even to a buffer that was set as not writable or copy from a+-- buffer that was set as not readable. --+-- When @ GL_ARB_copy_buffer @ is not available, this is implemented in terms+-- of `withMapping` and is subject to mapping restrictions.+-- -- This is faster than mapping both buffers and then doing a memcpy() style -- copying in system memory because this call does not require a round-trip to -- the driver.@@ -449,12 +463,18 @@ error "copy: source buffer is mapped." when (num_bytes > 0) $- mglNamedCopyBufferSubData- src- dst- (safeFromIntegral src_offset)- (safeFromIntegral dst_offset)- (safeFromIntegral num_bytes)+ if openGLVersion >= OpenGLVersion 3 1 ||+ gl_ARB_copy_buffer+ then mglNamedCopyBufferSubData+ src+ dst+ (safeFromIntegral src_offset)+ (safeFromIntegral dst_offset)+ (safeFromIntegral num_bytes)+ else withMapping src_offset num_bytes ReadAccess src_buffer $ \src_ptr ->+ withMapping dst_offset num_bytes WriteAccess dst_buffer $ \dst_ptr ->+ copyBytes dst_ptr src_ptr num_bytes+ where overlaps
src/Graphics/Caramia/Buffer/Internal.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE NoImplicitPrelude, ViewPatterns, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} module Graphics.Caramia.Buffer.Internal where import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.OpenGLResource import Graphics.Caramia.Prelude import Graphics.Caramia.Resource @@ -16,6 +20,12 @@ , ordIndex :: !Unique } deriving ( Typeable )++instance OpenGLResource GLuint Buffer where+ getRaw buf = do+ Buffer_ name <- getRaw (WrappedOpenGLResource $ resource buf)+ return name+ touch buf = touch (WrappedOpenGLResource $ resource buf) instance Ord Buffer where (ordIndex -> o1) `compare` (ordIndex -> o2) = o1 `compare` o2
src/Graphics/Caramia/Context.hs view
@@ -27,21 +27,23 @@ , storeContextLocalData , retrieveContextLocalData -- * Exceptions- , TooOldOpenGL(..) )+ , NoSupport(..)+ , TooOldOpenGL(..)+ , OpenGLVersion(..) ) where import Graphics.Caramia.Prelude import Graphics.Caramia.Internal.ContextLocalData+import Graphics.Caramia.Internal.Exception import Graphics.Caramia.Internal.OpenGLCApi import Graphics.Caramia.Internal.OpenGLDebug+import qualified Graphics.GL.Core33 as GL33 import Control.Concurrent import Control.Monad.IO.Class import Control.Monad.Catch import System.IO.Unsafe import System.Environment-import Foreign.Marshal.Alloc-import Foreign.Storable import qualified Data.Map.Strict as M import qualified Data.IntMap.Strict as IM@@ -49,9 +51,9 @@ -- | An exception that is thrown when the OpenGL version is too old for this -- library. data TooOldOpenGL = TooOldOpenGL- { wantedVersion :: (Int, Int) -- ^ The OpenGL version this- -- library needs.- , reportedVersion :: (Int, Int)+ { wantedVersion :: OpenGLVersion -- ^ The OpenGL version this+ -- library needs.+ , reportedVersion :: OpenGLVersion -- ^ The OpenGL version reported by current OpenGL -- context. }@@ -79,7 +81,7 @@ -- OpenGL's side to automatically detect if size has changed. -- -- Throws `TooOldOpenGL` if the code detects a context that does not provide--- OpenGL 3.3.+-- at least OpenGL 2.1. giveContext :: (MonadIO m, MonadMask m) => m a -> m a giveContext action = mask $ \restore -> do@@ -89,13 +91,10 @@ error $ "giveContext: current thread is not bound. How can it have " <> "an OpenGL context?" - v@(major, minor) <- getGLVersion- unless (major > 3 ||- (major == 3 && minor >= 3)) $- throwM- TooOldOpenGL { wantedVersion = (3, 3)- , reportedVersion = v- }+ unless (openGLVersion >= OpenGLVersion 2 1) $+ throwM TooOldOpenGL { wantedVersion = OpenGLVersion 2 1+ , reportedVersion = openGLVersion+ } cid <- newContextID tid <- myThreadId@@ -110,19 +109,8 @@ -- Enable sRGB framebuffers -- There seems to be no reason not to enable it; you can turn off sRGB -- handling in other ways.- glEnable GL_FRAMEBUFFER_SRGB+ glEnable GL33.GL_FRAMEBUFFER_SRGB glEnable GL_BLEND-- getGLVersion = alloca $ \major_ptr -> alloca $ \minor_ptr -> do- -- in case glGetIntegerv is completely broken, set initial values for- -- major and minor pointers- poke major_ptr 0- poke minor_ptr 0- glGetIntegerv GL_MAJOR_VERSION major_ptr- glGetIntegerv GL_MINOR_VERSION minor_ptr- major <- fromIntegral <$> peek major_ptr- minor <- fromIntegral <$> peek minor_ptr- return (major, minor) -- | Sets the new viewport size. You should call this if the display size has -- changed; otherwise your rendering may look twisted and stretched.
src/Graphics/Caramia/Framebuffer.hs view
@@ -6,8 +6,12 @@ -- -- <https://www.opengl.org/wiki/Framebuffer_Object> --+-- Either OpenGL 3.0 or @ GL_ARB_framebuffer_object @ is required for this+-- module.+-- {-# LANGUAGE NoImplicitPrelude, ViewPatterns, DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} module Graphics.Caramia.Framebuffer (@@ -47,11 +51,13 @@ import Graphics.Caramia.Context import Graphics.Caramia.Framebuffer.Internal import Graphics.Caramia.ImageFormats+import Graphics.Caramia.Internal.Exception import Graphics.Caramia.Internal.OpenGLCApi import Graphics.Caramia.Prelude import Graphics.Caramia.Resource import Graphics.Caramia.Texture import qualified Graphics.Caramia.Texture.Internal as Tex+import Graphics.GL.Ext.ARB.FramebufferObject -- | Returns the screen framebuffer. --@@ -122,20 +128,23 @@ error "newFramebuffer: no texture targets specified." | nub (fmap fst targets) /= fmap fst targets = error "newFramebuffer: there are duplicate attachments."- | otherwise = liftIO $ mask_ $ do- max_bufs <- getMaximumDrawBuffers- targetsSanityCheck max_bufs+ | otherwise = liftIO $ mask_ $+ checkOpenGLOrExtensionM (OpenGLVersion 3 0)+ "GL_ARB_framebuffer_object"+ gl_ARB_framebuffer_object $ do+ max_bufs <- getMaximumDrawBuffers+ targetsSanityCheck max_bufs - res <- newResource (creator max_bufs)- deleter- (return ())- index <- newUnique- return Framebuffer { resource = res- , ordIndex = index- , viewTargets = targets- , dimensions = calculatedDimensions- , binder = withThisFramebuffer res- , setter = setThisFramebuffer res }+ res <- newResource (creator max_bufs)+ deleter+ (return ())+ index <- newUnique+ return Framebuffer { resource = res+ , ordIndex = index+ , viewTargets = targets+ , dimensions = calculatedDimensions+ , binder = withThisFramebuffer res+ , setter = setThisFramebuffer res } where calculatedDimensions@(fw, fh) = foldl' (\(lowest_w, lowest_h) (w, h) ->
src/Graphics/Caramia/Framebuffer/Internal.hs view
@@ -1,15 +1,20 @@ {-# LANGUAGE RankNTypes, NoImplicitPrelude, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} module Graphics.Caramia.Framebuffer.Internal where -import Data.Unique import Control.Monad.IO.Class import Control.Monad.Catch+import Data.Unique import Foreign import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.OpenGLResource import Graphics.Caramia.Prelude import Graphics.Caramia.Resource import qualified Graphics.Caramia.Texture.Internal as Tex+import Graphics.GL.Ext.ARB.FramebufferObject data Framebuffer = ScreenFramebuffer@@ -23,6 +28,12 @@ } deriving ( Typeable ) +instance OpenGLResource GLuint Framebuffer where+ getRaw fbuf = do+ Framebuffer_ name <- getRaw (WrappedOpenGLResource $ resource fbuf)+ return name+ touch fbuf = touch (WrappedOpenGLResource $ resource fbuf)+ data Attachment = ColorAttachment !Int | DepthAttachment | StencilAttachment@@ -65,12 +76,16 @@ (w, h) <- getDimensions ScreenFramebuffer old_draw <- gi GL_DRAW_FRAMEBUFFER_BINDING old_read <- gi GL_READ_FRAMEBUFFER_BINDING- finally (glBindFramebuffer GL_FRAMEBUFFER 0 >>+ finally (extcheck (glBindFramebuffer GL_FRAMEBUFFER 0) >> glViewport 0 0 (fromIntegral w) (fromIntegral h) >> action) $ do glViewport ox oy ow oh- glBindFramebuffer GL_DRAW_FRAMEBUFFER old_draw- glBindFramebuffer GL_READ_FRAMEBUFFER old_read+ extcheck $ do+ glBindFramebuffer GL_DRAW_FRAMEBUFFER old_draw+ glBindFramebuffer GL_READ_FRAMEBUFFER old_read+ where+ extcheck = when (openGLVersion >= OpenGLVersion 3 0 ||+ gl_ARB_framebuffer_object) withBinding fbuf action = binder fbuf action -- | Returns the size of a framebuffer.
+ src/Graphics/Caramia/Internal/Exception.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Graphics.Caramia.Internal.Exception+ ( NoSupport(..)+ , checkExtension+ , checkExtensionM+ , checkOpenGLOrExtensionM+ , checkOpenGLM )+ where++import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Text ( Text )+import Graphics.Caramia.Internal.OpenGLVersion+import Graphics.Caramia.Prelude++-- | Thrown when there was a detected attempt to use an OpenGL feature that is+-- not supported by the driver, hardware or platform.+--+-- Caramia cannot detect all attempts to use non-supported features.+--+-- If the platform supports at least OpenGL 3.3, then this exception is+-- guaranteed to never be thrown.+data NoSupport = NoSupport { info :: Text }+ -- ^ The text contains human-readable string that may tell+ -- what exactly is missing and where.+ deriving ( Eq, Ord, Show, Read, Typeable )++instance Exception NoSupport++-- | Checks that extension is available and throw `NoSupport` with the given+-- extension name if it is not.+checkExtension :: MonadIO m => Text -> Bool -> m ()+checkExtension _ True = return ()+checkExtension extname False =+ liftIO $ throwM $+ NoSupport $ "This operation requires " <> extname <> " extension."+{-# INLINE checkExtension #-}++-- | Same as `checkExtension` but takes an action to run afterwards, it checks+-- for the extension and then runs the action.+checkExtensionM :: MonadIO m => Text -> Bool -> m a -> m a+checkExtensionM ext test action = checkExtension ext test >> action++-- | Checks that OpenGL version is at least given version or that an extension+-- is available.+--+-- This is for the common case of checking core OpenGL version and falling back+-- to a core extension.+checkOpenGLOrExtensionM :: MonadIO m+ => OpenGLVersion -> Text -> Bool -> m a -> m a+checkOpenGLOrExtensionM ver ext test action =+ if openGLVersion >= ver+ then action+ else checkExtensionM ext test action++checkOpenGLM :: MonadIO m+ => OpenGLVersion -> m a -> m a+checkOpenGLM ver action =+ if openGLVersion >= ver+ then action+ else liftIO $ throwM $ NoSupport $ "This operation requires " <> showT openGLVersion
src/Graphics/Caramia/Internal/OpenGLCApi.hs view
@@ -6,12 +6,18 @@ -- stuff there instead. -- -{-# LANGUAGE ForeignFunctionInterface, NoImplicitPrelude #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-} module Graphics.Caramia.Internal.OpenGLCApi ( module GLCore , module GLTypes + , openGLVersion+ , OpenGLVersion(..)+ , gi , gf @@ -61,21 +67,30 @@ ) where +import Control.Monad.IO.Class+import Control.Monad.Catch+import Data.Bits+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import Graphics.Caramia.Internal.Exception+import Graphics.Caramia.Internal.OpenGLVersion import Graphics.Caramia.Prelude-+import Graphics.GL.Standard21 as GLCore+import qualified Graphics.GL.Core33 as GL33 import Graphics.GL.Core33 as GLCore-import Graphics.GL.Types as GLTypes-import Graphics.GL.Ext.ARB.SeparateShaderObjects+import qualified Graphics.GL.Ext.EXT.GpuShader4 as EXT+import qualified Graphics.GL.Ext.ARB.InstancedArrays as ARB+import Graphics.GL.Ext.ARB.FramebufferObject ( gl_ARB_framebuffer_object )+import Graphics.GL.Ext.ARB.VertexArrayObject ( gl_ARB_vertex_array_object ) import Graphics.GL.Ext.ARB.BufferStorage+import Graphics.GL.Ext.ARB.CopyBuffer ( gl_ARB_copy_buffer )+import Graphics.GL.Ext.ARB.SeparateShaderObjects import Graphics.GL.Ext.ARB.DirectStateAccess--import Foreign.Ptr-import Foreign.C.Types-import Foreign.Storable-import Foreign.Marshal.Alloc-import Foreign.Marshal.Utils-import Control.Monad.IO.Class-import Control.Monad.Catch+import Graphics.GL.Ext.ARB.MapBufferRange+import Graphics.GL.Types as GLTypes {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} @@ -83,19 +98,31 @@ mglDeleteBuffer x = with x $ \x_ptr -> glDeleteBuffers 1 x_ptr mglDeleteVertexArray :: GLuint -> IO ()-mglDeleteVertexArray x = with x $ \x_ptr -> glDeleteVertexArrays 1 x_ptr+mglDeleteVertexArray x = with x $ \x_ptr -> GL33.glDeleteVertexArrays 1 x_ptr mglGenBuffer :: IO GLuint mglGenBuffer = alloca $ \x_ptr -> glGenBuffers 1 x_ptr *> peek x_ptr mglGenVertexArray :: IO GLuint-mglGenVertexArray = alloca $ \x_ptr -> glGenVertexArrays 1 x_ptr *> peek x_ptr+mglGenVertexArray =+ checkOpenGLOrExtensionM (OpenGLVersion 3 0)+ "GL_ARB_vertex_array_object"+ gl_ARB_vertex_array_object+ do_it+ where+ do_it = alloca $ \x_ptr -> GL33.glGenVertexArrays 1 x_ptr *> peek x_ptr mglGenFramebuffer :: IO GLuint-mglGenFramebuffer = alloca $ \x_ptr -> glGenFramebuffers 1 x_ptr *> peek x_ptr+mglGenFramebuffer =+ checkOpenGLOrExtensionM (OpenGLVersion 3 0)+ "GL_ARB_framebuffer_object"+ gl_ARB_framebuffer_object+ do_it+ where+ do_it = alloca $ \x_ptr -> GL33.glGenFramebuffers 1 x_ptr *> peek x_ptr mglDeleteFramebuffer :: GLuint -> IO ()-mglDeleteFramebuffer x = with x $ \x_ptr -> glDeleteFramebuffers 1 x_ptr+mglDeleteFramebuffer x = with x $ \x_ptr -> GL33.glDeleteFramebuffers 1 x_ptr mglGenQuery :: IO GLuint mglGenQuery = alloca $ \x_ptr -> glGenQueries 1 x_ptr *> peek x_ptr@@ -105,9 +132,15 @@ withBoundDrawFramebuffer :: (MonadIO m, MonadMask m) => GLuint -> m a -> m a withBoundDrawFramebuffer x action = do- old <- gi GL_DRAW_FRAMEBUFFER_BINDING- finally (glBindFramebuffer GL_DRAW_FRAMEBUFFER x >> action)- (glBindFramebuffer GL_DRAW_FRAMEBUFFER old)+ checkOpenGLOrExtensionM (OpenGLVersion 3 0)+ "GL_ARB_framebuffer_object"+ gl_ARB_framebuffer_object+ do_it+ where+ do_it = do+ old <- gi GL33.GL_DRAW_FRAMEBUFFER_BINDING+ finally (GL33.glBindFramebuffer GL33.GL_DRAW_FRAMEBUFFER x >> action)+ (GL33.glBindFramebuffer GL33.GL_DRAW_FRAMEBUFFER old) withBoundProgram :: (MonadIO m, MonadMask m) => GLuint -> m a -> m a withBoundProgram program action = do@@ -149,17 +182,26 @@ withBoundVAO :: (MonadIO m, MonadMask m) => GLuint -> m a -> m a withBoundVAO vao action = do- old <-- liftIO $ alloca $ \x_ptr -> glGetIntegerv GL_VERTEX_ARRAY_BINDING x_ptr >>- peek x_ptr- finally (glBindVertexArray vao >> action)- (glBindVertexArray $ fromIntegral old)+ checkOpenGLOrExtensionM (OpenGLVersion 3 0)+ "GL_ARB_vertex_array_object"+ gl_ARB_vertex_array_object+ do_it+ where+ do_it = do+ old <- gi GL33.GL_VERTEX_ARRAY_BINDING+ finally (GL33.glBindVertexArray vao >> action)+ (GL33.glBindVertexArray $ fromIntegral old) mglVertexArrayVertexAttribDivisor :: GLuint -> GLuint -> GLuint -> IO () mglVertexArrayVertexAttribDivisor vaobj index divisor = mask_ $ withBoundVAO vaobj $- glVertexAttribDivisor index divisor+ if ver >= OpenGLVersion 3 3+ then GL33.glVertexAttribDivisor index divisor+ else do checkExtension "GL_ARB_instanced_arrays" ARB.gl_ARB_instanced_arrays+ ARB.glVertexAttribDivisorARB index divisor+ where+ ver = openGLVersion mglVertexArrayVertexAttribOffsetAndEnable :: GLuint -> GLuint -> GLuint -> GLint -> GLenum@@ -182,8 +224,13 @@ withBoundVAO vaobj $ withBoundBuffer buffer $ do glEnableVertexAttribArray index- glVertexAttribIPointer index size dtype stride- (intPtrToPtr $ fromIntegral offset)+ unless (ver >= OpenGLVersion 3 0) $+ throwM $ NoSupport $+ "OpenGL 3.0 required for integer attribute mapping."+ GL33.glVertexAttribIPointer index size dtype stride+ (intPtrToPtr $ fromIntegral offset)+ where+ ver = openGLVersion mglNamedBufferStorage :: GLuint -> GLsizeiptr@@ -209,26 +256,50 @@ mglProgramUniform1ui program loc v1 = if gl_ARB_separate_shader_objects then glProgramUniform1ui program loc v1- else withBoundProgram program $ glUniform1ui loc v1+ else withBoundProgram program $+ if ver >= OpenGLVersion 3 0+ then GL33.glUniform1ui loc v1+ else do checkExtension "GL_EXT_gpu_shader4" EXT.gl_EXT_gpu_shader4+ EXT.glUniform1uiEXT loc v1+ where+ ver = openGLVersion mglProgramUniform2ui :: GLuint -> GLint -> GLuint -> GLuint -> IO () mglProgramUniform2ui program loc v1 v2 = if gl_ARB_separate_shader_objects then glProgramUniform2ui program loc v1 v2- else withBoundProgram program $ glUniform2ui loc v1 v2+ else withBoundProgram program $+ if ver >= OpenGLVersion 3 0+ then GL33.glUniform2ui loc v1 v2+ else do checkExtension "GL_EXT_gpu_shader4" EXT.gl_EXT_gpu_shader4+ EXT.glUniform2uiEXT loc v1 v2+ where+ ver = openGLVersion mglProgramUniform3ui :: GLuint -> GLint -> GLuint -> GLuint -> GLuint -> IO () mglProgramUniform3ui program loc v1 v2 v3 = if gl_ARB_separate_shader_objects then glProgramUniform3ui program loc v1 v2 v3- else withBoundProgram program $ glUniform3ui loc v1 v2 v3+ else withBoundProgram program $+ if ver >= OpenGLVersion 3 0+ then GL33.glUniform3ui loc v1 v2 v3+ else do checkExtension "GL_EXT_gpu_shader4" EXT.gl_EXT_gpu_shader4+ EXT.glUniform3uiEXT loc v1 v2 v3+ where+ ver = openGLVersion mglProgramUniform4ui :: GLuint -> GLint -> GLuint -> GLuint -> GLuint -> GLuint -> IO () mglProgramUniform4ui program loc v1 v2 v3 v4 = if gl_ARB_separate_shader_objects then glProgramUniform4ui program loc v1 v2 v3 v4- else withBoundProgram program $ glUniform4ui loc v1 v2 v3 v4+ else withBoundProgram program $+ if ver >= OpenGLVersion 3 0+ then GL33.glUniform4ui loc v1 v2 v3 v4+ else do checkExtension "GL_EXT_gpu_shader4" EXT.gl_EXT_gpu_shader4+ EXT.glUniform4uiEXT loc v1 v2 v3 v4+ where+ ver = openGLVersion mglProgramUniform1i :: GLuint -> GLint -> GLint -> IO () mglProgramUniform1i program loc v1 =@@ -298,8 +369,31 @@ -> GLsizeiptr -> GLbitfield -> IO (Ptr ()) mglMapNamedBufferRange buffer offset length access = withBoundBuffer buffer $- glMapBufferRange GL_ARRAY_BUFFER offset length access+ if | openGLVersion >= OpenGLVersion 3 0 ||+ gl_ARB_map_buffer_range+ -> glMapBufferRange GL_ARRAY_BUFFER offset length access+ | otherwise+ -- it is time to be sneaky. We only have the plain glMapBuffer. We+ -- can't specify offset or how much to map. What do we do??? We+ -- map the whole thing but return pointer to the offset. It's+ -- horrible but at least it works.+ -> case oldwayflags of+ Just flags -> do+ ptr <- glMapBuffer GL_ARRAY_BUFFER flags+ return $ ptr `plusPtr` (fromIntegral offset)+ -- return just some arbitrary pointer. Client specified+ -- they don't read or write to it so does it matter?+ Nothing -> return $ nullPtr `plusPtr` 1+ where+ oldwayflags =+ let can_read = access .&. GL_MAP_READ_BIT /= 0+ can_write = access .&. GL_MAP_WRITE_BIT /= 0+ in if | can_read && can_write -> Just GL_READ_WRITE+ | can_read -> Just GL_READ_ONLY+ | can_write -> Just GL_WRITE_ONLY+ | otherwise -> Nothing + mglUnmapNamedBuffer :: GLuint -> IO GLboolean mglUnmapNamedBuffer buffer = withBoundBuffer buffer $ glUnmapBuffer GL_ARRAY_BUFFER@@ -308,12 +402,15 @@ -> GLintptr -> GLintptr -> GLsizeiptr -> IO () mglNamedCopyBufferSubData src dst src_offset dst_offset num_bytes = withBoundElementBuffer src $- withBoundBuffer dst $- glCopyBufferSubData GL_ELEMENT_ARRAY_BUFFER- GL_ARRAY_BUFFER- src_offset- dst_offset- num_bytes+ withBoundBuffer dst $ do+ checkOpenGLOrExtensionM (OpenGLVersion 3 1)+ "GL_ARB_copy_buffer"+ gl_ARB_copy_buffer $+ GL33.glCopyBufferSubData GL_ELEMENT_ARRAY_BUFFER+ GL_ARRAY_BUFFER+ src_offset+ dst_offset+ num_bytes -- | Shortcut to `glGetIntegerv` when you query only one integer. gi :: MonadIO m => GLenum -> m GLuint
+ src/Graphics/Caramia/Internal/OpenGLVersion.hs view
@@ -0,0 +1,125 @@+--------------------------------------------------------------------+-- |+-- Copyright : (c) 2014 Edward Kmett+-- License : BSD2+-- Maintainer: Edward Kmett <ekmett@gmail.com>+-- Stability : experimental+-- Portability: non-portable+--+--------------------------------------------------------------------++-- this file is stolen from Edward's quine project+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-}++module Graphics.Caramia.Internal.OpenGLVersion+ ( openGLVersion+ , OpenGLVersion(..)+ , shadingLanguageVersion+ , shadingLanguageVersions+ ) where+++import Control.Monad+import Data.Functor+import Data.List (isPrefixOf)+import Data.Maybe+import Data.Set as Set+import Data.Typeable+import Data.Version+import Foreign.C.String+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import Graphics.GL.Core43+import Graphics.GL.Types+import System.IO.Unsafe+import Text.ParserCombinators.ReadP++-- |+-- @+-- major.minor <vendor-specific information>+-- major.minor.release <vendor-specific information>+-- OpenGL ES major.minor <vendor-specific information>+-- OpenGL ES major.minor.release <vendor-specific information>+-- OpenGL ES GLSL ES major.minor <vendor-specific information>+-- OpenGL ES GLSL ES major.minor.release <vendor-specific information>+-- @+parse :: String -> Maybe Version+parse s = case words s of+ "OpenGL":"ES":"GLSL":"ES":x:_ -> go x+ "OpenGL":"ES":x:_ -> go x+ x:_ -> go x+ _ -> Nothing+ where go xs = listToMaybe [ v | (v,"") <- readP_to_S parseVersion xs ]++getString :: GLenum -> IO String+getString = glGetString >=> peekCString . castPtr++-- | Returns the company responsible for this GL implementation. This name does not change from release to release.+vendor :: String+vendor = unsafePerformIO $ getString GL_VENDOR+{-# NOINLINE vendor #-}++-- | Returns the name of the renderer. This name is typically specific to a particular configuration of a hardware platform. It does not change from release to release.+renderer :: String+renderer = unsafePerformIO $ getString GL_RENDERER+{-# NOINLINE renderer #-}++versionString :: String+versionString = unsafePerformIO $ getString GL_VERSION+{-# NOINLINE versionString #-}++gles :: Bool+gles = "OpenGL ES" `isPrefixOf` versionString++-- | Returns a version or release number.+version :: Version+version = error ("malformed GL version: " ++ versionString) `fromMaybe` parse versionString++data OpenGLVersion = OpenGLVersion !Int !Int+ deriving ( Eq, Show, Read, Typeable )++instance Ord OpenGLVersion where+ OpenGLVersion ma1 mi1 `compare` OpenGLVersion ma2 mi2 =+ -- I think this would be equivalent to the auto-derived version but I'm+ -- not sure. It's important that it has this definition though.+ if | ma1 > ma2 -> GT+ | ma1 < ma2 -> LT+ | mi1 > mi2 -> GT+ | mi1 < mi2 -> LT+ | otherwise -> EQ++openGLVersion :: OpenGLVersion+#ifndef FIXED_OPENGL_MAJOR_VERSION+openGLVersion = OpenGLVersion (head ver) (head $ tail ver)+ where+ ver = versionBranch version+#else+openGLVersion = OpenGLVersion FIXED_OPENGL_MAJOR_VERSION FIXED_OPENGL_MINOR_VERSION+#endif++shadingLanguageVersionString :: String+shadingLanguageVersionString = unsafePerformIO $ getString GL_SHADING_LANGUAGE_VERSION+{-# NOINLINE shadingLanguageVersionString #-}++-- | Return the primary shading language version+shadingLanguageVersion :: Version+shadingLanguageVersion = Version [] [] `fromMaybe` parse shadingLanguageVersionString++-- | Returns a set of shading language versions supported by this implementation.+shadingLanguageVersions :: Set Version+shadingLanguageVersions + | version >= Version [4,3] [] = unsafePerformIO $ do+ n <- alloca $ \p -> do+ poke p 0 -- unsupported until 4.2, so scribble a 0 in first+ glGetIntegerv GL_NUM_SHADING_LANGUAGE_VERSIONS p+ peek p+ versions <- forM [0..fromIntegral n-1] $ \i -> do+ cs <- glGetStringi GL_SHADING_LANGUAGE_VERSION i+ parse <$> peekCString (castPtr cs)+ return $ Set.fromList $ catMaybes versions+ | otherwise = Set.singleton shadingLanguageVersion++{-# NOINLINE shadingLanguageVersions #-}
+ src/Graphics/Caramia/OpenGLResource.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Graphics.Caramia.OpenGLResource+ ( OpenGLResource(..) )+ where++import Control.Monad.IO.Class++-- | All OpenGL resources implement this typeclass.+--+-- The resources have an inner type, usually a `GLuint` but not always.+--+-- If you work with raw OpenGL resources, you may need to use `touch` to make+-- sure the resource is not garbage collected prematurely.+class OpenGLResource innertype a | a -> innertype where+ -- ^ Returns the raw OpenGL type.+ getRaw :: MonadIO m => a -> m innertype++ -- ^ Guarantees that the resource has not been garbage collected at the+ -- point this function is invoked.+ touch :: MonadIO m => a -> m ()+
src/Graphics/Caramia/Query.hs view
@@ -6,9 +6,15 @@ -- -- <https://www.opengl.org/wiki/Query_Object> --+-- Most features in this module require either OpenGL 3.3 or an extension.+-- +{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} @@ -43,21 +49,28 @@ import Foreign.Marshal.Alloc import Foreign.Storable import Graphics.Caramia.Internal.ContextLocalData+import Graphics.Caramia.Internal.Exception import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.OpenGLResource import Graphics.Caramia.Prelude import Graphics.Caramia.Resource+import Graphics.GL.Ext.ARB.OcclusionQuery+import Graphics.GL.Ext.ARB.OcclusionQuery2+import Graphics.GL.Ext.ARB.TimerQuery -- | What kind of query to make? These queries return integer results. data NumericQueryType = SamplesPassed | PrimitivesGenerated | TransformFeedbackPrimitivesWritten- | TimeElapsed+ | TimeElapsed -- ^ Requires OpenGL 3.3 or @ GL_ARB_timer_query @. deriving ( Eq, Ord, Show, Read, Typeable, Enum ) -- | What of query to make? These queries return boolean results. data BooleanQueryType- = AnySamplesPassed+ = AnySamplesPassed -- ^ If @ GL_ARB_occlusion_query2 @ or OpenGL 3.3 is+ -- not available, this is implemented with+ -- `SamplesPassed` behind the scenes. deriving ( Eq, Ord, Show, Read, Typeable, Enum ) -- | Which queries cannot be used together?@@ -77,6 +90,12 @@ , isActive :: !(IORef Bool) } deriving ( Typeable ) +instance OpenGLResource GLuint (Query a) where+ getRaw query = do+ Query_ name <- getRaw (WrappedOpenGLResource $ resource query)+ return name+ touch query = touch (WrappedOpenGLResource $ resource query)+ newtype Query_ = Query_ GLuint instance Eq (Query a) where@@ -114,6 +133,8 @@ -- There can be only one active query for each query type. An user error will -- be thrown if this is violated. --+-- `AnySamplesPassed` cannot be used at the same time as `SamplesPassed`.+-- -- You can query the returned `Query` for results. However, because using the -- GPU is typically asynchronous, results may not be (and often are not) -- immediately available. Use `tryGetResults` to check if results have become@@ -226,8 +247,21 @@ newQuery :: MonadIO m => SomeQuery -> m (Query a)-newQuery qt =+newQuery qt' = liftIO $ mask_ $ do+ qt <- case qt' of+ Left SamplesPassed -> return qt'+ Left TimeElapsed ->+ checkOpenGLOrExtensionM (OpenGLVersion 3 3)+ "GL_ARB_timer_query"+ gl_ARB_timer_query $ return qt'+ Left _ -> checkExtensionM "GL_ARB_occlusion_query"+ gl_ARB_occlusion_query $ return qt'+ Right AnySamplesPassed+ | openGLVersion < OpenGLVersion 3 3 &&+ not gl_ARB_occlusion_query2 -> return (Left SamplesPassed)+ | otherwise -> return qt'+ unique <- newUnique resource <- newResource (Query_ <$> mglGenQuery) (\(Query_ queryname) -> do
src/Graphics/Caramia/Render.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-} {-# LANGUAGE ViewPatterns, NoImplicitPrelude, DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE CPP #-} module Graphics.Caramia.Render@@ -38,29 +40,31 @@ , Culling(..) ) where -import Graphics.Caramia.Prelude--import qualified Graphics.Caramia.VAO.Internal as VAO-import qualified Graphics.Caramia.Shader.Internal as Shader-import qualified Graphics.Caramia.Framebuffer as FBuf-import qualified Graphics.Caramia.Framebuffer.Internal as FBuf-import qualified Graphics.Caramia.Texture.Internal as Texture-import qualified Data.IntMap.Strict as IM-import Graphics.Caramia.Render.Internal hiding ( setFragmentPassTests )-import qualified Graphics.Caramia.Render.Internal as I-import Graphics.Caramia.Blend-import Graphics.Caramia.Blend.Internal-import Graphics.Caramia.Texture-import Graphics.Caramia.Texture.Internal ( withTextureBinding )-import Graphics.Caramia.Resource-import Graphics.Caramia.Buffer.Internal-import Graphics.Caramia.Internal.OpenGLCApi import Control.Monad.Trans.Class import Control.Monad.IO.Class import Control.Monad.Catch import Control.Monad.Trans.State.Strict+import qualified Data.IntMap.Strict as IM import Foreign import Foreign.C.Types+import Graphics.Caramia.Blend+import Graphics.Caramia.Blend.Internal+import Graphics.Caramia.Buffer.Internal+import qualified Graphics.Caramia.Framebuffer as FBuf+import qualified Graphics.Caramia.Framebuffer.Internal as FBuf+import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.Internal.Exception+import Graphics.Caramia.Prelude+import Graphics.Caramia.Render.Internal hiding ( setFragmentPassTests )+import qualified Graphics.Caramia.Render.Internal as I+import Graphics.Caramia.Resource+import qualified Graphics.Caramia.Shader.Internal as Shader+import Graphics.Caramia.Texture+import qualified Graphics.Caramia.Texture.Internal as Texture+import Graphics.Caramia.Texture.Internal ( withTextureBinding )+import qualified Graphics.Caramia.VAO.Internal as VAO+import Graphics.GL.Ext.NV.PrimitiveRestart+import Graphics.GL.Ext.ARB.DrawInstanced -- | The different types of primitives you can use for rendering. --@@ -255,23 +259,43 @@ withBoundVAO vao_name $ case sourceData of Primitives {..} ->- glDrawArraysInstanced- (toConstant primitiveType)- (safeFromIntegral firstIndex)- (safeFromIntegral numIndices)- (safeFromIntegral numInstances)+ if gl_ARB_draw_instanced+ then glDrawArraysInstancedARB+ (toConstant primitiveType)+ (safeFromIntegral firstIndex)+ (safeFromIntegral numIndices)+ (safeFromIntegral numInstances)+ else if numInstances == 1+ then glDrawArrays+ (toConstant primitiveType)+ (safeFromIntegral firstIndex)+ (safeFromIntegral numIndices)+ else nosupport PrimitivesWithIndices {..} -> withResource (resource indexBuffer) $ \(Buffer_ buf_name) -> do when (buf_name /= boundEbo state) $ setBoundElementBuffer buf_name- glDrawElementsInstanced+ if gl_ARB_draw_instanced+ then glDrawElementsInstanced (toConstant primitiveType) (safeFromIntegral numIndices) (toConstantIT indexType) (intPtrToPtr $ fromIntegral indexOffset) (safeFromIntegral numInstances)+ else if numInstances == 1+ then glDrawElements+ (toConstant primitiveType)+ (safeFromIntegral numIndices)+ (toConstantIT indexType)+ (intPtrToPtr $+ fromIntegral indexOffset)+ else nosupport+ where+ nosupport = throwM $ NoSupport $+ "Instanced rendering requires GL_ARB_draw_instanced."+ -- inline `draw` because it's probably quite common to directly construct -- `DrawCommand` right there, so we can avoid all sorts of boxing and checking -- that happens.@@ -293,11 +317,7 @@ deriving ( Eq, Ord, Typeable ) newtype DrawT m a = DrawT (StateT DrawState m a)-#if __GLASGOW_HASKELL__ < 708- deriving ( Monad, Applicative, Functor )-#else- deriving ( Monad, Applicative, Functor, Typeable )-#endif+ deriving ( Monad, Applicative, Functor, Typeable ) type Draw = DrawT IO @@ -364,21 +384,44 @@ glActiveTexture old_active glViewport ox oy ow oh +data PrimitiveRestartFuns = PrimitiveRestartFuns {+ prIndex :: !GLenum+ , prRestart :: !GLenum+ , prPrimitiveRestartIndex :: !(GLuint -> IO ()) }++withPrimitiveRestartFuns :: (Monad m, MonadIO m)+ => Bool -> m a -> (PrimitiveRestartFuns -> m a) -> m a+withPrimitiveRestartFuns do_backup backup_action action =+ if | gl_NV_primitive_restart -> action nvfuns+ | openGLVersion >= OpenGLVersion 3 1 -> action o31funs+ | do_backup -> backup_action+ | otherwise ->+ liftIO $ throwM $ NoSupport "Primitive restart requires OpenGL 3.1 or GL_NV_primitive_restart."+ where+ nvfuns = PrimitiveRestartFuns GL_PRIMITIVE_RESTART_INDEX_NV+ GL_PRIMITIVE_RESTART_NV+ glPrimitiveRestartIndexNV++ o31funs = PrimitiveRestartFuns GL_PRIMITIVE_RESTART_INDEX+ GL_PRIMITIVE_RESTART+ glPrimitiveRestartIndex+ withPrimitiveRestart :: (MonadIO m, MonadMask m) => Maybe Word32 -> m a -> m a-withPrimitiveRestart pr action = do- old_primitive_restart_enabled <- liftIO $ glIsEnabled GL_PRIMITIVE_RESTART- old_i <- gi GL_PRIMITIVE_RESTART_INDEX- finally (activate >> action)- (do if old_primitive_restart_enabled /= 0- then glEnable GL_PRIMITIVE_RESTART- else glDisable GL_PRIMITIVE_RESTART- glPrimitiveRestartIndex old_i)+withPrimitiveRestart pr action =+ withPrimitiveRestartFuns (isNothing pr) action $ \funs@(PrimitiveRestartFuns{..}) -> do+ old_primitive_restart_enabled <- liftIO $ glIsEnabled prRestart+ old_i <- gi prIndex+ finally (activate funs >> action)+ (do if old_primitive_restart_enabled /= 0+ then glEnable prRestart+ else glDisable prRestart+ liftIO $ prPrimitiveRestartIndex old_i) where- activate = case pr of- Nothing -> glDisable GL_PRIMITIVE_RESTART+ activate (PrimitiveRestartFuns{..}) = case pr of+ Nothing -> glDisable prRestart Just value -> do- glEnable GL_PRIMITIVE_RESTART- glPrimitiveRestartIndex (fromIntegral value)+ glEnable prRestart+ liftIO $ prPrimitiveRestartIndex (fromIntegral value) withPolygonOffset :: (MonadIO m, MonadMask m) => (Float, Float) -> m a -> m a withPolygonOffset (factor, units) action = do@@ -399,18 +442,19 @@ -- | Sets new primitive restart mode. setPrimitiveRestart :: MonadIO m => Maybe Word32 -> DrawT m ()-setPrimitiveRestart restart = DrawT $ do- pr <- return . boundPrimitiveRestart =<< get- liftIO $ case (pr, restart) of- (Nothing, Just x) -> do- glEnable GL_PRIMITIVE_RESTART- glPrimitiveRestartIndex (fromIntegral x)- (Just _, Nothing) -> do- glDisable GL_PRIMITIVE_RESTART- (Just y, Just x) | y /= x ->- glPrimitiveRestartIndex (fromIntegral x)- _ -> return ()- modify (\old -> old { boundPrimitiveRestart = restart })+setPrimitiveRestart restart = DrawT $+ withPrimitiveRestartFuns (isNothing restart) (return ()) $ \PrimitiveRestartFuns{..} -> do+ pr <- return . boundPrimitiveRestart =<< get+ liftIO $ case (pr, restart) of+ (Nothing, Just x) -> do+ glEnable prRestart+ prPrimitiveRestartIndex (fromIntegral x)+ (Just _, Nothing) -> do+ glDisable prRestart+ (Just y, Just x) | y /= x ->+ prPrimitiveRestartIndex (fromIntegral x)+ _ -> return ()+ modify (\old -> old { boundPrimitiveRestart = restart }) -- | Sets new texture bindings. setTextureBindings :: MonadIO m => IM.IntMap Texture -> DrawT m ()
src/Graphics/Caramia/Resource.hs view
@@ -15,17 +15,22 @@ -- {-# LANGUAGE BangPatterns, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} module Graphics.Caramia.Resource ( Resource() , newResource- , withResource )+ , withResource+ , WrappedOpenGLResource(..) ) where -import Graphics.Caramia.Prelude-import Graphics.Caramia.Context-import Control.Monad.IO.Class import Control.Monad.Catch+import Control.Monad.IO.Class+import Graphics.Caramia.Context+import Graphics.Caramia.OpenGLResource+import Graphics.Caramia.Prelude -- | The data type of a Caramia resource. data Resource a = Resource@@ -37,6 +42,20 @@ } deriving ( Typeable ) +-- | Wrap a `Resource` to a `WrappedOpenGLResource`. The wrapped resource has+-- `OpenGLResource` implementation.+newtype WrappedOpenGLResource a = WrappedOpenGLResource (Resource a)+ deriving ( Eq, Typeable )++instance OpenGLResource a (WrappedOpenGLResource a) where+ getRaw (WrappedOpenGLResource managed) =+ liftIO $ readIORef (rawResource managed) >>= \case+ Nothing -> error "getRaw (WrappedOpenGLResource): resource has been finalized."+ Just (r, _, _) -> return r++ touch (WrappedOpenGLResource managed) =+ liftIO $ touchIORef (rawResource managed)+ instance Eq (Resource a) where res1 == res2 = rawResource res1 == rawResource res2 @@ -144,5 +163,7 @@ liftIO (readIORef ref) where ref = rawResource resource- touchIORef !_ = return ()++touchIORef :: IORef a -> IO ()+touchIORef !_ = return ()
src/Graphics/Caramia/Shader.hs view
@@ -22,13 +22,17 @@ {-# LANGUAGE ExistentialQuantification, ViewPatterns, OverloadedStrings #-} module Graphics.Caramia.Shader- ( newShader+ (+ -- * Creating new shaders.+ newShader , newShaderB , newShaderBL , newPipeline , newPipelineVF , Shader() , Pipeline()+ -- ** Attribute bindings+ , AttributeBindings -- * Uniforms , setUniform , getUniformLocation@@ -47,14 +51,16 @@ ) where +import Control.Lens ( ifor_ )+import Control.Monad.Catch+import Control.Monad.IO.Class import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as BL+import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Foreign as T-import Control.Monad.Catch-import Control.Monad.IO.Class import Foreign import Foreign.C.Types import GHC.Float ( double2Float )@@ -227,15 +233,30 @@ newPipelineVF :: MonadIO m => T.Text -- ^ Vertex shader source. -> T.Text -- ^ Fragment shader source.+ -> AttributeBindings -- ^ Attribute bindings. -> m Pipeline-newPipelineVF vert_src frag_src = liftIO $ do+newPipelineVF vert_src frag_src bindings = liftIO $ do vsh <- newShader vert_src Vertex fsh <- newShader frag_src Fragment- newPipeline [vsh, fsh]+ newPipeline [vsh, fsh] bindings +-- | Binds attribute names to specific attribute indices.+--+-- See `glBindAttribLocation` from OpenGL documentation.+--+-- The `Map` is from containers and is a member of `Monoid` so you can use+-- `mempty` if you are not doing any special binding.+--+-- You can use `mapKeys` or `mapKeysMonotonic` to change the key and `fmap` to+-- map indices.+type AttributeBindings = M.Map B.ByteString GLuint+ -- | Creates a pipeline composed of different shaders.-newPipeline :: MonadIO m => [Shader] -> m Pipeline-newPipeline shaders = liftIO $ mask_ $ do+newPipeline :: MonadIO m+ => [Shader]+ -> AttributeBindings+ -> m Pipeline+newPipeline shaders attribute_bindings = liftIO $ mask_ $ do res <- newResource creator deleter (return ())@@ -249,6 +270,9 @@ for_ shaders $ \shader -> withResource (resource shader) $ \(CompiledShader sname) -> glAttachShader program sname+ ifor_ attribute_bindings $ \key binding ->+ B.useAsCString key $ \key_cstr ->+ glBindAttribLocation program binding key_cstr glLinkProgram program checkLinkingErrors program return $ Pipeline_ program@@ -661,7 +685,18 @@ cr = do vsh <- newShader vsh_src Vertex fsh <- newShader fsh_src Fragment- newPipeline [vsh, fsh] >>= return . CLNopPipeline+ newPipeline [vsh, fsh] mempty >>= return . CLNopPipeline where- vsh_src = "#version 330\nvoid main() { }\n"- fsh_src = "#version 330\nvoid main() { }\n"+ (vsh_src, fsh_src) =+ (nopsrc, nopsrc)+ where+ nopsrc = case openGLVersion of+ OpenGLVersion 3 2 -> "#version 150\nvoid main() { }\n"+ OpenGLVersion 3 1 -> "#version 140\nvoid main() { }\n"+ OpenGLVersion 3 0 -> "#version 130\nvoid main() { }\n"+ OpenGLVersion 2 1 -> "#version 120\nvoid main() { }\n"+ OpenGLVersion 2 0 -> "#version 110\nvoid main() { }\n"+ OpenGLVersion maj min ->+ "#version " <> showT maj <> showT min <> "0\n" <>+ "void main() { }\n"+
src/Graphics/Caramia/Shader/Internal.hs view
@@ -1,8 +1,12 @@ {-# LANGUAGE ViewPatterns, NoImplicitPrelude, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} module Graphics.Caramia.Shader.Internal where import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.OpenGLResource import Graphics.Caramia.Prelude import Graphics.Caramia.Resource @@ -17,6 +21,12 @@ } deriving ( Typeable ) +instance OpenGLResource GLuint Shader where+ getRaw shader = do+ CompiledShader name <- getRaw (WrappedOpenGLResource $ resource shader)+ return name+ touch shader = touch (WrappedOpenGLResource $ resource shader)+ instance Eq Shader where (resource -> res1) == (resource -> res2) = res1 == res2 @@ -25,7 +35,7 @@ instance Ord Shader where (identifier -> id1) `compare` (identifier -> id2) = id1 `compare` id2 -data Shader_ = CompiledShader !GLuint -- OpenGL shader+newtype Shader_ = CompiledShader GLuint -- OpenGL shader -- | A pipeline object that references a collection of shaders. --@@ -35,6 +45,14 @@ , pipelineIdentifier :: !Unique , shaders :: [Shader] } deriving ( Typeable )++-- | Despite the Haskell name, `Pipeline`, the object is a shader program+-- object.+instance OpenGLResource GLuint Pipeline where+ getRaw program = do+ Pipeline_ name <- getRaw (WrappedOpenGLResource $ resourcePL program)+ return name+ touch program = touch (WrappedOpenGLResource $ resourcePL program) instance Eq Pipeline where p1 == p2 = resourcePL p1 == resourcePL p2
src/Graphics/Caramia/Sync.hs view
@@ -6,8 +6,14 @@ -- At the moment, the only place where these objects are useful in Caramia is -- unsynchronized buffer mapping. --+-- Operations in this module require @ GL_ARB_sync @ extension or OpenGL 3.2.+-- {-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, MultiWayIf #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Graphics.Caramia.Sync@@ -22,27 +28,34 @@ import Control.Monad.Catch import Control.Monad.IO.Class+import Graphics.Caramia.Internal.Exception import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.OpenGLResource import Graphics.Caramia.Prelude import Graphics.Caramia.Resource+import Graphics.GL.Ext.ARB.Sync ( gl_ARB_sync ) data Fence = Fence { resource :: !(Resource GLsync) , ordIndex :: !Unique } deriving ( Eq, Typeable ) +instance OpenGLResource GLsync Fence where+ getRaw (Fence r _) = getRaw $ WrappedOpenGLResource r+ touch (Fence r _) = touch $ WrappedOpenGLResource r+ instance Ord Fence where (ordIndex -> o1) `compare` (ordIndex -> o2) = o1 `compare` o2 -- | Create a fence.-fence :: (MonadIO m, MonadMask m) => m Fence-fence = mask_ $ do- resource <-- newResource createFence- glDeleteSync- (return ())- unique <- liftIO newUnique- return $ Fence { resource = resource- , ordIndex = unique }+fence :: MonadIO m => m Fence+fence = liftIO $ mask_ $ do+ checkOpenGLOrExtensionM (OpenGLVersion 3 2)+ "GL_ARB_sync"+ gl_ARB_sync $ do+ resource <- newResource createFence glDeleteSync (return ())+ unique <- liftIO newUnique+ return $ Fence { resource = resource+ , ordIndex = unique } where createFence = glFenceSync GL_SYNC_GPU_COMMANDS_COMPLETE 0
src/Graphics/Caramia/Texture.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude #-} {-# LANGUAGE MultiWayIf, ViewPatterns, DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} module Graphics.Caramia.Texture (@@ -52,12 +53,15 @@ import Graphics.Caramia.Prelude import Graphics.Caramia.Texture.Internal+import Graphics.Caramia.Internal.Exception import Graphics.Caramia.Internal.TexStorage import Graphics.Caramia.Internal.OpenGLCApi import qualified Graphics.Caramia.Buffer.Internal as Buf import Graphics.Caramia.ImageFormats.Internal import Graphics.Caramia.Resource+import Graphics.GL.Ext.ARB.TextureBufferObject import Graphics.GL.Ext.ARB.TextureStorage+import Graphics.GL.Ext.ARB.TextureMultisample import Graphics.GL.Ext.EXT.TextureFilterAnisotropic import Control.Monad.IO.Class import Control.Monad.Catch@@ -300,6 +304,9 @@ (safeFromIntegral height2DArray) (safeFromIntegral layers2D) createByTopologyTexStorage name (Tex2DMultisample {..}) =+ checkOpenGLOrExtensionM (OpenGLVersion 3 2)+ "GL_ARB_texture_multisample"+ gl_ARB_texture_multisample $ withBinding GL_TEXTURE_2D_MULTISAMPLE GL_TEXTURE_BINDING_2D_MULTISAMPLE name $@@ -312,6 +319,9 @@ (if fixedSampleLocations2DMS then 1 else 0) createByTopologyTexStorage name (Tex2DMultisampleArray {..}) =+ checkOpenGLOrExtensionM (OpenGLVersion 3 2)+ "GL_ARB_texture_multisample"+ gl_ARB_texture_multisample $ withBinding GL_TEXTURE_2D_MULTISAMPLE_ARRAY GL_TEXTURE_BINDING_2D_MULTISAMPLE_ARRAY name $@@ -334,6 +344,9 @@ (safeFromIntegral widthCube) (safeFromIntegral widthCube) createByTopologyTexStorage name (TexBuffer {..}) =+ checkOpenGLOrExtensionM (OpenGLVersion 3 1)+ "GL_ARB_texture_buffer_object"+ gl_ARB_texture_buffer_object $ withBinding GL_TEXTURE_BUFFER GL_TEXTURE_BINDING_BUFFER name $
src/Graphics/Caramia/Texture/Internal.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE RecordWildCards, NoImplicitPrelude, LambdaCase #-} {-# LANGUAGE DeriveDataTypeable, MultiWayIf #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} module Graphics.Caramia.Texture.Internal where @@ -8,6 +11,7 @@ import qualified Graphics.Caramia.Buffer.Internal as Buf import Graphics.Caramia.ImageFormats import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.OpenGLResource import Graphics.Caramia.Prelude import Graphics.Caramia.Resource @@ -17,6 +21,12 @@ , viewSpecification :: !TextureSpecification } deriving ( Typeable ) +instance OpenGLResource GLuint Texture where+ getRaw tex = do+ Texture_ name <- getRaw (WrappedOpenGLResource $ resource tex)+ return name+ touch tex = touch (WrappedOpenGLResource $ resource tex)+ newtype Texture_ = Texture_ GLuint -- | The type of a texture unit.@@ -67,6 +77,8 @@ , height2DMS :: !Int , samples2DMS :: !Int , fixedSampleLocations2DMS :: !Bool }+ -- ^ Multisampling is available if OpenGL version >= 3.2 or+ -- `GL_ARB_texture_multisample` is available. | Tex2DMultisampleArray { width2DMSArray :: !Int , height2DMSArray :: !Int@@ -77,6 +89,9 @@ | TexBuffer { texBuffer :: !Buf.Buffer } -- ^ Buffer textures, see -- <https://www.opengl.org/wiki/Buffer_Texture>+ --+ -- Available if OpenGL version >= 3.1 or+ -- `GL_ARB_texture_buffer_object` is available. deriving ( Eq, Show, Typeable ) withBinding :: (MonadIO m, MonadMask m) => GLenum -> GLenum -> GLuint -> m a -> m a
src/Graphics/Caramia/VAO.hs view
@@ -5,7 +5,12 @@ -- -- <https://www.opengl.org/wiki/Vertex_Array_Object> --+-- Either OpenGL 3.0 or @ GL_ARB_vertex_array_object @ extension is required to+-- use operations from this module.+-- +{-# LANGUAGE OverloadedStrings #-}+ module Graphics.Caramia.VAO ( -- * Creation newVAO@@ -25,10 +30,12 @@ import Control.Monad.Catch import Data.Unique import qualified Graphics.Caramia.Buffer.Internal as Buf+import Graphics.Caramia.Internal.Exception import Graphics.Caramia.Internal.OpenGLCApi import Graphics.Caramia.Prelude import Graphics.Caramia.Resource import Graphics.Caramia.VAO.Internal+import Graphics.GL.Ext.ARB.VertexArrayObject -- | Creates a vertex array object. --@@ -36,14 +43,17 @@ -- program. newVAO :: MonadIO m => m VAO newVAO = liftIO $ mask_ $ do- res <- newResource create- (\(VAO_ vao) -> mglDeleteVertexArray vao)- (return ())- ref <- newIORef []- unique <- newUnique- return VAO { resource = res- , boundBuffers = ref- , vaoIndex = unique }+ checkOpenGLOrExtensionM (OpenGLVersion 3 0)+ "GL_ARB_vertex_array_object"+ gl_ARB_vertex_array_object $ do+ res <- newResource create+ (\(VAO_ vao) -> mglDeleteVertexArray vao)+ (return ())+ ref <- newIORef []+ unique <- newUnique+ return VAO { resource = res+ , boundBuffers = ref+ , vaoIndex = unique } where create = VAO_ <$> mglGenVertexArray
src/Graphics/Caramia/VAO/Internal.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE NoImplicitPrelude, ViewPatterns, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} module Graphics.Caramia.VAO.Internal where @@ -7,6 +10,7 @@ import Graphics.Caramia.Resource import Graphics.Caramia.Internal.OpenGLCApi import qualified Graphics.Caramia.Buffer.Internal as Buf+import Graphics.Caramia.OpenGLResource -- | The vertex array object data type. data VAO = VAO@@ -22,4 +26,10 @@ (vaoIndex -> v1) `compare` (vaoIndex -> v2) = v1 `compare` v2 newtype VAO_ = VAO_ GLuint++instance OpenGLResource GLuint VAO where+ getRaw vao = do+ VAO_ name <- getRaw (WrappedOpenGLResource $ resource vao)+ return name+ touch vao = touch (WrappedOpenGLResource $ resource vao)
+ tests/buffer/Main.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Main ( main ) where++import Control.Concurrent+import Control.Exception+import qualified Data.Set as S+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import Graphics.Caramia+import Graphics.Caramia.Prelude+import Linear.V2+import SDL+import System.IO.Unsafe ( unsafePerformIO )+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding ( Test )++foreign import ccall unsafe "memset" c_memset+ :: Ptr a -> CInt -> CSize -> IO (Ptr b)++sdlLock :: MVar ()+sdlLock = unsafePerformIO $ newMVar ()+{-# NOINLINE sdlLock #-}++setup :: IO a -> IO a+setup action = runInBoundThread $ withMVar sdlLock $ \_ -> do+ initialize [InitEverything]+ let glconfig = defaultOpenGL {+ glProfile = Core Normal 3 3+ }+ w <- createWindow "buffer" defaultWindow {+ windowOpenGL = Just glconfig+ , windowSize = V2 1500 1000+ }+ ctx <- glCreateContext w+ finally (giveContext action) $ do+ glDeleteContext ctx+ destroyWindow w+ quit++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests = [+ testCase "Invalidation does not crash and burn" invalidateSomeBuffers+ , testCase "I can create various types of buffers" createSomeBuffers+ , testCase "I cannot map write-only buffers for reading" writeOnlyTest+ , testCase "I cannot map read-only buffers for writing" readOnlyTest+ , testCase "I cannot map no-access buffers for anything" noAccessTest+ , testCase "I can map readwrite buffers for anything" readWriteTest+ , testCase "What I write I can get back" writeReadBackTest+ , testCase "Mapping with offset works" offsetMappingTest+ , testCase "Mapping with unsynchronized flag set doesn't crash" unsyncTest+ , testCase "Buffer copying works" copyBuffersTest+ ]++copyBuffersTest :: IO ()+copyBuffersTest = setup $ do+ buf <- newBufferFromList (take 10000 $ repeat (77 :: Word8))+ (\old -> old { accessFlags = ReadWriteAccess })+ buf2 <- newBufferFromList (take 20000 $ repeat (99 :: Word8))+ (\old -> old { accessFlags = ReadWriteAccess })+ buf3 <- newBufferFromList (replicate 300 111 ++ replicate 300 222 :: [Word8])+ (\old -> old { accessFlags = ReadWriteAccess })+ -- copy from another to another+ copy buf 11 buf2 13 5+ -- copying inside the same buffer+ copy buf3 3 buf3 311 5++ withMapping 0 100 ReadAccess buf $ \ptr -> do+ let cptr = castPtr ptr :: Ptr Word8+ ass = assertEqual "bytes copied look correct"+ assM x off = do v <- peekElemOff cptr off+ ass x v+ assM 77 0+ assM 77 1+ assM 77 2+ assM 77 3+ assM 77 4+ assM 77 10+ assM 99 11+ assM 99 12+ assM 99 13+ assM 99 14+ assM 99 15+ assM 77 16+ withMapping 0 600 ReadAccess buf3 $ \ptr -> do+ let cptr = castPtr ptr :: Ptr Word8+ ass = assertEqual "bytes copied look correct"+ assM x off = do v <- peekElemOff cptr off+ ass x v+ assM 111 0+ assM 111 1+ assM 111 2+ assM 222 3+ assM 222 4+ assM 222 5+ assM 222 6+ assM 222 7+ assM 111 8+ assM 111 9+ assM 111 10++offsetMappingTest :: IO ()+offsetMappingTest = setup $ do+ buf <- newBufferFromList (take 10000 $ cycle [(0 :: Word8)..])+ (\old -> old { accessFlags = ReadWriteAccess })+ for_ offsets $ \off -> withMapping off 32 ReadAccess buf $ \ptr -> do+ let cptr = castPtr ptr :: Ptr Word8+ expect m v = assertEqual "a byte read from a buffer should be the same that was written"+ (fromIntegral $ (off+m) `mod` 256)+ v+ v1 <- peekElemOff cptr 0+ v2 <- peekElemOff cptr 1+ v3 <- peekElemOff cptr 2+ v4 <- peekElemOff cptr 3+ expect 0 v1+ expect 1 v2+ expect 2 v3+ expect 3 v4+ where+ offsets = [ 0, 16, 1024, 2048, 2040, 8000 ]++writeReadBackTest :: IO ()+writeReadBackTest = setup $ do+ buf <- newBuffer defaultBufferCreation+ { size = 1000000+ , accessFlags = ReadWriteAccess }+ withMapping 0 1000000 WriteAccess buf $ \ptr -> do+ void $ c_memset ptr 33 1000000+ pokeElemOff (castPtr ptr :: Ptr Word8) 12371 177+ withMapping 0 1000000 ReadAccess buf $ \ptr -> do+ let cptr = castPtr ptr :: Ptr Word8+ v <- peekElemOff cptr 12371+ assertEqual "a byte read from a buffer should be the same that was written"+ 177+ v+ v_prec <- peekElemOff cptr 12370+ v_succ <- peekElemOff cptr 12372+ assertEqual "a byte read from a buffer should be the same that was written"+ 33+ v_prec+ assertEqual "a byte read from a buffer should be the same that was written"+ 33+ v_succ++writeOnlyTest :: IO ()+writeOnlyTest = setup $ do+ buf <- newBuffer defaultBufferCreation+ { size = 1024+ , accessFlags = WriteAccess }+ expectException $ bufferMap 0 1024 ReadAccess buf+ expectException $ bufferMap 0 1024 ReadWriteAccess buf+ withMapping 0 1024 WriteAccess buf (const $ return ())++readOnlyTest :: IO ()+readOnlyTest = setup $ do+ buf <- newBuffer defaultBufferCreation+ { size = 1024+ , accessFlags = ReadAccess }+ expectException $ bufferMap 0 1024 WriteAccess buf+ expectException $ bufferMap 0 1024 ReadWriteAccess buf+ withMapping 0 1024 ReadAccess buf (const $ return ())++noAccessTest :: IO ()+noAccessTest = setup $ do+ buf <- newBuffer defaultBufferCreation+ { size = 1024+ , accessFlags = NoAccess }+ for_ allAccessFlags $ \flags ->+ expectException $ bufferMap 0 1024 flags buf++readWriteTest :: IO ()+readWriteTest = setup $ do+ buf <- newBuffer defaultBufferCreation+ { size = 1024+ , accessFlags = ReadWriteAccess }+ for_ allAccessFlags $ \flags ->+ when (flags /= NoAccess) $+ withMapping 0 1024 flags buf (const $ return ())++expectException :: IO a -> IO ()+expectException action = do+ result <- try action+ case result of+ Left (_ :: SomeException) -> return ()+ Right _ -> error "expected exception"++withSomeBuffers :: (BufferCreation -> Buffer -> IO ()) -> IO ()+withSomeBuffers action =+ for_ allAccessHints $ \hints ->+ for_ allAccessFlags $ \flags ->+ for_ sizes $ \size -> do+ let c = defaultBufferCreation {+ size = size+ , initialData = Nothing+ , accessFlags = flags+ , accessHints = hints }+ newBuffer c >>= action c+ allocaBytes size $ \ptr -> do+ let c' = c { initialData = Just ptr }+ newBuffer c' >>= action c'+ runPendingFinalizers++unsyncTest :: IO ()+unsyncTest = setup $ withSomeBuffers $ \cr buf -> do+ when (accessFlags cr == WriteAccess ||+ accessFlags cr == ReadWriteAccess) $+ withMapping2 (S.singleton UnSynchronized)+ 0+ (size cr)+ WriteAccess+ buf $ const $ return ()++invalidateSomeBuffers :: IO ()+invalidateSomeBuffers = setup $ withSomeBuffers $ \_ -> invalidateBuffer++createSomeBuffers :: IO ()+createSomeBuffers = setup $ withSomeBuffers (\_ _ -> return ())++sizes :: [Int]+sizes = [ 1, 2, 3, 4, 8, 11, 12, 512, 1024, 1023, 1025, 1000000 ]++allAccessFlags :: [AccessFlags]+allAccessFlags = [ReadAccess, WriteAccess, ReadWriteAccess, NoAccess]++allAccessHints :: [(AccessFrequency, AccessNature)]+allAccessHints = [ (f, n) | f <- [Stream, Static, Dynamic]+ , n <- [Draw, Read, Copy] ]+
+ tests/shader/Main.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Main ( main ) where++import Control.Concurrent+import Control.Exception+import Linear.V2+import Graphics.Caramia+import Graphics.Caramia.Prelude+import SDL+import System.IO.Unsafe ( unsafePerformIO )+import Test.Framework+import Test.Framework.Providers.HUnit++sdlLock :: MVar ()+sdlLock = unsafePerformIO $ newMVar ()+{-# NOINLINE sdlLock #-}++setup :: IO a -> IO a+setup action = runInBoundThread $ withMVar sdlLock $ \_ -> do+ initialize [InitEverything]+ let glconfig = defaultOpenGL {+ glProfile = Core Normal 3 3+ }+ w <- createWindow "buffer" defaultWindow {+ windowOpenGL = Just glconfig+ , windowSize = V2 1500 1000+ }+ ctx <- glCreateContext w+ finally (giveContext action) $ do+ glDeleteContext ctx+ destroyWindow w+ quit++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests = [+ testCase "I can create the nop shader pipeline" nopPipelineTest+ ]++nopPipelineTest :: IO ()+nopPipelineTest = setup $ do+ x <- nopPipeline+ x `seq` return ()+