caramia 0.7.1.1 → 0.7.2.0
raw patch · 22 files changed
+461/−110 lines, 22 filesdep +mtldep ~basedep ~containersdep ~sdl2
Dependencies added: mtl
Dependency ranges changed: base, containers, sdl2
Files
- README.md +2/−1
- caramia.cabal +20/−2
- src/Graphics/Caramia/Blend/Internal.hs +9/−7
- src/Graphics/Caramia/Buffer.hs +55/−15
- src/Graphics/Caramia/Buffer/Internal.hs +19/−3
- src/Graphics/Caramia/Color.hs +5/−1
- src/Graphics/Caramia/Framebuffer/Internal.hs +6/−1
- src/Graphics/Caramia/ImageFormats/Internal.hs +7/−5
- src/Graphics/Caramia/Internal/OpenGLCApi.hs +50/−15
- src/Graphics/Caramia/OpenGLResource.hs +7/−2
- src/Graphics/Caramia/Query.hs +6/−2
- src/Graphics/Caramia/Render.hs +76/−22
- src/Graphics/Caramia/Resource.hs +8/−13
- src/Graphics/Caramia/Shader.hs +5/−2
- src/Graphics/Caramia/Shader/Internal.hs +6/−1
- src/Graphics/Caramia/Sync.hs +1/−0
- src/Graphics/Caramia/Texture.hs +41/−17
- src/Graphics/Caramia/Texture/Internal.hs +3/−0
- src/Graphics/Caramia/VAO.hs +6/−1
- src/Graphics/Caramia/VAO/Internal.hs +1/−0
- tests/buffer/Main.hs +47/−0
- tests/texture/Main.hs +81/−0
README.md view
@@ -17,7 +17,8 @@ Here are the most important features of this library: - * Safe and automatic finalization of OpenGL resources+ * Safe and automatic finalization of OpenGL resources, with optional prompt+ finalization. * 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
caramia.cabal view
@@ -1,5 +1,5 @@ name: caramia-version: 0.7.1.1+version: 0.7.2.0 synopsis: High-level OpenGL bindings homepage: https://github.com/Noeda/caramia/ license: MIT@@ -10,6 +10,7 @@ category: Graphics build-type: Simple stability: experimental+bug-reports: https://github.com/Noeda/caramia/issues/ cabal-version: >=1.10 extra-source-files: README.md @@ -31,7 +32,8 @@ . Here are the most important features of this library: .- * Safe and automatic finalization of OpenGL resources+ * Safe and automatic finalization of OpenGL resources, with optional prompt+ finalization. . * 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@@ -133,6 +135,7 @@ ,exceptions >=0.6 && <1.0 ,lens >=4.6 && <5.0 ,linear >=1.15 && <2.0+ ,mtl >=2.1 && <3.0 ,semigroups >=0.15 && <1.0 ,text >=0.9 && <2.0 ,transformers >=0.3 && <1.0@@ -174,6 +177,21 @@ ,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 texture+ 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/texture+ 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+ ,transformers >=0.3 && <1.0 default-language: Haskell2010 test-suite color
src/Graphics/Caramia/Blend/Internal.hs view
@@ -1,14 +1,16 @@ {-# LANGUAGE RecordWildCards, NoImplicitPrelude, DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} module Graphics.Caramia.Blend.Internal where -import Graphics.Caramia.Prelude--import Graphics.Caramia.Internal.OpenGLCApi-import Graphics.Caramia.Color import Control.Monad.Catch import Control.Monad.IO.Class+import Data.Data ( Data ) import Foreign+import GHC.Generics ( Generic )+import Graphics.Caramia.Color+import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.Prelude -- | Describes which equation to use in blending. --@@ -19,7 +21,7 @@ | BEReverseSubtract | BEMin | BEMax- deriving ( Eq, Ord, Show, Read, Typeable, Enum )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic ) -- | Describes the arithmetic to use in blending. --@@ -40,7 +42,7 @@ | BFConstantAlpha | BFOneMinusConstantAlpha | BFSrcAlphaSaturate- deriving ( Eq, Ord, Show, Read, Typeable, Enum )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic ) toConstantBE :: BlendEquation -> GLenum toConstantBE BEAdd = GL_FUNC_ADD@@ -75,7 +77,7 @@ , dstColorFunc :: !BlendFunc , dstAlphaFunc :: !BlendFunc , blendColor :: !Color }- deriving ( Eq, Ord, Show, Read, Typeable )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic ) setBlendings :: MonadIO m => BlendSpec -> m () setBlendings (BlendSpec{..}) = do
src/Graphics/Caramia/Buffer.hs view
@@ -6,6 +6,7 @@ -- {-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-} module Graphics.Caramia.Buffer@@ -24,6 +25,8 @@ , defaultBufferCreation -- * Invalidation , invalidateBuffer+ -- * Explicit flushing+ , explicitFlush -- * Manipulation , bufferMap , bufferMap2@@ -45,9 +48,11 @@ import Data.Bits import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B+import Data.Data ( Data ) import qualified Data.Set as S import qualified Data.Vector.Storable as V import Foreign+import GHC.Generics import Graphics.Caramia.Buffer.Internal import Graphics.Caramia.Internal.OpenGLCApi import Graphics.Caramia.Prelude hiding ( map )@@ -66,7 +71,7 @@ Stream | Static | Dynamic- deriving ( Eq, Ord, Show, Read )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum ) -- | The nature of access to a buffer. --@@ -78,7 +83,7 @@ Draw | Read | Copy- deriving ( Eq, Ord, Show, Read )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum ) canMapWith :: AccessFlags -> AccessFlags -> Bool canMapWith ReadWriteAccess _ = True@@ -110,9 +115,12 @@ toConstantMF ss | S.null ss = 0 | otherwise =- if UnSynchronized `S.member` ss- then GL_MAP_UNSYNCHRONIZED_BIT- else 0+ flag GL_MAP_UNSYNCHRONIZED_BIT UnSynchronized .|.+ flag GL_MAP_FLUSH_EXPLICIT_BIT ExplicitFlush+ where+ flag bits hi = if hi `S.member` ss+ then bits+ else 0 -- | This data describes how a buffer should behave and what operations can be -- done with it.@@ -136,6 +144,7 @@ , accessFlags :: !AccessFlags -- ^ What kind of mapping access is -- allowed. See `map`. }+ deriving ( Eq, Ord, Show, Typeable, Data, Generic ) -- | The default buffer creation flags. --@@ -162,7 +171,7 @@ newResource createBuffer (\(Buffer_ bufname) -> mglDeleteBuffer bufname) (return ())- initial_status <- newIORef BufferStatus { mapped = False }+ initial_status <- newIORef BufferStatus { mapped = Nothing } oi <- newUnique return Buffer { resource = resource , status = initial_status@@ -279,11 +288,16 @@ (access_flags == ReadWriteAccess || access_flags == ReadAccess) = error "bufferMap2: cannot map for reading with unsynchronized flag."+ -- if explicitly flushing, writing must be allowed+ | S.member ExplicitFlush map_flags &&+ (access_flags /= WriteAccess &&+ access_flags /= ReadWriteAccess) =+ error "bufferMap: explicit flush mapping requires write access." | otherwise = liftIO $ withResource (resource buffer) $ \(Buffer_ buf) -> mask_ $ do bufstatus <- readIORef (status buffer) -- make sure buffer has not been already mapped- when (mapped bufstatus) $+ when (isJust $ mapped bufstatus) $ error "bufferMap2: buffer is already mapped." -- can we really map with these access flags unless (canMapWith (viewAllowedMappings buffer) access_flags) $@@ -306,7 +320,7 @@ "You might want to check OpenGL debug log." atomicModifyIORef' (status buffer) $ \old ->- ( old { mapped = True }, () )+ ( old { mapped = Just map_flags }, () ) return ptr @@ -348,13 +362,13 @@ bufferUnmap :: MonadIO m => Buffer -> m () bufferUnmap buffer = liftIO $ do bufstatus <- readIORef (status buffer)- when (mapped bufstatus) $+ when (isJust $ mapped bufstatus) $ withResource (resource buffer) $ \(Buffer_ buf) -> mask_ $ do result <- mglUnmapNamedBuffer buf when (result == GL_FALSE) $ throwM $ BufferCorruption buffer atomicModifyIORef' (status buffer) $ \old ->- ( old { mapped = False }, () )+ ( old { mapped = Nothing }, () ) -- | Same as `withMapping` but with map flags. --@@ -432,9 +446,9 @@ -- 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.+-- This is faster (when the required extensions are available) than mapping+-- both buffers and then doing a memcpy() style copying in system memory+-- because this call usually does not require a round-trip to the driver. -- -- You can use the same buffer for both destination and source but the copying -- area may not overlap.@@ -457,10 +471,10 @@ liftIO $ withResource (resource dst_buffer) $ \(Buffer_ dst) -> withResource (resource src_buffer) $ \(Buffer_ src) -> do dst_status <- readIORef (status dst_buffer)- when (mapped dst_status) $+ when (isJust $ mapped dst_status) $ error "copy: destination buffer is mapped." src_status <- readIORef (status src_buffer)- when (mapped src_status) $+ when (isJust $ mapped src_status) $ error "copy: source buffer is mapped." when (num_bytes > 0) $@@ -502,4 +516,30 @@ when gl_ARB_invalidate_subdata $ withResource (resource buf) $ \(Buffer_ name) -> glInvalidateBufferData name++-- | Explicitly flushes part of a buffer mapping.+--+-- The buffer must have been mapped with `ExplicitFlush` set. Furthermore,+-- either OpenGL 3.0 or \"GL_ARB_map_buffer_range\" is required; however this+-- function does nothing is neither of those are available.+explicitFlush :: MonadIO m+ => Buffer+ -> Int -- ^ Offset, in bytes, from start of the mapped+ -- region.+ -> Int -- ^ How many bytes to flush.+ -> m ()+explicitFlush buf offset size = liftIO $ do+ s <- readIORef (status buf)+ case mapped s of+ Just x | ExplicitFlush `S.notMember` x ->+ error $ "explicitFlush: buffer is not " <>+ "mapped with `ExplicitFlush` set."+ Nothing ->+ error "explicitFlush: buffer is not mapped."+ _ -> return ()++ withResource (resource buf) $ \(Buffer_ name) ->+ mglFlushMappedNamedBufferRange name+ (safeFromIntegral offset)+ (safeFromIntegral size)
src/Graphics/Caramia/Buffer/Internal.hs view
@@ -3,9 +3,13 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-} module Graphics.Caramia.Buffer.Internal where +import Data.Data+import qualified Data.Set as S+import GHC.Generics import Graphics.Caramia.Internal.OpenGLCApi import Graphics.Caramia.OpenGLResource import Graphics.Caramia.Prelude@@ -26,12 +30,13 @@ Buffer_ name <- getRaw (WrappedOpenGLResource $ resource buf) return name touch buf = touch (WrappedOpenGLResource $ resource buf)+ finalize buf = finalize (WrappedOpenGLResource $ resource buf) instance Ord Buffer where (ordIndex -> o1) `compare` (ordIndex -> o2) = o1 `compare` o2 data BufferStatus = BufferStatus- { mapped :: !Bool }+ { mapped :: !(Maybe (S.Set MapFlag)) } instance Show Buffer where show (Buffer{..}) = "<Buffer bytesize(" <> show viewSize <> ")>"@@ -48,7 +53,7 @@ | ReadWriteAccess -- ^ Both reading and writing can be done. | NoAccess -- ^ No access; you cannot map the buffer at all after -- creation.- deriving ( Eq, Ord, Show, Read, Typeable, Enum )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic ) -- | Additional mapping flags. data MapFlag =@@ -56,5 +61,16 @@ -- You will have to use synchronization primitives -- to make sure you and OpenGL won't be using -- the buffer at the same time.- deriving ( Eq, Ord, Show, Read, Typeable, Enum )+ | ExplicitFlush -- ^ If set, you need to explicitly flush ranges of+ -- the mapping after you have modified them, with+ -- `explicitFlush`. The mapping must allow writes.+ -- Requires OpenGL 3.0 or greater or+ -- \"GL_ARB_map_buffer_range\", but if neither of+ -- these are available, then this flag is no-op and+ -- so is `explicitFlush`.+ --+ -- Explicit flushing can be useful when you map a+ -- large buffer but don't know beforehand how much+ -- of that buffer you are going to modify.+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic )
src/Graphics/Caramia/Color.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-} module Graphics.Caramia.Color (@@ -29,6 +30,8 @@ where import Control.Lens+import Data.Data+import GHC.Generics import Graphics.Caramia.Prelude import Foreign.Storable import Linear.V4@@ -42,7 +45,8 @@ -- `Color`'s `Storable` instance is equal to `V4` `Float`'s -- `Storable` instance, in the order \"r g b a\". newtype Color = Color { toV4 :: (V4 Float) }- deriving ( Eq, Ord, Show, Read, Typeable, Storable )+ deriving ( Eq, Ord, Show, Read, Typeable, Storable+ , Data, Generic ) v4 :: Lens' Color (V4 Float) v4 = lens toV4 (\_ new -> Color new)
src/Graphics/Caramia/Framebuffer/Internal.hs view
@@ -2,13 +2,16 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-} module Graphics.Caramia.Framebuffer.Internal where import Control.Monad.IO.Class import Control.Monad.Catch+import Data.Data ( Data ) import Data.Unique import Foreign+import GHC.Generics import Graphics.Caramia.Internal.OpenGLCApi import Graphics.Caramia.OpenGLResource import Graphics.Caramia.Prelude@@ -33,11 +36,12 @@ Framebuffer_ name <- getRaw (WrappedOpenGLResource $ resource fbuf) return name touch fbuf = touch (WrappedOpenGLResource $ resource fbuf)+ finalize fbuf = finalize (WrappedOpenGLResource $ resource fbuf) data Attachment = ColorAttachment !Int | DepthAttachment | StencilAttachment- deriving ( Eq, Ord, Show, Read, Typeable )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic ) instance Eq Framebuffer where ScreenFramebuffer == ScreenFramebuffer = True@@ -56,6 +60,7 @@ data TextureTarget = TextureTarget { attacher :: GLuint -> IO () , texture :: Tex.Texture }+ deriving ( Typeable ) setBinding :: MonadIO m => Framebuffer -> m () setBinding ScreenFramebuffer = do
src/Graphics/Caramia/ImageFormats/Internal.hs view
@@ -4,15 +4,17 @@ -- {-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE DeriveGeneric #-} module Graphics.Caramia.ImageFormats.Internal where -import Graphics.Caramia.Prelude-+import Data.Data ( Data )+import Foreign.C.Types+import GHC.Generics import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.Prelude import Graphics.GL.Ext.EXT.TextureCompressionS3tc import Graphics.GL.Ext.EXT.TextureSRGB-import Foreign.C.Types -- | Given a format, returns `True` if that format can be rendered to. That is, -- if it can be one of the targets in a framebuffer.@@ -183,7 +185,7 @@ | DEPTH_COMPONENT16 | DEPTH32F_STENCIL8 | DEPTH24_STENCIL8- deriving ( Eq, Ord, Show, Read, Typeable, Enum )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic ) toConstantIF :: ImageFormat -> GLenum toConstantIF R8 = GL_R8@@ -264,7 +266,7 @@ | FInt32 | FFloat | FHalfFloat- deriving ( Eq, Ord, Show, Read, Typeable, Enum )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic ) toConstantST :: SpecificationType -> GLenum toConstantST FWord8 = GL_UNSIGNED_BYTE
src/Graphics/Caramia/Internal/OpenGLCApi.hs view
@@ -64,6 +64,7 @@ , mglMapNamedBufferRange , mglUnmapNamedBuffer , mglNamedCopyBufferSubData+ , mglFlushMappedNamedBufferRange ) where @@ -372,9 +373,17 @@ mglMapNamedBufferRange :: GLuint -> GLintptr -> GLsizeiptr -> GLbitfield -> IO (Ptr a) mglMapNamedBufferRange buffer offset length access = fmap castPtr $- withBoundBuffer buffer $- if | openGLVersion >= OpenGLVersion 3 0 ||- gl_ARB_map_buffer_range+ if gl_ARB_direct_state_access && we_have_map_buffer_range+ then dsaWay+ else nonDsaWay+ where+ dsaWay = glMapNamedBufferRange buffer+ offset+ (safeFromIntegral length)+ access++ nonDsaWay = withBoundBuffer buffer $+ if | we_have_map_buffer_range -> glMapBufferRange GL_ARRAY_BUFFER offset length access | otherwise -- it is time to be sneaky. We only have the plain glMapBuffer. We@@ -388,7 +397,10 @@ -- 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++ we_have_map_buffer_range = openGLVersion >= OpenGLVersion 3 0 ||+ gl_ARB_map_buffer_range+ oldwayflags = let can_read = access .&. GL_MAP_READ_BIT /= 0 can_write = access .&. GL_MAP_WRITE_BIT /= 0@@ -397,24 +409,47 @@ | can_write -> Just GL_WRITE_ONLY | otherwise -> Nothing +-- | This function is a no-op if the required extensions are not available.+mglFlushMappedNamedBufferRange :: GLuint -> GLintptr -> GLsizei -> IO ()+mglFlushMappedNamedBufferRange buffer offset length =+ if gl_ARB_direct_state_access && we_have_map_buffer_range+ then dsaWay+ else when we_have_map_buffer_range $ nonDsaWay+ where+ dsaWay = glFlushMappedNamedBufferRange buffer offset length + nonDsaWay = withBoundBuffer buffer $+ glFlushMappedBufferRange GL_ARRAY_BUFFER offset (fromIntegral length)++ we_have_map_buffer_range = openGLVersion >= OpenGLVersion 3 0 ||+ gl_ARB_map_buffer_range+ mglUnmapNamedBuffer :: GLuint -> IO GLboolean mglUnmapNamedBuffer buffer =- withBoundBuffer buffer $ glUnmapBuffer GL_ARRAY_BUFFER+ if gl_ARB_direct_state_access+ then glUnmapNamedBuffer buffer+ else withBoundBuffer buffer $ glUnmapBuffer GL_ARRAY_BUFFER mglNamedCopyBufferSubData :: GLuint -> GLuint -> GLintptr -> GLintptr -> GLsizeiptr -> IO () mglNamedCopyBufferSubData src dst src_offset dst_offset num_bytes =- withBoundElementBuffer src $- 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+ if gl_ARB_direct_state_access && gl_ARB_copy_buffer+ then dsaWay+ else nonDsaWay+ where+ dsaWay =+ glCopyNamedBufferSubData src dst src_offset dst_offset+ (safeFromIntegral num_bytes)++ nonDsaWay = withBoundElementBuffer src $ withBoundBuffer dst $+ 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/OpenGLResource.hs view
@@ -14,10 +14,15 @@ -- 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.+ -- | Returns the raw OpenGL type. getRaw :: MonadIO m => a -> m innertype - -- ^ Guarantees that the resource has not been garbage collected at the+ -- | Guarantees that the resource has not been garbage collected at the -- point this function is invoked. touch :: MonadIO m => a -> m ()++ -- | Promptly finalizes the resource.+ --+ -- This can be unsafe; see `Graphics.Caramia.Resource.finalizeNow`.+ finalize :: MonadIO m => a -> m ()
src/Graphics/Caramia/Query.hs view
@@ -15,6 +15,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} @@ -43,11 +44,13 @@ import Control.Monad.Catch import Control.Monad.IO.Class+import Data.Data ( Data ) import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Unique import Foreign.Marshal.Alloc import Foreign.Storable+import GHC.Generics ( Generic ) import Graphics.Caramia.Internal.ContextLocalData import Graphics.Caramia.Internal.Exception import Graphics.Caramia.Internal.OpenGLCApi@@ -64,14 +67,14 @@ | PrimitivesGenerated | TransformFeedbackPrimitivesWritten | TimeElapsed -- ^ Requires OpenGL 3.3 or @ GL_ARB_timer_query @.- deriving ( Eq, Ord, Show, Read, Typeable, Enum )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic ) -- | What of query to make? These queries return boolean results. data BooleanQueryType = 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 )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic ) -- | Which queries cannot be used together? illPairs :: M.Map SomeQuery (S.Set SomeQuery)@@ -95,6 +98,7 @@ Query_ name <- getRaw (WrappedOpenGLResource $ resource query) return name touch query = touch (WrappedOpenGLResource $ resource query)+ finalize query = finalize (WrappedOpenGLResource $ resource query) newtype Query_ = Query_ GLuint
src/Graphics/Caramia/Render.hs view
@@ -3,7 +3,13 @@ {-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-} {-# LANGUAGE ViewPatterns, NoImplicitPrelude, DeriveDataTypeable #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-}@@ -43,13 +49,18 @@ , Culling(..) ) where -import Control.Monad.Trans.Class-import Control.Monad.IO.Class import Control.Monad.Catch-import Control.Monad.Trans.State.Strict+import Control.Monad.Cont.Class+import Control.Monad.Error.Class+import Control.Monad.IO.Class+import Control.Monad.Reader.Class+import Control.Monad.RWS.Class+import Control.Monad.State.Strict hiding ( forM_, sequence_ )+import Data.Data ( Data ) import qualified Data.IntMap.Strict as IM import Foreign import Foreign.C.Types+import GHC.Generics import Graphics.Caramia.Blend import Graphics.Caramia.Blend.Internal import Graphics.Caramia.Buffer.Internal@@ -84,7 +95,7 @@ | LineStripAdjacency | TriangleStripAdjacency | TrianglesAdjacency- deriving ( Eq, Ord, Show, Read, Typeable, Enum )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic ) toConstant :: Primitive -> GLenum toConstant Triangles = GL_TRIANGLES@@ -104,7 +115,7 @@ IWord32 | IWord16 | IWord8- deriving ( Eq, Ord, Show, Read, Typeable, Enum )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic ) toConstantIT :: IndexType -> GLenum toConstantIT IWord32 = GL_UNSIGNED_INT@@ -312,28 +323,40 @@ { boundPipeline :: !Shader.Pipeline , boundEbo :: !GLuint , boundTextures :: !(IM.IntMap Texture)+ , restoreTextures :: !(IM.IntMap (DrawT IO ())) , boundBlending :: !BlendSpec , boundFramebuffer :: !FBuf.Framebuffer , boundFragmentPassTests :: !FragmentPassTests , boundPrimitiveRestart :: !(Maybe Word32) , activeTexture :: !GLuint }- deriving ( Eq, Ord, Typeable )+ deriving ( Typeable ) newtype DrawT m a = DrawT (StateT DrawState m a) deriving ( Monad, Applicative, Functor, Typeable ) +deriving instance MonadCont m => MonadCont (DrawT m)+deriving instance MonadError e m => MonadError e (DrawT m)+deriving instance MonadReader r m => MonadReader r (DrawT m)+deriving instance MonadRWS r w s m => MonadRWS r w s (DrawT m)+deriving instance MonadWriter w m => MonadWriter w (DrawT m)+ type Draw = DrawT IO -- | Using `liftIO` is safe inside a `DrawT` stream. It is possible to run -- nested `DrawT` streams this way as well.------ One useful thing to do is to set uniforms to pipelines with `setUniform`. instance MonadIO m => MonadIO (DrawT m) where liftIO = DrawT . liftIO instance MonadTrans DrawT where lift = DrawT . lift +-- State looks like it cannot be derived automatically...maybe the `StateT`+-- inside `DrawT` interferes with it? Whatever, let's just manually do it.+instance MonadState s m => MonadState s (DrawT m) where+ get = DrawT $ lift get+ put = DrawT . lift . put+ state = DrawT . lift . state+ -- | Use to hoist the base monad in a `DrawT`. hoistDrawT :: Monad n => (forall a. m a -> n a) -> DrawT m a -> DrawT n a hoistDrawT changer (DrawT action) = DrawT $ do@@ -359,18 +382,27 @@ runDraws params (DrawT cmd_stream) = withParams params $ do (result, st) <-- runStateT cmd_stream DrawState+ runStateT commands DrawState { boundPipeline = pipeline params , boundFragmentPassTests = fragmentPassTests params , boundEbo = 0 , boundBlending = blending params , boundFramebuffer = targetFramebuffer params- , boundTextures = bindTextures params+ , boundTextures = bind_textures+ , restoreTextures = fmap (const (return ())) bind_textures , boundPrimitiveRestart = primitiveRestart params , activeTexture = 0 } st `seq` return result+ where+ bind_textures = bindTextures params + commands = finally cmd_stream $ do+ st <- get+ sequence_ $ fmap (unwrapDrawT . hoistDrawT liftIO) $ restoreTextures st++ unwrapDrawT (DrawT ac) = ac+ withParams :: (MonadIO m, MonadMask m) => DrawParams -> m a -> m a withParams (DrawParams {..}) action = FBuf.withBinding targetFramebuffer $@@ -479,6 +511,8 @@ setTextureBindings texes = do state <- DrawT get let old_texes = boundTextures state+ old_restorations = restoreTextures state+ -- Iterate over the old bindings. forM_ (IM.assocs old_texes) $ \(index, tex) -> case IM.lookup index texes of@@ -505,21 +539,41 @@ Texture.getTopologyBindPoints $ topology $ viewSpecification new_tex in liftIO $ glBindTexture bind_target name+ -- Iterate over new bindings. We need to only check those that were not -- part of the old bindings.- forM_ (IM.assocs texes) $ \(index, tex) ->- case IM.lookup index old_texes of- Just _ -> return () -- already handled in the above forM_- Nothing -> do- name <- liftIO $ withResource (Texture.resource tex) $- \(Texture.Texture_ name) -> return name- setActiveTexture (safeFromIntegral index)- let (bind_target, _) =- Texture.getTopologyBindPoints $- topology $ viewSpecification tex- in liftIO $ glBindTexture bind_target name+ new_restorations <-+ flip execStateT old_restorations $+ forM_ (IM.assocs texes) $ \(index, tex) -> do+ -- Do we need to restore texture binding afterwards?+ restorations <- get+ case IM.lookup index restorations of+ Just _ -> return () -- nope, handled already+ Nothing -> do+ -- messily make sure that texture binding is restored when+ -- we return from runDrawT+ lift $ setActiveTexture (safeFromIntegral index)+ let (bind_point, bind_point_get) =+ Texture.getTopologyBindPoints $+ topology $ viewSpecification tex+ old_tex <- gi bind_point_get+ modify $ IM.insert index $ do+ setActiveTexture (safeFromIntegral index)+ glBindTexture bind_point old_tex - DrawT $ modify (\old -> old { boundTextures = texes })+ case IM.lookup index old_texes of+ Just _ -> return () -- already handled in the above forM_+ Nothing -> do+ name <- liftIO $ withResource (Texture.resource tex) $+ \(Texture.Texture_ name) -> return name+ lift $ setActiveTexture (safeFromIntegral index)+ let (bind_target, _) =+ Texture.getTopologyBindPoints $+ topology $ viewSpecification tex+ in liftIO $ glBindTexture bind_target name++ DrawT $ modify (\old -> old { boundTextures = texes+ , restoreTextures = new_restorations }) -- | Changes the pipeline in a `Draw` command stream. setPipeline :: MonadIO m => Shader.Pipeline -> DrawT m ()
src/Graphics/Caramia/Resource.hs view
@@ -23,6 +23,7 @@ ( Resource() , newResource , withResource+ , finalizeNow , WrappedOpenGLResource(..) ) where @@ -56,6 +57,9 @@ touch (WrappedOpenGLResource managed) = liftIO $ touchIORef (rawResource managed) + finalize (WrappedOpenGLResource managed) =+ liftIO $ finalizeNow managed+ instance Eq (Resource a) where res1 == res2 = rawResource res1 == rawResource res2 @@ -102,28 +106,19 @@ -- | Promptly finalize a resource. --+-- This is UNSAFE if you finalize a resource that is being referred to from+-- another resource that you will still use. Consequences will be unpredictable+-- (although you are unlikely to hit a hard crash).+-- -- The ordinary finalizer will be run immediately. The OpenGL finalizer will be -- run if the current thread is the same OpenGL thread where the resource was -- created. ----- If you want asynchronous finalization, then use `finalizeAsync`, which--- behaves more like actual garbage collection, only more promptly.------ I recommend you use `finalizeAsync` because it is more consistent with--- normal garbage collection behaviour and thus is more difficult to use--- incorrectly.--- -- If ordinary finalizer throws an exception, the OpenGL finalizer is not run -- and the resource is marked as finalized. The exception propagates out from -- this call to you. -- -- Does nothing if the resource is already finalized.------ ***********************--- TODO: this is not actually exported API. Some resources cannot be finalized--- like this because other resources might refer to them. How do we handle--- resources that can refer to each other? Right now, we cannot. So we can't--- allow users to finalize things by themselves. finalizeNow :: Resource a -> IO () finalizeNow resource = mask_ $ do maybe_res <- atomicModifyIORef (rawResource resource) $
src/Graphics/Caramia/Shader.hs view
@@ -20,6 +20,7 @@ {-# LANGUAGE NoImplicitPrelude, FlexibleInstances, DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification, ViewPatterns, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} module Graphics.Caramia.Shader (@@ -57,6 +58,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as BL+import Data.Data ( Data ) import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -64,6 +66,7 @@ import Foreign import Foreign.C.Types import GHC.Float ( double2Float )+import GHC.Generics ( Generic ) import Graphics.Caramia.Color import Graphics.Caramia.Context import Graphics.Caramia.Internal.OpenGLCApi@@ -98,14 +101,14 @@ -- -- Can also be caught as `ShaderBuildingError`. data ShaderCompilationError = ShaderCompilationError !T.Text- deriving ( Eq, Typeable, Show )+ deriving ( Eq, Typeable, Show, Data, Generic ) -- | Thrown when a shader linking error occurs. The text is the error log for -- linking. -- -- Can also be caught as `ShaderBuildingError`. data ShaderLinkingError = ShaderLinkingError !T.Text- deriving ( Eq, Typeable, Show )+ deriving ( Eq, Typeable, Show, Data, Generic ) instance Exception ShaderBuildingError
src/Graphics/Caramia/Shader/Internal.hs view
@@ -2,9 +2,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-} module Graphics.Caramia.Shader.Internal where +import Data.Data ( Data )+import GHC.Generics ( Generic ) import Graphics.Caramia.Internal.OpenGLCApi import Graphics.Caramia.OpenGLResource import Graphics.Caramia.Prelude@@ -26,6 +29,7 @@ CompiledShader name <- getRaw (WrappedOpenGLResource $ resource shader) return name touch shader = touch (WrappedOpenGLResource $ resource shader)+ finalize shader = finalize (WrappedOpenGLResource $ resource shader) instance Eq Shader where (resource -> res1) == (resource -> res2) = res1 == res2@@ -53,6 +57,7 @@ Pipeline_ name <- getRaw (WrappedOpenGLResource $ resourcePL program) return name touch program = touch (WrappedOpenGLResource $ resourcePL program)+ finalize program = finalize (WrappedOpenGLResource $ resourcePL program) instance Eq Pipeline where p1 == p2 = resourcePL p1 == resourcePL p2@@ -66,5 +71,5 @@ Vertex | Fragment | Geometry- deriving ( Eq, Ord, Show, Read )+ deriving ( Eq, Ord, Show, Read, Typeable, Enum, Data, Generic )
src/Graphics/Caramia/Sync.hs view
@@ -42,6 +42,7 @@ instance OpenGLResource GLsync Fence where getRaw (Fence r _) = getRaw $ WrappedOpenGLResource r touch (Fence r _) = touch $ WrappedOpenGLResource r+ finalize (Fence r _) = finalize $ WrappedOpenGLResource r instance Ord Fence where (ordIndex -> o1) `compare` (ordIndex -> o2) = o1 `compare` o2
src/Graphics/Caramia/Texture.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables, NoImplicitPrelude #-} {-# LANGUAGE MultiWayIf, ViewPatterns, DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} module Graphics.Caramia.Texture (@@ -46,26 +47,32 @@ , viewHeight , viewDepth , viewMipmapLevels+ , viewSize2D+ , viewSize3D -- * Utilities , maxMipmapLevels ) where -import Graphics.Caramia.Prelude -import Graphics.Caramia.Texture.Internal+import Control.Monad.IO.Class+import Control.Monad.Catch+import Data.Data ( Data )+import GHC.Generics+import qualified Graphics.Caramia.Buffer.Internal as Buf+import Graphics.Caramia.ImageFormats.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.Prelude import Graphics.Caramia.Resource+import Graphics.Caramia.Texture.Internal 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+import Graphics.GL.Ext.ARB.TextureMultisample+import Graphics.GL.Ext.ARB.TextureStorage import Foreign+import Linear.V2 ( V2(..) )+import Linear.V3 ( V3(..) ) textureSpecification :: TextureSpecification textureSpecification = TextureSpecification {@@ -90,6 +97,22 @@ -- TODO: you can actually infer that from the buffer size -- so implement it +-- | Returns the size of a texture, as a `V2`. Width and height.+--+-- @+-- viewSize2D tex = V2 (viewWidth tex) (viewHeight tex)+-- @+viewSize2D :: Texture -> V2 Int+viewSize2D tex = V2 (viewWidth tex) (viewHeight tex)++-- | Returns the size of a texture, as a `V3`. Width, height and depth.+--+-- @+-- viewSize3D tex = V3 (viewWidth tex) (viewHeight tex) (viewDepth tex)+-- @+viewSize3D :: Texture -> V3 Int+viewSize3D tex = V3 (viewWidth tex) (viewHeight tex) (viewDepth tex)+ -- | Returns the height of a texture. -- -- This is 1 for one-dimensional textures.@@ -135,9 +158,10 @@ -- Initially the contents of the texture are undefined. -- -- Texture dimensions must be positive.-newTexture :: TextureSpecification- -> IO Texture-newTexture spec = mask_ $ do+newTexture :: MonadIO m+ => TextureSpecification+ -> m Texture+newTexture spec = liftIO $ mask_ $ do topologySanityCheck (topology spec) when (not (isMultisamplingTopology (topology spec)) && mipmapLevels spec < 1) $@@ -371,7 +395,7 @@ | UBGRA | UDEPTH_COMPONENT -- ^ Depth values. | USTENCIL_INDEX -- ^ Stencil values.- deriving ( Eq, Ord, Show, Read, Typeable )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic ) -- TODO: add UDEPTH_STENCIL when `SpecificationType` has special interpretation -- formats.@@ -440,7 +464,7 @@ | NegativeX | PositiveZ | NegativeZ- deriving ( Eq, Ord, Show, Read, Typeable )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic ) toConstantCS :: CubeSide -> GLenum toConstantCS PositiveX = GL_TEXTURE_CUBE_MAP_POSITIVE_X@@ -662,17 +686,17 @@ | MiLinearMipmapNearest | MiNearestMipmapLinear | MiLinearMipmapLinear- deriving ( Eq, Ord, Show, Read, Typeable )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum ) data MagFilter = MaNearest | MaLinear- deriving ( Eq, Ord, Show, Read, Typeable )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum ) data Wrapping = Clamp | Repeat- deriving ( Eq, Ord, Show, Read, Typeable )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum ) -- | Texture comparison modes. --@@ -680,7 +704,7 @@ data CompareMode = NoCompare | CompareRefToTexture- deriving ( Eq, Ord, Show, Read, Typeable )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Enum ) toConstantC :: CompareMode -> GLenum toConstantC NoCompare = GL_NONE
src/Graphics/Caramia/Texture/Internal.hs view
@@ -21,11 +21,14 @@ , viewSpecification :: !TextureSpecification } deriving ( Typeable ) +-- | If you use `finalize`, be careful of any resource that might refer to the+-- texture. instance OpenGLResource GLuint Texture where getRaw tex = do Texture_ name <- getRaw (WrappedOpenGLResource $ resource tex) return name touch tex = touch (WrappedOpenGLResource $ resource tex)+ finalize tex = finalize (WrappedOpenGLResource $ resource tex) newtype Texture_ = Texture_ GLuint
src/Graphics/Caramia/VAO.hs view
@@ -9,7 +9,9 @@ -- use operations from this module. -- +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} module Graphics.Caramia.VAO ( -- * Creation@@ -28,7 +30,9 @@ import Control.Monad.IO.Class import Control.Monad.Catch+import Data.Data ( Data ) import Data.Unique+import GHC.Generics ( Generic ) import qualified Graphics.Caramia.Buffer.Internal as Buf import Graphics.Caramia.Internal.Exception import Graphics.Caramia.Internal.OpenGLCApi@@ -71,7 +75,7 @@ | SHalfFloat -- ^ 16-bit floating point value. | SFloat | SDouble- deriving ( Eq, Ord, Show, Read )+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic ) -- | This returns the size of a `SourceType`, in bytes. sourceTypeSize :: SourceType -> Int@@ -185,6 +189,7 @@ -- ^ The data type of values in the buffer. It tells the type of a single -- component. }+ deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic ) -- | The default sourcing. --
src/Graphics/Caramia/VAO/Internal.hs view
@@ -32,4 +32,5 @@ VAO_ name <- getRaw (WrappedOpenGLResource $ resource vao) return name touch vao = touch (WrappedOpenGLResource $ resource vao)+ finalize vao = finalize (WrappedOpenGLResource $ resource vao)
tests/buffer/Main.hs view
@@ -58,7 +58,54 @@ , testCase "Mapping with offset works" offsetMappingTest , testCase "Mapping with unsynchronized flag set doesn't crash" unsyncTest , testCase "Buffer copying works" copyBuffersTest+ , testCase "Explicit flushing tentatively works" explicitFlushTest+ , testCase ("I cannot invoke `explicitFlush` on a mapping without " <>+ "`ExplicitFlush` flag.") incorrectExplicitFlushTest+ , testCase "I cannot map with `ExplicitFlush` and no writing access."+ noWriteExplicitFlushTest+ , testCase "I cannot invoke `explicitFlush` without a mapping."+ explicitFlushNoMapTest ]++explicitFlushNoMapTest :: IO ()+explicitFlushNoMapTest = setup $ do+ buf <- newBufferFromList (take 10000 $ repeat (12 :: Word8))+ (\old -> old { accessFlags = ReadWriteAccess })+ expectException $ explicitFlush buf 10 10++noWriteExplicitFlushTest :: IO ()+noWriteExplicitFlushTest = setup $ do+ buf <- newBufferFromList (take 10000 $ repeat (12 :: Word8))+ (\old -> old { accessFlags = ReadWriteAccess })+ expectException $ withMapping2 (S.singleton ExplicitFlush)+ 100 100 ReadAccess buf $ const $ return ()+ expectException $ withMapping2 (S.singleton ExplicitFlush)+ 100 100 NoAccess buf $ const $ return ()++incorrectExplicitFlushTest :: IO ()+incorrectExplicitFlushTest = setup $ do+ buf <- newBufferFromList (take 10000 $ repeat (12 :: Word8))+ (\old -> old { accessFlags = ReadWriteAccess })+ withMapping 100 100 WriteAccess buf $ \_ -> do+ expectException $ explicitFlush buf 10 10+++explicitFlushTest :: IO ()+explicitFlushTest = setup $ do+ buf <- newBufferFromList (take 10000 $ repeat (12 :: Word8))+ (\old -> old { accessFlags = ReadWriteAccess })+ withMapping2 (S.singleton ExplicitFlush) 7800 1000 WriteAccess buf $ \ptr -> do+ pokeElemOff (ptr :: Ptr Word8) 10 8+ pokeElemOff (ptr :: Ptr Word8) 11 9+ pokeElemOff (ptr :: Ptr Word8) 12 10+ explicitFlush buf 8 3+ withMapping 7800 100 ReadAccess buf $ \ptr -> do+ let assM x y = do z <- peekElemOff (ptr :: Ptr Word8) x+ assertEqual "explicitly flushed bytes are the same"+ y z+ assM 10 8+ assM 11 9+ assM 12 10 copyBuffersTest :: IO () copyBuffersTest = setup $ do
+ tests/texture/Main.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Main ( main ) where++import Control.Concurrent+import Control.Exception+import Control.Monad.IO.Class ( liftIO )+import qualified Data.IntMap.Strict as IM+import Linear.V2+import Graphics.Caramia+import Graphics.Caramia.Internal.OpenGLCApi+import Graphics.Caramia.Prelude+import SDL+import System.IO.Unsafe ( unsafePerformIO )+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit hiding ( Test )++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 "texture" 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 "Texture bindings don't linger in rendering (ex-bug)"+ textureLingerTest+ ]++textureLingerTest :: IO ()+textureLingerTest = setup $ do+ nop <- nopPipeline+ tex <- newTexture textureSpecification { topology = Tex2D 32 32+ , imageFormat = R8 }+ runDraws defaultDrawParams { pipeline = nop } $ do+ glActiveTexture GL_TEXTURE0+ b <- gi GL_TEXTURE_BINDING_2D+ liftIO $ assertEqual "texture is not absurd at texture unit 0" 0 b+ glActiveTexture GL_TEXTURE1+ b <- gi GL_TEXTURE_BINDING_2D+ liftIO $ assertEqual "texture is not absurd at texture unit 0" 0 b+ glActiveTexture GL_TEXTURE0++ setTextureBindings $ IM.fromList [(0, tex), (1, tex)]++ glActiveTexture GL_TEXTURE0+ b <- gi GL_TEXTURE_BINDING_2D+ liftIO $ assertBool "texture is set correctly in texture unit 0" (0 /= b)+ glActiveTexture GL_TEXTURE1+ b <- gi GL_TEXTURE_BINDING_2D+ liftIO $ assertBool "texture is set correctly in texture unit 1" (0 /= b)+ glActiveTexture GL_TEXTURE0++ glActiveTexture GL_TEXTURE0+ b <- gi GL_TEXTURE_BINDING_2D+ assertEqual "texture is not lingering at texture unit 0" 0 b++ glActiveTexture GL_TEXTURE1+ c <- gi GL_TEXTURE_BINDING_2D+ assertEqual "texture is not lingering at texture unit 1" 0 c+