luminance 0.6.0.5 → 0.7
raw patch · 27 files changed
+1365/−608 lines, 27 files
Files
- CHANGELOG.md +23/−0
- luminance.cabal +25/−3
- src/Graphics/Luminance/Core/Batch.hs +9/−9
- src/Graphics/Luminance/Core/Buffer.hs +93/−8
- src/Graphics/Luminance/Core/Cubemap.hs +40/−12
- src/Graphics/Luminance/Core/CubemapArray.hs +27/−14
- src/Graphics/Luminance/Core/Debug.hs +7/−5
- src/Graphics/Luminance/Core/Framebuffer.hs +71/−8
- src/Graphics/Luminance/Core/Geometry.hs +36/−0
- src/Graphics/Luminance/Core/RenderCmd.hs +1/−1
- src/Graphics/Luminance/Core/Renderbuffer.hs +16/−2
- src/Graphics/Luminance/Core/Shader/Program.hs +743/−44
- src/Graphics/Luminance/Core/Shader/Stage.hs +57/−32
- src/Graphics/Luminance/Core/Shader/Uniform.hs +0/−383
- src/Graphics/Luminance/Core/Shader/UniformBlock.hs +5/−22
- src/Graphics/Luminance/Core/Texture.hs +64/−24
- src/Graphics/Luminance/Core/Texture1D.hs +23/−1
- src/Graphics/Luminance/Core/Texture1DArray.hs +24/−1
- src/Graphics/Luminance/Core/Texture2D.hs +28/−4
- src/Graphics/Luminance/Core/Texture2DArray.hs +24/−1
- src/Graphics/Luminance/Core/Texture3D.hs +24/−1
- src/Graphics/Luminance/Core/Vertex.hs +14/−0
- src/Graphics/Luminance/Shader.hs +0/−2
- src/Graphics/Luminance/Shader/Program.hs +7/−0
- src/Graphics/Luminance/Shader/Stage.hs +2/−6
- src/Graphics/Luminance/Shader/Uniform.hs +0/−21
- src/Graphics/Luminance/Texture.hs +2/−4
CHANGELOG.md view
@@ -1,3 +1,26 @@+# 0.7++#### Breaking changes++- Shader creation can fail with the `UnsupportedStage` error, holding the stage (and not a `String`)+ as it used to.+- Fixed cubemap size interface.+- Shader interface now uses the type `StageType` and `createStage` to create new shader stages.++#### Minor changes++- Several internal architectural changes.+- Added `gl45-bindless-textures` caps.+- Added `gl32` and `gl45` backends. The default backend is `gl32` and backends can be selected via+ compilation flags.++#### Patch changes++- Simplified and fixed UBO implementation.+- Added more debug symbols.+- OpenGL debugging now shows the callstack in a fancy way.+- Several internal architectural changes.+ ### 0.6.0.5 - semigroups-0.18 support.
luminance.cabal view
@@ -1,5 +1,5 @@ name: luminance-version: 0.6.0.5+version: 0.7 synopsis: Type-safe, type-level and stateless graphics framework description: This package exposes several modules to work with /GPUs/ in a stateless and type-safe way. Currently, it uses OpenGL as backend hardware technology but@@ -46,12 +46,36 @@ default: False manual: True +flag gl45+ description: Compile with the OpenGL 4.5 backend+ default: False+ manual: True++flag gl45-bindless-textures+ description: Compile with the OpenGL 4.5 + bindless textures backend+ default: False+ manual: True++flag gl32+ description: Compile with the OpenGL 3.2 backend+ default: True+ manual: True+ library ghc-options: -W -Wall if flag(debug-gl) cpp-options: -DDEBUG_GL + if flag(gl45)+ cpp-options: -D__GL45++ if flag(gl45-bindless-textures)+ cpp-options: -D__GL45 -D__GL_BINDLESS_TEXTURES++ if flag(gl32)+ cpp-options: -D__GL32+ exposed-modules: Graphics.Luminance , Graphics.Luminance.Batch , Graphics.Luminance.Blending@@ -67,7 +91,6 @@ , Graphics.Luminance.Shader , Graphics.Luminance.Shader.Program , Graphics.Luminance.Shader.Stage- , Graphics.Luminance.Shader.Uniform , Graphics.Luminance.Texture , Graphics.Luminance.Vertex @@ -87,7 +110,6 @@ , Graphics.Luminance.Core.RW , Graphics.Luminance.Core.Shader.Program , Graphics.Luminance.Core.Shader.Stage- , Graphics.Luminance.Core.Shader.Uniform , Graphics.Luminance.Core.Shader.UniformBlock , Graphics.Luminance.Core.Texture , Graphics.Luminance.Core.Texture1D
src/Graphics/Luminance/Core/Batch.hs view
@@ -18,11 +18,11 @@ import Foreign.Ptr ( nullPtr ) import Graphics.GL import Graphics.Luminance.Core.Blending ( setBlending )+import Graphics.Luminance.Core.Debug import Graphics.Luminance.Core.Framebuffer ( Framebuffer(..) ) import Graphics.Luminance.Core.Geometry ( Geometry(..), VertexArray(..) )-import Graphics.Luminance.Core.Shader.Program ( Program(..) )+import Graphics.Luminance.Core.Shader.Program ( Program(..), U(..) ) import Graphics.Luminance.Core.RenderCmd ( RenderCmd(..) )-import Graphics.Luminance.Core.Shader.Uniform ( U(..) ) -------------------------------------------------------------------------------- -- Framebuffer batch -----------------------------------------------------------@@ -39,8 +39,8 @@ -- |Run a 'FBBatch'. runFBBatch :: (MonadIO m) => FBBatch rw c d -> m () runFBBatch (FBBatch fb spbs) = do- liftIO $ glBindFramebuffer GL_DRAW_FRAMEBUFFER (fromIntegral $ framebufferID fb)- liftIO $ glClear $ GL_DEPTH_BUFFER_BIT .|. GL_COLOR_BUFFER_BIT+ liftIO . debugGL $ glBindFramebuffer GL_DRAW_FRAMEBUFFER (fromIntegral $ framebufferID fb)+ liftIO . debugGL $ glClear $ GL_DEPTH_BUFFER_BIT .|. GL_COLOR_BUFFER_BIT traverse_ (\(AnySPBatch spb) -> runSPBatch spb) spbs -- |Share a 'Framebuffer' between several shader program batches.@@ -79,7 +79,7 @@ runSPBatch :: (MonadIO m) => SPBatch rw c d u v -> m () runSPBatch (SPBatch prog uni u geometries) = do liftIO $ do- glUseProgram (programID prog)+ debugGL $ glUseProgram (programID prog) runU uni u traverse_ drawGeometry geometries @@ -102,8 +102,8 @@ liftIO (runU uni u) case geometry of DirectGeometry (VertexArray vid mode vbNb) -> do- glBindVertexArray vid- glDrawArrays mode 0 vbNb+ debugGL $ glBindVertexArray vid+ debugGL $ glDrawArrays mode 0 vbNb IndexedGeometry (VertexArray vid mode ixNb) -> do- glBindVertexArray vid- glDrawElements mode ixNb GL_UNSIGNED_INT nullPtr+ debugGL $ glBindVertexArray vid+ debugGL $ glDrawElements mode ixNb GL_UNSIGNED_INT nullPtr
src/Graphics/Luminance/Core/Buffer.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -18,11 +19,15 @@ import Control.Monad.Trans.Resource ( MonadResource, register ) import Data.Bits ( (.|.) ) import Data.Foldable ( toList )+import Data.Proxy ( Proxy(..) ) import Data.Word ( Word32 ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Array ( peekArray, pokeArray ) import Foreign.Marshal.Utils ( with )-import Foreign.Ptr ( Ptr, castPtr, nullPtr, plusPtr )+import Foreign.Ptr ( Ptr, castPtr, nullPtr )+#ifdef __GL45+import Foreign.Ptr ( plusPtr )+#endif import Foreign.Storable ( Storable(..) ) import Graphics.GL import Graphics.Luminance.Core.RW@@ -37,6 +42,7 @@ => GLbitfield -> Int -> m (Buffer,Ptr ())+#ifdef __GL45 mkBuffer flags size = do (bid,mapped) <- liftIO . alloca $ \p -> do glCreateBuffers 1 p@@ -45,15 +51,34 @@ pure (bid,mapped) _ <- register . with bid $ glDeleteBuffers 1 pure (Buffer bid,mapped)+#elif defined(__GL32)+mkBuffer flags size = do+ (bid,mapped) <- liftIO . alloca $ \p -> do+ glGenBuffers 1 p+ bid <- peek p+ mapped <- createStorage bid flags size+ pure (bid,mapped)+ _ <- register . with bid $ glDeleteBuffers 1+ pure (Buffer bid,mapped)+#endif -- Create the required OpenGL storage for a 'Buffer'. createStorage :: GLuint -> GLbitfield -> Int -> IO (Ptr ())+#ifdef __GL45 createStorage bid flags size = do glNamedBufferStorage bid bytes nullPtr flags- ptr <- glMapNamedBufferRange bid 0 (fromIntegral size) flags+ ptr <- glMapNamedBufferRange bid 0 bytes flags pure ptr where bytes = fromIntegral size+#elif defined(__GL32)+createStorage bid _ size = do+ glBindBuffer GL_ARRAY_BUFFER bid+ glBufferData GL_ARRAY_BUFFER bytes nullPtr GL_STREAM_DRAW+ pure nullPtr+ where+ bytes = fromIntegral size+#endif -- |Create a new 'Buffer' using regions through the 'BuildRegion' monadic type. The 'Buffer' is -- returned as well as the computed 'a' value in the 'BuildRegion'.@@ -73,7 +98,7 @@ -- |'Buffer'’s 'Region's can have reads and writes. That typeclass makes implements all possible -- cases. class BufferRW rw where- bufferFlagsFromRW :: rw -> GLenum+ bufferFlagsFromRW :: proxy rw -> GLenum instance BufferRW R where bufferFlagsFromRW _ = GL_MAP_READ_BIT@@ -89,22 +114,39 @@ createBuffer :: forall a m rw. (BufferRW rw,MonadIO m,MonadResource m) => BuildRegion rw a -> m a-createBuffer = fmap fst . mkBufferWithRegions (bufferFlagsFromRW (undefined :: rw) .|. GL_MAP_PERSISTENT_BIT .|. GL_MAP_COHERENT_BIT)+createBuffer = fmap fst . mkBufferWithRegions (bufferFlagsFromRW (Proxy :: Proxy rw) .|. persistentCoherentBits) -- Special case of 'createBuffer', returning the 'Buffer' in addition for internal uses. createBuffer_ :: forall a m rw. (BufferRW rw,MonadIO m,MonadResource m) => BuildRegion rw a -> m (a,Buffer) createBuffer_ = mkBufferWithRegions $- bufferFlagsFromRW (undefined :: rw) .|. GL_MAP_PERSISTENT_BIT .|. GL_MAP_COHERENT_BIT+ bufferFlagsFromRW (Proxy :: Proxy rw) .|. persistentCoherentBits +persistentCoherentBits :: GLbitfield+#ifdef __GL45+persistentCoherentBits = GL_MAP_PERSISTENT_BIT .|. GL_MAP_COHERENT_BIT+#elif defined(__GL32)+persistentCoherentBits = 0+#endif+ -- |A 'Region' is a GPU typed memory area. It can be pictured as a GPU array.+#ifdef __GL45 data Region rw a = Region { regionPtr :: Ptr a -- mapped pointer (into GPU memory) , regionOffset :: Int , regionSize :: Int -- number of elements living in that region , regionBuffer :: Buffer -- buffer the region lays in } deriving (Eq,Show)+#elif defined(__GL32)+-- OpenGL 3.2 doesn’t have any support for persistent/coherent buffers, so we don’t need to store+-- the pointer, as we will ask for it each time we want to do something with the buffer.+data Region rw a = Region {+ regionOffset :: Int+ , regionSize :: Int -- number of elements living in that region+ , regionBuffer :: Buffer -- buffer the region lays in+ } deriving (Eq,Show)+#endif -- |Convenient type to build 'Region's. newtype BuildRegion rw a = BuildRegion {@@ -116,6 +158,7 @@ newRegion size = BuildRegion $ do offset <- get put $ offset + fromIntegral size * sizeOf (undefined :: a)+#ifdef __GL45 (buffer,ptr) <- ask pure $ Region { regionPtr = (castPtr $ ptr `plusPtr` fromIntegral offset)@@ -123,10 +166,27 @@ , regionSize = fromIntegral size , regionBuffer = buffer }+#elif defined(__GL32)+ (buffer,_) <- ask+ pure $ Region {+ regionOffset = offset+ , regionSize = fromIntegral size+ , regionBuffer = buffer+ }+#endif -- |Read a whole 'Region'. readWhole :: (MonadIO m,Readable r,Storable a) => Region r a -> m [a]+#ifdef __GL45 readWhole r = liftIO $ peekArray (regionSize r) (regionPtr r)+#elif defined(__GL32)+readWhole r = liftIO $ do+ glBindBuffer GL_ARRAY_BUFFER (bufferID $ regionBuffer r)+ p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ regionOffset r) (fromIntegral $ regionSize r) GL_MAP_READ_BIT+ a <- peekArray (regionSize r) (castPtr p)+ _ <- glUnmapBuffer GL_ARRAY_BUFFER+ pure a+#endif -- |Write the whole 'Region'. If value are missing, only the provided values will replace the -- existing ones. If there are more values than the size of the 'Region', they are ignored.@@ -134,28 +194,53 @@ => Region w a -> f a -> m ()+#ifdef __GL45 writeWhole r values = liftIO . pokeArray (regionPtr r) . take (regionSize r) $ toList values+#elif defined(__GL32)+writeWhole r values = liftIO $ do+ glBindBuffer GL_ARRAY_BUFFER (bufferID $ regionBuffer r)+ p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ regionOffset r) (fromIntegral $ regionSize r) GL_MAP_WRITE_BIT+ pokeArray (castPtr p) . take (regionSize r) $ toList values+ () <$ glUnmapBuffer GL_ARRAY_BUFFER+#endif -- |Fill a 'Region' with a value. fill :: (MonadIO m,Storable a,Writable w) => Region w a -> a -> m ()-fill r a = liftIO . pokeArray (regionPtr r) $ replicate (regionSize r) a+fill r a = writeWhole r (replicate (regionSize r) a) -- |Index getter. Bounds checking is performed and returns 'Nothing' if out of bounds. (@?) :: (MonadIO m,Storable a,Readable r) => Region r a -> Word32 -> m (Maybe a) r @? i | i >= fromIntegral (regionSize r) = pure Nothing- | otherwise = liftIO $ Just <$> peekElemOff (regionPtr r) (fromIntegral i)+ | otherwise = fmap Just (r @! i) -- |Index getter. Unsafe version of '(@?)'. (@!) :: (MonadIO m,Storable a,Readable r) => Region r a -> Word32 -> m a+#ifdef __GL45 r @! i = liftIO $ peekElemOff (regionPtr r) (fromIntegral i)+#elif defined(__GL32)+r @! i = liftIO $ do+ glBindBuffer GL_ARRAY_BUFFER (bufferID $ regionBuffer r)+ p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ regionOffset r) (fromIntegral $ regionSize r) GL_MAP_READ_BIT+ a <- peekElemOff (castPtr p) (fromIntegral i)+ _ <- glUnmapBuffer GL_ARRAY_BUFFER+ pure a+#endif -- |Index setter. Bounds checking is performed and nothing is done if out of bounds. writeAt :: (MonadIO m,Storable a,Writable w) => Region w a -> Word32 -> a -> m () writeAt r i a | i >= fromIntegral (regionSize r) = pure ()- | otherwise = liftIO $ pokeElemOff (regionPtr r) (fromIntegral i) a+ | otherwise = writeAt' r i a -- |Index setter. Unsafe version of 'writeAt''. writeAt' :: (MonadIO m,Storable a,Writable w) => Region w a -> Word32 -> a -> m ()+#ifdef __GL45 writeAt' r i a = liftIO $ pokeElemOff (regionPtr r) (fromIntegral i) a+#elif defined(__GL32)+writeAt' r i a = liftIO $ do+ glBindBuffer GL_ARRAY_BUFFER (bufferID $ regionBuffer r)+ p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ regionOffset r) (fromIntegral $ regionSize r) GL_MAP_WRITE_BIT+ pokeElemOff (castPtr p) (fromIntegral i) a+ () <$ glUnmapBuffer GL_ARRAY_BUFFER+#endif
src/Graphics/Luminance/Core/Cubemap.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -14,8 +15,14 @@ module Graphics.Luminance.Core.Cubemap where import Data.Proxy ( Proxy(..) )+#ifdef __GL32+import Data.Foldable ( for_ )+#endif import Data.Vector.Storable ( unsafeWith ) import Foreign.Ptr ( castPtr )+#ifdef __GL32+import Foreign.Ptr ( nullPtr )+#endif import Graphics.Luminance.Core.Texture ( BaseTexture(..), Texture(..) ) import Graphics.Luminance.Core.Pixel ( Pixel(..) ) import Graphics.GL@@ -43,33 +50,54 @@ -- |A cubemap. data Cubemap f = Cubemap { cubemapBase :: BaseTexture- , cubemapW :: Natural- , cubemapH :: Natural+ , cubemapSize :: Natural } deriving (Eq,Show) instance (Pixel f) => Texture (Cubemap f) where- type TextureSize (Cubemap f) = (Natural,Natural)+ type TextureSize (Cubemap f) = Natural type TextureOffset (Cubemap f) = (Natural,Natural,CubeFace)- fromBaseTexture bt (w,h) = Cubemap bt w h+ fromBaseTexture = Cubemap toBaseTexture = cubemapBase textureTypeEnum _ = GL_TEXTURE_CUBE_MAP- textureSize (Cubemap _ w h) = (w,h)- textureStorage _ tid levels (w,h) =- glTextureStorage2D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral w)- (fromIntegral h)- transferTexelsSub _ tid (x,y,f) (w,h) texels =+ textureSize (Cubemap _ s) = s+#ifdef __GL45+ textureStorage _ tid levels s =+ glTextureStorage2D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral s)+ (fromIntegral s)+#elif defined(__GL32)+ textureStorage _ _ levels s = do+ for_ [0..levels-1] $ \lvl -> do+ let divisor = 2 ^ lvl+ glTexImage2D GL_TEXTURE_CUBE_MAP lvl (fromIntegral $ pixelIFormat pf)+ (fromIntegral s `div` divisor) (fromIntegral s `div` divisor) 0 (pixelFormat pf)+ (pixelType pf) nullPtr+ where pf = Proxy :: Proxy f+#endif+#ifdef __GL45+ transferTexelsSub _ tid (x,y,f) s texels = unsafeWith texels $ glTextureSubImage3D tid 0 (fromIntegral x) (fromIntegral y)- (fromCubeFace f) (fromIntegral w) (fromIntegral h) 1 fmt+ (fromCubeFace f) (fromIntegral s) (fromIntegral s) 1 fmt typ . castPtr+#elif defined(__GL32)+ transferTexelsSub _ tid (x,y,f) s texels = do+ glBindTexture GL_TEXTURE_CUBE_MAP tid+ unsafeWith texels $ glTexSubImage3D GL_TEXTURE_CUBE_MAP 0 (fromIntegral x) (fromIntegral y)+ (fromCubeFace f) (fromIntegral s) (fromIntegral s) 1 fmt+ typ . castPtr+#endif where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy- fillTextureSub _ tid (x,y,f) (w,h) filling =+#ifdef __GL45+ fillTextureSub _ tid (x,y,f) s filling = unsafeWith filling $ glClearTexSubImage tid 0 (fromIntegral x) (fromIntegral y) - (fromCubeFace f) (fromIntegral w) (fromIntegral h) 1+ (fromCubeFace f) (fromIntegral s) (fromIntegral s) 1 fmt typ . castPtr where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#elif defined(__GL32)+ fillTextureSub p tid o w filling = transferTexelsSub p tid o w filling+#endif
src/Graphics/Luminance/Core/CubemapArray.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -15,9 +16,10 @@ module Graphics.Luminance.Core.CubemapArray where +import Data.Foldable ( for_ ) import Data.Proxy ( Proxy(..) )-import Data.Vector.Storable ( unsafeWith )-import Foreign.Ptr ( castPtr )+import Data.Vector.Storable as V ( concat, unsafeWith )+import Foreign.Ptr ( castPtr, nullPtr ) import GHC.TypeLits ( KnownNat, Nat, natVal ) import Graphics.Luminance.Core.Cubemap ( CubeFace, fromCubeFace ) import Graphics.Luminance.Core.Texture ( BaseTexture(..), Texture(..) )@@ -28,35 +30,46 @@ -- |A cubemap array. data CubemapArray (n :: Nat) (f :: *) = CubemapArray { cubemapArrayBase :: BaseTexture- , cubemapArrayW :: Natural- , cubemapArrayH :: Natural+ , cubemapArraySize :: Natural } deriving (Eq,Show) instance (KnownNat n, Pixel f) => Texture (CubemapArray n f) where -- |(w,h)- type TextureSize (CubemapArray n f) = (Natural,Natural)+ type TextureSize (CubemapArray n f) = Natural -- |(layer,x,y,face) type TextureOffset (CubemapArray n f) = (Natural,Natural,Natural,CubeFace)- fromBaseTexture bt (w,h) = CubemapArray bt w h+ fromBaseTexture bt s = CubemapArray bt s toBaseTexture = cubemapArrayBase textureTypeEnum _ = GL_TEXTURE_CUBE_MAP_ARRAY- textureSize (CubemapArray _ w h) = (w,h)- textureStorage _ tid levels (w,h) =- glTextureStorage3D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral w)- (fromIntegral h) (fromIntegral $ natVal (Proxy :: Proxy n))- transferTexelsSub _ tid (layer,x,y,f) (w,h) texels =+ textureSize (CubemapArray _ s) = s+#ifdef __GL45+ textureStorage _ tid levels s =+ glTextureStorage3D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral s)+ (fromIntegral s) (fromIntegral $ natVal (Proxy :: Proxy n))+#elif defined(__GL32)+ textureStorage _ _ _ _ = pure ()+#endif+#ifdef __GL45+ transferTexelsSub _ tid (layer,x,y,f) s texels = unsafeWith texels $ glTextureSubImage3D tid 0 (fromIntegral x) (fromIntegral y)- (fromCubeFace f + fromIntegral layer*6) (fromIntegral w) (fromIntegral h) 1 fmt+ (fromCubeFace f + fromIntegral layer*6) (fromIntegral s) (fromIntegral s) 1 fmt typ . castPtr where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy- fillTextureSub _ tid (layer,x,y,f) (w,h) filling =+#elif defined(__GL32)+ transferTexelsSub _ _ _ _ _ = pure ()+#endif+#ifdef __GL45+ fillTextureSub _ tid (layer,x,y,f) s filling = unsafeWith filling $ glClearTexSubImage tid 0 (fromIntegral x) (fromIntegral y) - (fromCubeFace f + fromIntegral layer*6) (fromIntegral w) (fromIntegral h) 1+ (fromCubeFace f + fromIntegral layer*6) (fromIntegral s) (fromIntegral s) 1 fmt typ . castPtr where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#elif defined(__GL32)+ fillTextureSub _ _ _ _ _ = pure ()+#endif
src/Graphics/Luminance/Core/Debug.hs view
@@ -17,6 +17,7 @@ #if DEBUG_GL import Data.Foldable ( traverse_ ) #endif+import GHC.Stack ( currentCallStack, renderStack ) import Graphics.GL --------------------------------------------------------------------------------@@ -65,17 +66,18 @@ -- |Given a context 'String' and an action, that function clears the OpenGL errors in order to run -- the action in a sane and error-free OpenGL context. If an error has occured, print it on 'stderr'--- along with the 'String' context. Otherwise, simply it returns the action’s result.+-- along with the callstack. Otherwise, it returns the action’s result. -- -- Keep in mind that you can mute that function’s implementation by disabling the cabal flag -- 'debug-gl', which is the default setting.-debugGL :: (MonadIO m) => String -> m a -> m a+debugGL :: (MonadIO m) => m a -> m a #if DEBUG_GL-debugGL ctx gl = do+debugGL gl = do clearGLError a <- gl- liftIO $ fmap toGLError glGetError >>= traverse_ (\e -> putStrLn ctx >> print e)+ callStack <- liftIO (fmap renderStack currentCallStack)+ liftIO $ fmap toGLError glGetError >>= traverse_ (\e -> putStrLn callStack >> print e) pure a #else-debugGL _ = id+debugGL = id #endif
src/Graphics/Luminance/Core/Framebuffer.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -77,9 +78,10 @@ -> Natural -> Natural -> m (Framebuffer rw c d)+#ifdef __GL45 createFramebuffer w h mipmaps = do fid <- liftIO . alloca $ \p -> do- debugGL "createFramebuffer" $ glCreateFramebuffers 1 p+ debugGL $ glCreateFramebuffers 1 p peek p (colorOutputNb,colorTexs) <- addColorOutput fid 0 w h mipmaps (Proxy :: Proxy c) (hasDepthOutput,depthTex) <- addDepthOutput fid w h mipmaps (Proxy :: Proxy d)@@ -90,6 +92,22 @@ if | status == GL_FRAMEBUFFER_COMPLETE -> pure $ Framebuffer fid (Output colorTexs depthTex) | otherwise -> throwError . fromFramebufferError . IncompleteFramebuffer $ translateFramebufferStatus status+#elif defined(__GL32)+createFramebuffer w h mipmaps = do+ fid <- liftIO . alloca $ \p -> do+ debugGL $ glGenFramebuffers 1 p+ peek p+ glBindFramebuffer GL_FRAMEBUFFER fid+ (colorOutputNb,colorTexs) <- addColorOutput fid 0 w h mipmaps (Proxy :: Proxy c)+ (hasDepthOutput,depthTex) <- addDepthOutput fid w h mipmaps (Proxy :: Proxy d)+ setColorBuffers fid colorOutputNb (Proxy :: Proxy rw)+ unless hasDepthOutput $ setDepthRenderbuffer fid w h+ _ <- register . with fid $ glDeleteFramebuffers 1+ status <- glCheckFramebufferStatus GL_FRAMEBUFFER+ if + | status == GL_FRAMEBUFFER_COMPLETE -> pure $ Framebuffer fid (Output colorTexs depthTex)+ | otherwise -> throwError . fromFramebufferError . IncompleteFramebuffer $ translateFramebufferStatus status+#endif -- Translate OpenGL framebuffer status into human readable versions. translateFramebufferStatus :: GLenum -> String@@ -156,12 +174,21 @@ -> Natural -> proxy rw -> m ()+#ifdef __GL45 setColorBuffers fid colorOutputNb _ = case colorOutputNb of 0 -> do -- disable color outputs- debugGL "setColorBuffers 1" $ glNamedFramebufferDrawBuffer fid GL_NONE- debugGL "setColorBuffers 2" $ glNamedFramebufferReadBuffer fid GL_NONE+ debugGL $ glNamedFramebufferDrawBuffer fid GL_NONE+ debugGL $ glNamedFramebufferReadBuffer fid GL_NONE _ -> setFramebufferColorRW fid colorOutputNb (Proxy :: Proxy rw)+#elif defined(__GL32)+setColorBuffers fid colorOutputNb _ = case colorOutputNb of+ 0 -> do+ -- disable color outputs+ debugGL $ glDrawBuffer GL_NONE+ debugGL $ glReadBuffer GL_NONE+ _ -> setFramebufferColorRW fid colorOutputNb (Proxy :: Proxy rw)+#endif -------------------------------------------------------------------------------- -- Framebuffer depth attachment ------------------------------------------------@@ -188,10 +215,17 @@ -> Natural -> Natural -> m ()+#ifdef __GL45 setDepthRenderbuffer fid w h = do renderbuffer <- createRenderbuffer w h (Proxy :: Proxy Depth32F)- debugGL "setDepthRenderBuffer" $ glNamedFramebufferRenderbuffer fid (fromAttachment DepthAttachment) GL_RENDERBUFFER+ debugGL $ glNamedFramebufferRenderbuffer fid (fromAttachment DepthAttachment) GL_RENDERBUFFER (renderbufferID renderbuffer)+#elif defined(__GL32)+setDepthRenderbuffer _ w h = do+ renderbuffer <- createRenderbuffer w h (Proxy :: Proxy Depth32F)+ debugGL $ glFramebufferRenderbuffer GL_FRAMEBUFFER (fromAttachment DepthAttachment) GL_RENDERBUFFER+ (renderbufferID renderbuffer)+#endif -------------------------------------------------------------------------------- -- Framebuffer color read/write configuration ----------------------------------@@ -201,14 +235,26 @@ setFramebufferColorRW :: (MonadIO m) => GLuint -> Natural -> proxy rw -> m () instance FramebufferColorRW W where+#ifdef __GL45 setFramebufferColorRW fid nb _ = liftIO $ do withArrayLen (colorAttachmentsFromMax nb) $ \n buffers ->- debugGL "setFramebufferColorRW[W]" $ glNamedFramebufferDrawBuffers fid (fromIntegral n) buffers+ debugGL $ glNamedFramebufferDrawBuffers fid (fromIntegral n) buffers+#elif defined(__GL32)+ setFramebufferColorRW _ nb _ = liftIO $ do+ withArrayLen (colorAttachmentsFromMax nb) $ \n buffers ->+ debugGL $ glDrawBuffers (fromIntegral n) buffers+#endif instance FramebufferColorRW RW where+#ifdef __GL45 setFramebufferColorRW fid nb _ = liftIO $ do withArrayLen (colorAttachmentsFromMax nb) $ \n buffers ->- debugGL "setFramebufferColorRW[RW]" $ glNamedFramebufferDrawBuffers fid (fromIntegral n) buffers+ debugGL $ glNamedFramebufferDrawBuffers fid (fromIntegral n) buffers+#elif defined(__GL32)+ setFramebufferColorRW _ nb _ = liftIO $ do+ withArrayLen (colorAttachmentsFromMax nb) $ \n buffers ->+ debugGL $ glDrawBuffers (fromIntegral n) buffers+#endif -------------------------------------------------------------------------------- -- Framebuffer read/write target configuration ---------------------------------@@ -238,11 +284,19 @@ -> Natural -> proxy p -> m (Texture2D p)+#ifdef __GL45 addOutput fid ca w h mipmaps _ = do tex :: Texture2D p <- createTexture (w,h) mipmaps defaultSampling- debugGL "addOutput" . liftIO $ glNamedFramebufferTexture fid (fromAttachment ca)+ debugGL . liftIO $ glNamedFramebufferTexture fid (fromAttachment ca) (baseTextureID $ texture2DBase tex) 0 pure tex+#elif defined(__GL32)+addOutput _ ca w h mipmaps _ = do+ tex :: Texture2D p <- createTexture (w,h) mipmaps defaultSampling+ debugGL . liftIO $ glFramebufferTexture GL_FRAMEBUFFER (fromAttachment ca)+ (baseTextureID $ texture2DBase tex) 0+ pure tex+#endif -------------------------------------------------------------------------------- -- Framebuffer textures accessors ----------------------------------------------@@ -287,9 +341,18 @@ -> FramebufferBlitMask -> Filter -> m ()-framebufferBlit src dst srcX srcY srcW srcH dstX dstY dstW dstH mask flt = liftIO . debugGL "blit" $+#ifdef __GL45+framebufferBlit src dst srcX srcY srcW srcH dstX dstY dstW dstH mask flt = liftIO . debugGL $ glBlitNamedFramebuffer (framebufferID src) (framebufferID dst) srcX0 srcY0 srcX1 srcY1 dstX0 dstY0 dstX1 dstY1 (fromFramebufferBlitMask mask) (fromFilter flt)+#elif defined(__GL32)+framebufferBlit src dst srcX srcY srcW srcH dstX dstY dstW dstH mask flt =+ liftIO . debugGL $ do+ glBindFramebuffer GL_READ_FRAMEBUFFER (framebufferID src)+ glBindFramebuffer GL_DRAW_FRAMEBUFFER (framebufferID dst)+ glBlitFramebuffer srcX0 srcY0 srcX1 srcY1 dstX0 dstY0 dstX1 dstY1+ (fromFramebufferBlitMask mask) (fromFilter flt)+#endif where srcX0 = fromIntegral srcX srcY0 = fromIntegral srcY
src/Graphics/Luminance/Core/Geometry.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -----------------------------------------------------------------------------@@ -72,6 +73,7 @@ -- If you don’t pass indices ('Nothing'), you end up with a /direct geometry/. Otherwise, you get an -- /indexed geometry/. You also have to provide a 'GeometryMode' to state how you want the vertices -- to be connected with each other.+#ifdef __GL45 createGeometry :: forall f m v. (Foldable f,MonadIO m,MonadResource m,Storable v,Vertex v) => f v -> Maybe (f Word32)@@ -100,6 +102,40 @@ where vertNb = length vertices mode' = fromGeometryMode mode+#elif defined(__GL32)+createGeometry :: forall f m v. (Foldable f,MonadIO m,MonadResource m,Storable v,Vertex v)+ => f v+ -> Maybe (f Word32)+ -> GeometryMode+ -> m Geometry+createGeometry vertices indices mode = do+ -- create the vertex array object (OpenGL-side)+ vid <- liftIO . alloca $ \p -> do+ glGenVertexArrays 1 p+ peek p+ _ <- register . with vid $ glDeleteVertexArrays 1+ glBindVertexArray vid+ -- vertex buffer+ (vreg :: Region W v,vbo) <- createBuffer_ $ newRegion (fromIntegral vertNb)+ writeWhole vreg vertices+ liftIO $ glBindBuffer GL_ARRAY_BUFFER (bufferID vbo)+ _ <- setFormatV vid 0 0 (Proxy :: Proxy v)+ -- element buffer, if required+ case indices of+ Just indices' -> do+ let ixNb = length indices'+ (ireg :: Region W Word32,ibo) <- createBuffer_ $ newRegion (fromIntegral ixNb)+ writeWhole ireg indices'+ glBindBuffer GL_ELEMENT_ARRAY_BUFFER(bufferID ibo)+ glBindVertexArray 0+ pure . IndexedGeometry $ VertexArray vid mode' (fromIntegral ixNb)+ Nothing -> do+ glBindVertexArray 0+ pure . DirectGeometry $ VertexArray vid mode' (fromIntegral vertNb)+ where+ vertNb = length vertices+ mode' = fromGeometryMode mode+#endif -- |/O (n log n)/ --
src/Graphics/Luminance/Core/RenderCmd.hs view
@@ -11,7 +11,7 @@ module Graphics.Luminance.Core.RenderCmd where import Graphics.Luminance.Core.Blending-import Graphics.Luminance.Core.Shader.Uniform ( U(..) )+import Graphics.Luminance.Core.Shader.Program ( U(..) ) -- FIXME: we need to make a tighter link between c and blending and between d and the depth test. -- FIXME: is the 'rw' type parameter still useful?
src/Graphics/Luminance/Core/Renderbuffer.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2015 Dimitri Sabadie@@ -23,11 +25,23 @@ newtype Renderbuffer = Renderbuffer { renderbufferID :: GLuint } deriving (Eq,Show) createRenderbuffer :: (MonadIO m,MonadResource m,Pixel f) => Natural -> Natural -> Proxy f -> m Renderbuffer+#ifdef __GL45 createRenderbuffer w h depthProxy = do rid <- liftIO . alloca $ \p -> do glCreateRenderbuffers 1 p rid <- peek p glNamedRenderbufferStorage rid (pixelIFormat depthProxy) (fromIntegral w) (fromIntegral h) pure rid- _ <- register . with rid $ glDeleteRenderbuffers 1- pure $ Renderbuffer rid+ _ <- register $ with rid (glDeleteRenderbuffers 1)+ pure (Renderbuffer rid)+#elif defined(__GL32)+createRenderbuffer w h depthProxy = do+ rid <- liftIO . alloca $ \p -> do+ glGenRenderbuffers 1 p+ rid <- peek p+ glBindRenderbuffer GL_RENDERBUFFER rid+ glRenderbufferStorage GL_RENDERBUFFER (pixelIFormat depthProxy) (fromIntegral w) (fromIntegral h)+ pure rid+ _ <- register $ with rid (glDeleteRenderbuffers 1)+ pure (Renderbuffer rid)+#endif
src/Graphics/Luminance/Core/Shader/Program.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,22 +18,41 @@ module Graphics.Luminance.Core.Shader.Program where import Control.Applicative ( liftA2 )+import Control.Monad ( unless, when ) import Control.Monad.Except ( MonadError(throwError) ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Trans.Resource ( MonadResource, register ) import Control.Monad.Trans.State ( StateT, evalStateT, gets, modify )-import Data.Foldable ( traverse_ )+import Data.Foldable ( toList, traverse_ )+import Data.Functor.Contravariant ( Contravariant(..) )+import Data.Functor.Contravariant.Divisible ( Decidable(..), Divisible(..) )+import Data.Int ( Int32 ) import Data.Proxy ( Proxy(..) )+import Data.Semigroup ( Semigroup(..) )+import Data.Void ( absurd )+import Data.Word ( Word32 ) import Foreign.C ( peekCString, withCString ) import Foreign.Marshal.Alloc ( alloca )-import Foreign.Marshal.Array ( allocaArray )+import Foreign.Marshal.Array ( allocaArray, withArrayLen )+import Foreign.Marshal.Utils ( with ) import Foreign.Ptr ( castPtr, nullPtr ) import Foreign.Storable ( Storable(peek) ) import Graphics.Luminance.Core.Buffer ( Region(..), bufferID )+import Graphics.Luminance.Core.Debug+import Graphics.Luminance.Core.Cubemap ( Cubemap(..) )+import Graphics.Luminance.Core.Pixel ( Pixel ) import Graphics.Luminance.Core.Shader.Stage ( Stage(..) )-import Graphics.Luminance.Core.Shader.Uniform ( U(..), Uniform(..) ) import Graphics.Luminance.Core.Shader.UniformBlock ( UB, UniformBlock(sizeOfSTD140) )+import Graphics.Luminance.Core.Texture+import Graphics.Luminance.Core.Texture1D+import Graphics.Luminance.Core.Texture2D+import Graphics.Luminance.Core.Texture3D import Graphics.GL+#ifdef __GL_BINDLESS_TEXTURES+import Graphics.GL.Ext.ARB.BindlessTexture ( glProgramUniformHandleui64ARB )+#endif+import Linear+import Linear.V ( V(..) ) import Numeric.Natural ( Natural ) --------------------------------------------------------------------------------@@ -57,20 +78,20 @@ -> m (Program,i) createProgram stages buildIface = do (pid,linked,cl) <- liftIO $ do- pid <- glCreateProgram- traverse_ (glAttachShader pid . stageID) stages- glLinkProgram pid- linked <- isLinked pid+ pid <- debugGL glCreateProgram+ traverse_ (debugGL . glAttachShader pid . stageID) stages+ debugGL $ glLinkProgram pid+ linked <- debugGL $ isLinked pid ll <- clogLength pid cl <- clog ll pid pure (pid,linked,cl)- if- | linked -> do- _ <- register $ glDeleteProgram pid- let prog = Program pid- a <- runUniformInterface $ buildIface (uniformize prog) (uniformizeBlock prog)- pure (prog,a)- | otherwise -> throwError . fromProgramError $ LinkFailed cl+ unless linked $ do+ liftIO (glDeleteProgram pid)+ throwError . fromProgramError $ LinkFailed cl+ _ <- register $ glDeleteProgram pid+ let prog = Program pid+ a <- runUniformInterface $ buildIface (uniformize prog) (uniformizeBlock prog)+ pure (prog,a) -- |A simpler version of 'createProgram'. That function assumes you don’t need a uniform interface -- and then just returns the 'Program'.@@ -82,21 +103,19 @@ -- |Is a shader program linked? isLinked :: GLuint -> IO Bool isLinked pid = do- ok <- alloca $ liftA2 (*>) (glGetProgramiv pid GL_LINK_STATUS) peek+ ok <- debugGL . alloca $ liftA2 (*>) (glGetProgramiv pid GL_LINK_STATUS) peek pure $ ok == GL_TRUE -- |Shader program link log’s length. clogLength :: GLuint -> IO Int clogLength pid =- fmap fromIntegral .- alloca $ liftA2 (*>) (glGetProgramiv pid GL_INFO_LOG_LENGTH) peek+ fmap fromIntegral . debugGL . alloca $ liftA2 (*>) (glGetProgramiv pid GL_INFO_LOG_LENGTH) peek -- |Shader program link log. clog :: Int -> GLuint -> IO String clog l pid =- allocaArray l $- liftA2 (*>) (glGetProgramInfoLog pid (fromIntegral l) nullPtr)- (peekCString . castPtr)+ debugGL . allocaArray l $+ liftA2 (*>) (glGetProgramInfoLog pid (fromIntegral l) nullPtr) (peekCString . castPtr) -------------------------------------------------------------------------------- -- Uniform interface -----------------------------------------------------------@@ -108,13 +127,21 @@ runUniformInterface :: (Monad m) => UniformInterface m a -> m a runUniformInterface ui = evalStateT (runUniformInterface' ui) emptyUniformInterfaceCtxt -newtype UniformInterfaceCtxt = UniformInterfaceCtxt {+data UniformInterfaceCtxt = UniformInterfaceCtxt {+ -- Used to generate bindings for uniform blocks uniformInterfaceBufferBinding :: GLuint+#if !defined(__GL_BINDLESS_TEXTURES)+ -- Used to generate texture units when necessary+ , uniformInterfaceTextureUnit :: GLenum+#endif } deriving (Eq,Show) emptyUniformInterfaceCtxt :: UniformInterfaceCtxt emptyUniformInterfaceCtxt = UniformInterfaceCtxt { uniformInterfaceBufferBinding = 0+#if !defined(__GL_BINDLESS_TEXTURES)+ , uniformInterfaceTextureUnit = 0+#endif } -- |Either map a 'String' or 'Natural' to a uniform.@@ -124,13 +151,12 @@ -> UniformInterface m (U a) uniformize Program{programID = pid} access = UniformInterface $ case access of Left name -> do- location <- liftIO . withCString name $ glGetUniformLocation pid- if- | location /= -1 -> pure $ toU pid location- | otherwise -> throwError . fromProgramError $ InactiveUniform access- Right sem- | sem /= -1 -> pure $ toU pid (fromIntegral sem)- | otherwise -> throwError . fromProgramError $ InactiveUniform access+ location <- liftIO . debugGL . withCString name $ glGetUniformLocation pid+ when (location == -1) (throwError . fromProgramError $ InactiveUniform access)+ runUniformInterface' (toU pid location)+ Right sem -> do+ when (sem == -1) (throwError . fromProgramError $ InactiveUniform access)+ runUniformInterface' $ toU pid (fromIntegral sem) -- |Map a 'String' to a uniform block. uniformizeBlock :: forall a e m rw. (HasProgramError e,MonadError e m,MonadIO m,UniformBlock a)@@ -138,21 +164,694 @@ -> String -> UniformInterface m (U (Region rw (UB a))) uniformizeBlock Program{programID = pid} name = UniformInterface $ do- index <- liftIO . withCString name $ glGetUniformBlockIndex pid- if- | index /= GL_INVALID_INDEX -> do- -- retrieve a new binding value and use it- binding <- gets uniformInterfaceBufferBinding- modify $ \ctxt -> ctxt { uniformInterfaceBufferBinding = succ $ uniformInterfaceBufferBinding ctxt }- liftIO (glUniformBlockBinding pid index binding)- pure . U $ \r -> do- glBindBufferRange- GL_UNIFORM_BUFFER- binding- (bufferID $ regionBuffer r)- (fromIntegral $ regionOffset r)- (fromIntegral $ regionSize r * sizeOfSTD140 (Proxy :: Proxy a))- | otherwise -> throwError . fromProgramError $ InactiveUniformBlock name+ index <- liftIO . debugGL . withCString name $ glGetUniformBlockIndex pid+ when (index == GL_INVALID_INDEX) (throwError . fromProgramError $ InactiveUniformBlock name)+ -- retrieve a new binding value and use it+ binding <- gets uniformInterfaceBufferBinding+ modify $ \ctxt -> ctxt { uniformInterfaceBufferBinding = succ $ uniformInterfaceBufferBinding ctxt }+ liftIO . debugGL $ glUniformBlockBinding pid index binding+ pure . U $ \r -> do+ debugGL $ glBindBufferRange+ GL_UNIFORM_BUFFER+ binding+ (bufferID $ regionBuffer r)+ (fromIntegral $ regionOffset r)+ (fromIntegral $ regionSize r * sizeOfSTD140 (Proxy :: Proxy a))++#if !defined(__GL_BINDLESS_TEXTURES)+nextTextureUnit :: (Monad m) => UniformInterface m GLuint+nextTextureUnit = UniformInterface $ do+ texUnit <- gets uniformInterfaceTextureUnit+ modify $ \ctxt -> ctxt { uniformInterfaceTextureUnit = succ texUnit }+ pure texUnit+#endif++--------------------------------------------------------------------------------+-- Uniform ---------------------------------------------------------------------++-- |A shader uniform. @'U' a@ doesn’t hold any value. It’s more like a mapping between the host+-- code and the shader the uniform was retrieved from.+--+-- 'U' is contravariant in its argument. That means that you can use 'contramap' to build more+-- interesting uniform types. It’s also a divisible contravariant functor, then you can divide+-- structures to take advantage of divisible contravariant properties and then glue several 'U'+-- with different types. That can be useful to build a uniform type by gluing its fields.+--+-- Another interesting part is the fact that 'U' is also monoidal. You can accumulate several of+-- them with '(<>)' if they have the same type. That means that you can join them so that when you+-- pass an actual value, it gets shared inside the resulting value.+--+-- The '()' instance doesn’t do anything and doesn’t even use its argument ('()').+newtype U a = U { runU :: a -> IO () }++instance Contravariant U where+ contramap f u = U $ runU u . f++instance Decidable U where+ lose f = U $ absurd . f+ choose f p q = U $ either (runU p) (runU q) . f++instance Divisible U where+ divide f p q = U $ \a -> do+ let (b,c) = f a+ runU p b+ runU q c+ conquer = mempty++instance Monoid (U a) where+ mempty = U . const $ pure ()+ mappend = (<>)++instance Semigroup (U a) where+ u <> v = U $ \a -> runU u a >> runU v a++-- |Class of types that can be sent down to shaders. That class is closed because shaders cannot+-- handle a lot of uniform types. However, you should have a look at the 'U' documentation for+-- further information about how to augment the scope of the types you can send down to shaders.+class Uniform a where+ -- |@'toU' prog l@ creates a new 'U a' by mapping it to the 'Program' @prog@ and using the+ -- location 'l'.+ toU :: (Monad m) => GLuint -> GLint -> UniformInterface m (U a)++--------------------------------------------------------------------------------+-- Unit instance ---------------------------------------------------------------++instance Uniform () where+ toU _ _ = pure mempty++--------------------------------------------------------------------------------+-- Int32 instances -------------------------------------------------------------++-- scalar+instance Uniform Int32 where+#ifdef __GL45+ toU prog l = pure $ U (glProgramUniform1i prog l)+#elif defined(__GL32)+ toU _ l = pure $ U (glUniform1i l)+#endif++-- D2+instance Uniform (Int32,Int32) where+#ifdef __GL45+ toU prog l = pure . U $ \(x,y) -> glProgramUniform2i prog l x y+#elif defined(__GL32)+ toU _ l = pure . U $ \(x,y) -> glUniform2i l x y+#endif++instance Uniform (V2 Int32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V2 x y) -> glProgramUniform2i prog l x y+#elif defined(__GL32)+ toU _ l = pure . U $ \(V2 x y) -> glUniform2i l x y+#endif++instance Uniform (V 2 Int32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V v) -> case toList v of+ [x,y] -> glProgramUniform2i prog l x y+ _ -> pure ()+#elif defined(__GL32)+ toU _ l = pure . U $ \(V v) -> case toList v of+ [x,y] -> glUniform2i l x y+ _ -> pure ()+#endif+ +-- D3+instance Uniform (Int32,Int32,Int32) where+#ifdef __GL45+ toU prog l = pure . U $ \(x,y,z) -> glProgramUniform3i prog l x y z+#elif defined(__GL32)+ toU _ l = pure . U $ \(x,y,z) -> glUniform3i l x y z+#endif++instance Uniform (V3 Int32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V3 x y z) -> glProgramUniform3i prog l x y z+#elif defined(__GL32)+ toU _ l = pure . U $ \(V3 x y z) -> glUniform3i l x y z+#endif++instance Uniform (V 3 Int32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V v) -> case toList v of+ [x,y,z] -> glProgramUniform3i prog l x y z+ _ -> pure ()+#elif defined(__GL32)+ toU _ l = pure . U $ \(V v) -> case toList v of+ [x,y,z] -> glUniform3i l x y z+ _ -> pure ()+#endif++-- D4+instance Uniform (Int32,Int32,Int32,Int32) where+#ifdef __GL45+ toU prog l = pure . U $ \(x,y,z,w) -> glProgramUniform4i prog l x y z w+#elif defined(__GL32)+ toU _ l = pure . U $ \(x,y,z,w) -> glUniform4i l x y z w+#endif++instance Uniform (V4 Int32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V4 x y z w) -> glProgramUniform4i prog l x y z w+#elif defined(__GL32)+ toU _ l = pure . U $ \(V4 x y z w) -> glUniform4i l x y z w+#endif++instance Uniform (V 4 Int32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V v) -> case toList v of+ [x,y,z,w] -> glProgramUniform4i prog l x y z w+ _ -> pure ()+#elif defined(__GL32)+ toU _ l = pure . U $ \(V v) -> case toList v of+ [x,y,z,w] -> glUniform4i l x y z w+ _ -> pure ()+#endif++-- scalar array+instance Uniform [Int32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ glProgramUniform1iv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ glUniform1iv l . fromIntegral+#endif++-- D2 array+instance Uniform [(Int32,Int32)] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen (concatMap unPair v) $+ glProgramUniform2iv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen (concatMap unPair v) $+ glUniform2iv l . fromIntegral+#endif++instance Uniform [V2 Int32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform2iv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform2iv l (fromIntegral size) (castPtr p)+#endif++instance Uniform [V 2 Int32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform2iv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform2iv l (fromIntegral size) (castPtr p)+#endif++-- D3 array+instance Uniform [(Int32,Int32,Int32)] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen (concatMap unTriple v) $+ glProgramUniform3iv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen (concatMap unTriple v) $+ glUniform3iv l . fromIntegral+#endif++instance Uniform [V3 Int32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform3iv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform3iv l (fromIntegral size) (castPtr p)+#endif++instance Uniform [V 3 Int32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform3iv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform3iv l (fromIntegral size) (castPtr p)+#endif++-- D4 array+instance Uniform [(Int32,Int32,Int32,Int32)] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen (concatMap unQuad v) $+ glProgramUniform4iv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen (concatMap unQuad v) $+ glUniform4iv l . fromIntegral+#endif++instance Uniform [V4 Int32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform4iv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform4iv l (fromIntegral size) (castPtr p)+#endif++instance Uniform [V 4 Int32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform4iv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform4iv l (fromIntegral size) (castPtr p)+#endif++--------------------------------------------------------------------------------+-- Word32 instances ------------------------------------------------------------++-- scalar+instance Uniform Word32 where+#ifdef __GL45+ toU prog l = pure . U $ glProgramUniform1ui prog l+#elif defined(__GL32)+ toU _ l = pure . U $ glUniform1ui l+#endif++-- D2+instance Uniform (Word32,Word32) where+#ifdef __GL45+ toU prog l = pure . U $ \(x,y) -> glProgramUniform2ui prog l x y+#elif defined(__GL32)+ toU _ l = pure . U $ \(x,y) -> glUniform2ui l x y+#endif++instance Uniform (V2 Word32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V2 x y) -> glProgramUniform2ui prog l x y+#elif defined(__GL32)+ toU _ l = pure . U $ \(V2 x y) -> glUniform2ui l x y+#endif++instance Uniform (V 2 Word32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V v) -> case toList v of+ [x,y] -> glProgramUniform2ui prog l x y+ _ -> pure ()+#elif defined(__GL32)+ toU _ l = pure . U $ \(V v) -> case toList v of+ [x,y] -> glUniform2ui l x y+ _ -> pure ()+#endif++-- D3+instance Uniform (Word32,Word32,Word32) where+#ifdef __GL45+ toU prog l = pure . U $ \(x,y,z) -> glProgramUniform3ui prog l x y z+#elif defined(__GL32)+ toU _ l = pure . U $ \(x,y,z) -> glUniform3ui l x y z+#endif++instance Uniform (V3 Word32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V3 x y z) -> glProgramUniform3ui prog l x y z+#elif defined(__GL32)+ toU _ l = pure . U $ \(V3 x y z) -> glUniform3ui l x y z+#endif++instance Uniform (V 3 Word32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V v) -> case toList v of+ [x,y,z] -> glProgramUniform3ui prog l x y z+ _ -> pure ()+#elif defined(__GL32)+ toU _ l = pure . U $ \(V v) -> case toList v of+ [x,y,z] -> glUniform3ui l x y z+ _ -> pure ()+#endif++-- D4+instance Uniform (Word32,Word32,Word32,Word32) where+#ifdef __GL45+ toU prog l = pure . U $ \(x,y,z,w) -> glProgramUniform4ui prog l x y z w+#elif defined(__GL32)+ toU _ l = pure . U $ \(x,y,z,w) -> glUniform4ui l x y z w+#endif++instance Uniform (V4 Word32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V4 x y z w) -> glProgramUniform4ui prog l x y z w+#elif defined(__GL32)+ toU _ l = pure . U $ \(V4 x y z w) -> glUniform4ui l x y z w+#endif++instance Uniform (V 4 Word32) where+#ifdef __GL45+ toU prog l = pure . U $ \(V v) -> case toList v of+ [x,y,z,w] -> glProgramUniform4ui prog l x y z w+ _ -> pure ()+#elif defined(__GL32)+ toU _ l = pure . U $ \(V v) -> case toList v of+ [x,y,z,w] -> glUniform4ui l x y z w+ _ -> pure ()+#endif++-- scalar array+instance Uniform [Word32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $+ glProgramUniform1uiv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $+ glUniform1uiv l . fromIntegral+#endif++-- D2 array+instance Uniform [(Word32,Word32)] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen (concatMap unPair v) $+ glProgramUniform2uiv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen (concatMap unPair v) $+ glUniform2uiv l . fromIntegral+#endif++instance Uniform [V2 Word32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform2uiv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform2uiv l (fromIntegral size) (castPtr p)+#endif++instance Uniform [V 2 Word32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform2uiv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform2uiv l (fromIntegral size) (castPtr p)+#endif++-- D3 array+instance Uniform [(Word32,Word32,Word32)] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen (concatMap unTriple v) $+ glProgramUniform3uiv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen (concatMap unTriple v) $+ glUniform3uiv l . fromIntegral+#endif++instance Uniform [V3 Word32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform3uiv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform3uiv l (fromIntegral size) (castPtr p)+#endif++instance Uniform [V 3 Word32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform3uiv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform3uiv l (fromIntegral size) (castPtr p)+#endif++-- D4 array+instance Uniform [(Word32,Word32,Word32,Word32)] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen (concatMap unQuad v) $+ glProgramUniform4uiv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen (concatMap unQuad v) $+ glUniform4uiv l . fromIntegral+#endif++instance Uniform [V4 Word32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform4uiv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform4uiv l (fromIntegral size) (castPtr p)+#endif++instance Uniform [V 4 Word32] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform4uiv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform4uiv l (fromIntegral size) (castPtr p)+#endif++--------------------------------------------------------------------------------+-- Float instances -------------------------------------------------------------++-- scalar+instance Uniform Float where+#ifdef __GL45+ toU prog l = pure . U $ glProgramUniform1f prog l+#elif defined(__GL32)+ toU _ l = pure . U $ glUniform1f l+#endif++-- D2+instance Uniform (Float,Float) where+#ifdef __GL45+ toU prog l = pure . U $ \(x,y) -> glProgramUniform2f prog l x y+#elif defined(__GL32)+ toU _ l = pure . U $ \(x,y) -> glUniform2f l x y+#endif++instance Uniform (V2 Float) where+#ifdef __GL45+ toU prog l = pure . U $ \(V2 x y) -> glProgramUniform2f prog l x y+#elif defined(__GL32)+ toU _ l = pure . U $ \(V2 x y) -> glUniform2f l x y+#endif++instance Uniform (V 2 Float) where+#ifdef __GL45+ toU prog l = pure . U $ \(V v) -> case toList v of+ [x,y] -> glProgramUniform2f prog l x y+ _ -> pure ()+#elif defined(__GL32)+ toU _ l = pure . U $ \(V v) -> case toList v of+ [x,y] -> glUniform2f l x y+ _ -> pure ()+#endif++-- D3+instance Uniform (Float,Float,Float) where+#ifdef __GL45+ toU prog l = pure . U $ \(x,y,z) -> glProgramUniform3f prog l x y z+#elif defined(__GL32)+ toU _ l = pure . U $ \(x,y,z) -> glUniform3f l x y z+#endif++instance Uniform (V3 Float) where+#ifdef __GL45+ toU prog l = pure . U $ \(V3 x y z) -> glProgramUniform3f prog l x y z+#elif defined(__GL32)+ toU _ l = pure . U $ \(V3 x y z) -> glUniform3f l x y z+#endif++instance Uniform (V 3 Float) where+#ifdef __GL45+ toU prog l = pure . U $ \(V v) -> case toList v of+ [x,y,z] -> glProgramUniform3f prog l x y z+ _ -> pure ()+#elif defined(__GL32)+ toU _ l = pure . U $ \(V v) -> case toList v of+ [x,y,z] -> glUniform3f l x y z+ _ -> pure ()+#endif++-- D4+instance Uniform (Float,Float,Float,Float) where+#ifdef __GL45+ toU prog l = pure . U $ \(x,y,z,w) -> glProgramUniform4f prog l x y z w+#elif defined(__GL32)+ toU _ l = pure . U $ \(x,y,z,w) -> glUniform4f l x y z w+#endif++instance Uniform (V4 Float) where+#ifdef __GL45+ toU prog l = pure . U $ \(V4 x y z w) -> glProgramUniform4f prog l x y z w+#elif defined(__GL32)+ toU _ l = pure . U $ \(V4 x y z w) -> glUniform4f l x y z w+#endif++instance Uniform (V 4 Float) where+#ifdef __GL45+ toU prog l = pure . U $ \(V v) -> case toList v of+ [x,y,z,w] -> glProgramUniform4f prog l x y z w+ _ -> pure ()+#elif defined(__GL32)+ toU _ l = pure . U $ \(V v) -> case toList v of+ [x,y,z,w] -> glUniform4f l x y z w+ _ -> pure ()+#endif++-- scalar array+instance Uniform [Float] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $+ glProgramUniform1fv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $+ glUniform1fv l . fromIntegral+#endif++-- D2 array+instance Uniform [(Float,Float)] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen (concatMap unPair v) $+ glProgramUniform2fv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen (concatMap unPair v) $+ glUniform2fv l . fromIntegral+#endif++instance Uniform [V2 Float] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform2fv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform2fv l (fromIntegral size) (castPtr p)+#endif++instance Uniform [V 2 Float] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform2fv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform2fv l (fromIntegral size) (castPtr p)+#endif++-- D3 array+instance Uniform [(Float,Float,Float)] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen (concatMap unTriple v) $+ glProgramUniform3fv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen (concatMap unTriple v) $+ glUniform3fv l . fromIntegral+#endif++instance Uniform [V3 Float] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform3fv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform3fv l (fromIntegral size) (castPtr p)+#endif++instance Uniform [V 3 Float] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform3fv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform3fv l (fromIntegral size) (castPtr p)+#endif++-- D4 array+instance Uniform [(Float,Float,Float,Float)] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen (concatMap unQuad v) $+ glProgramUniform4fv prog l . fromIntegral+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen (concatMap unQuad v) $+ glUniform4fv l . fromIntegral+#endif++instance Uniform [V4 Float] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform4fv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform4fv l (fromIntegral size) (castPtr p)+#endif++instance Uniform [V 4 Float] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniform4fv prog l (fromIntegral size) (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniform4fv l (fromIntegral size) (castPtr p)+#endif++--------------------------------------------------------------------------------+-- Matrices --------------------------------------------------------------------+instance Uniform (M44 Float) where+#ifdef __GL45+ toU prog l = pure . U $ \v -> with v $ glProgramUniformMatrix4fv prog l 1 GL_FALSE . castPtr+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> with v $ glUniformMatrix4fv l 1 GL_FALSE . castPtr+#endif++instance Uniform [M44 Float] where+#ifdef __GL45+ toU prog l = pure . U $ \v -> withArrayLen v $ \size p ->+ glProgramUniformMatrix4fv prog l (fromIntegral size) GL_FALSE (castPtr p)+#elif defined(__GL32)+ toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->+ glUniformMatrix4fv l (fromIntegral size) GL_FALSE (castPtr p)+#endif++--------------------------------------------------------------------------------+-- Textures --------------------------------------------------------------------++#if defined(__GL45) && defined(__GL_BINDLESS_TEXTURES)+instance Uniform (Texture1D f) where+ toU prog l = pure . U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . texture1DBase++instance Uniform (Texture2D f) where+ toU prog l = pure . U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . texture2DBase++instance Uniform (Texture3D f) where+ toU prog l = pure . U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . texture3DBase++instance Uniform (Cubemap f) where+ toU prog l = pure . U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . cubemapBase+#elif defined(__GL32)+instance (Pixel f) => Uniform (Texture1D f) where+ toU = toUTex+ +instance (Pixel f) => Uniform (Texture2D f) where+ toU = toUTex++instance (Pixel f) => Uniform (Texture3D f) where+ toU = toUTex++instance (Pixel f) => Uniform (Cubemap f) where+ toU = toUTex++toUTex :: forall m tex. (Monad m,Texture tex) => GLuint -> GLint -> UniformInterface m (U tex)+toUTex _ l = do+ texUnit <- nextTextureUnit+ pure . U $ \tex -> do+ debugGL $ glUniform1i l (fromIntegral texUnit) -- FIXME: a bit redundant?+ debugGL $ glActiveTexture (GL_TEXTURE0 + texUnit)+ debugGL $ glBindTexture (textureTypeEnum (Proxy :: Proxy tex)) (baseTextureID $ toBaseTexture tex)+#endif++--------------------------------------------------------------------------------+-- Untuple functions -----------------------------------------------------------++unPair :: (a,a) -> [a]+unPair (x,y) = [x,y]++unTriple :: (a,a,a) -> [a]+unTriple (x,y,z) = [x,y,z]++unQuad :: (a,a,a,a) -> [a]+unQuad (x,y,z,w) = [x,y,z,w] -------------------------------------------------------------------------------- -- Shader program errors -------------------------------------------------------
src/Graphics/Luminance/Core/Shader/Stage.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- |@@ -13,10 +13,13 @@ module Graphics.Luminance.Core.Shader.Stage where import Control.Applicative ( liftA2 )+import Control.Monad ( unless ) import Control.Monad.Except ( MonadError(throwError) ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Trans.Resource ( MonadResource, register ) import Graphics.GL+import Graphics.Luminance.Core.Debug+import Graphics.Luminance.Core.Query ( getGLExtensions ) import Foreign.C.String ( peekCString, withCString ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Array ( allocaArray )@@ -30,29 +33,38 @@ -- |A shader 'Stage'. newtype Stage = Stage { stageID :: GLuint } +-- |A shader 'Stage' type.+data StageType+ = TessControlShader+ | TessEvaluationShader+ | VertexShader+ | GeometryShader+ | FragmentShader+ deriving (Eq,Show)+ -- |Create a new tessellation control shader from a 'String' representation of its source code. createTessCtrlShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage createTessCtrlShader = mkShader GL_TESS_CONTROL_SHADER --- |Create a new tessellation evaluation shader from a 'String' representation of its source code.-createTessEvalShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage-createTessEvalShader = mkShader GL_TESS_EVALUATION_SHADER---- |Create a new vertex shader from a 'String' representation of its source code.-createVertexShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage-createVertexShader = mkShader GL_VERTEX_SHADER---- |Create a new geometry shader from a 'String' representation of its source code.-createGeometryShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage-createGeometryShader = mkShader GL_GEOMETRY_SHADER---- |Create a new fragment shader from a 'String' representation of its source code.-createFragmentShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage-createFragmentShader = mkShader GL_FRAGMENT_SHADER---- |Create a new compute shader from a 'String' representation of its source code.-createComputeShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m) => String -> m Stage-createComputeShader = mkShader GL_COMPUTE_SHADER+-- |Create a shader stage from a 'String' representation of its source code and its type.+--+-- Note: on some hardware and backends, /tessellation shaders/ aren’t available. That function+-- throws 'UnsupportedStage' error in such cases.+createStage :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m)+ => StageType+ -> String+ -> m Stage+createStage t src = case t of+ TessControlShader -> checkTessSupport t >> mkShader GL_TESS_CONTROL_SHADER src+ TessEvaluationShader -> checkTessSupport t >> mkShader GL_TESS_EVALUATION_SHADER src+ VertexShader -> mkShader GL_VERTEX_SHADER src+ GeometryShader -> mkShader GL_GEOMETRY_SHADER src+ FragmentShader -> mkShader GL_FRAGMENT_SHADER src+ where+ checkTessSupport stage = do+ exts <- getGLExtensions+ unless ("GL_ARB_tessellation_shader" `elem` exts) $+ throwError $ fromStageError (UnsupportedStage stage) -- Create a shader from the kind of shader and its source code 'String' representation. mkShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m)@@ -61,43 +73,50 @@ -> m Stage mkShader target src = do (sid,compiled,cl) <- liftIO $ do- sid <- glCreateShader target+ sid <- debugGL $ glCreateShader target withCString (prependGLSLPragma src) $ \cstr -> do- with cstr $ \pcstr -> glShaderSource sid 1 pcstr nullPtr- glCompileShader sid+ with cstr $ \pcstr -> debugGL $ glShaderSource sid 1 pcstr nullPtr+ debugGL $ glCompileShader sid compiled <- isCompiled sid ll <- clogLength sid cl <- clog ll sid pure (sid,compiled,cl)- if- | compiled -> do- _ <- register $ glDeleteShader sid- pure $ Stage sid- | otherwise -> throwError . fromStageError $ CompilationFailed cl+ unless compiled $ do+ liftIO (glDeleteShader sid)+ throwError . fromStageError $ CompilationFailed cl+ _ <- register $ glDeleteShader sid+ pure $ Stage sid -- Is a shader compiled? isCompiled :: GLuint -> IO Bool isCompiled sid = do- ok <- alloca $ liftA2 (*>) (glGetShaderiv sid GL_COMPILE_STATUS) peek+ ok <- debugGL . alloca $ liftA2 (*>) (glGetShaderiv sid GL_COMPILE_STATUS) peek pure $ ok == GL_TRUE -- Shader compilation log’s length. clogLength :: GLuint -> IO Int clogLength sid =- fmap fromIntegral . alloca $+ fmap fromIntegral . debugGL . alloca $ liftA2 (*>) (glGetShaderiv sid GL_INFO_LOG_LENGTH) peek -- Shader compilation log. clog :: Int -> GLuint -> IO String clog l sid =- allocaArray l $+ debugGL . allocaArray l $ liftA2 (*>) (glGetShaderInfoLog sid (fromIntegral l) nullPtr) (peekCString . castPtr) prependGLSLPragma :: String -> String prependGLSLPragma src =+#if defined(__GL45) "#version 450 core\n"+#elif defined(__GL32)+ "#version 150 core\n"+#endif+#if defined(__GL_BINDLESS_TEXTURES) ++ "#extension GL_ARB_bindless_texture : require\n"+ ++ "layout (bindless_sampler) uniform;"+#endif ++ src --------------------------------------------------------------------------------@@ -107,7 +126,13 @@ -- -- 'CompilationFailed reason' occurs when a shader fails to compile, and the 'String' 'reason' -- contains a description of the failure.-newtype StageError = CompilationFailed String deriving (Eq,Show)+--+-- 'UnsupportedStage stage' occurs when you try to create a shader which type is not supported on+-- the current hardware.+data StageError+ = CompilationFailed String + | UnsupportedStage StageType+ deriving (Eq,Show) -- |Types that can handle 'StageError'. class HasStageError a where
− src/Graphics/Luminance/Core/Shader/Uniform.hs
@@ -1,383 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}---------------------------------------------------------------------------------- |--- Copyright : (C) 2015 Dimitri Sabadie--- License : BSD3------ Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------module Graphics.Luminance.Core.Shader.Uniform where--import Data.Functor.Contravariant ( Contravariant(..) )-import Data.Functor.Contravariant.Divisible ( Decidable(..), Divisible(..) )-import Data.Int ( Int32 )-import Data.Foldable ( toList )-import Data.Semigroup ( Semigroup(..) )-import Data.Void ( absurd )-import Data.Word ( Word32 )-import Foreign.Marshal.Utils ( with )-import Foreign.Marshal.Array ( withArrayLen )-import Foreign.Ptr ( castPtr )-import Graphics.GL-import Graphics.GL.Ext.ARB.BindlessTexture ( glProgramUniformHandleui64ARB )-import Graphics.Luminance.Core.Cubemap ( Cubemap(cubemapBase) )-import Graphics.Luminance.Core.Texture ( BaseTexture(baseTextureHnd) )-import Graphics.Luminance.Core.Texture1D ( Texture1D(texture1DBase) )-import Graphics.Luminance.Core.Texture2D ( Texture2D(texture2DBase) )-import Graphics.Luminance.Core.Texture3D ( Texture3D(texture3DBase) )-import Linear-import Linear.V ( V(V) )------------------------------------------------------------------------------------- Uniform ------------------------------------------------------------------------- |Class of types that can be sent down to shaders. That class is closed because shaders cannot--- handle a lot of uniform types. However, you should have a look at the 'U' documentation for--- further information about how to augment the scope of the types you can send down to shaders.-class Uniform a where- -- |@'toU' prog l@ creates a new 'U a' by mapping it to the 'Program' @prog@ and using the- -- location 'l'.- toU :: GLuint -> GLint -> U a---- |A shader uniform. @'U' a@ doesn’t hold any value. It’s more like a mapping between the host--- code and the shader the uniform was retrieved from.------ 'U' is contravariant in its argument. That means that you can use 'contramap' to build more--- interesting uniform types. It’s also a divisible contravariant functor, then you can divide--- structures to take advantage of divisible contravariant properties and then glue several 'U'--- with different types. That can be useful to build a uniform type by gluing its fields.------ Another interesting part is the fact that 'U' is also monoidal. You can accumulate several of--- them with '(<>)' if they have the same type. That means that you can join them so that when you--- pass an actual value, it gets shared inside the resulting value.------ The '()' instance doesn’t do anything and doesn’t even use its argument ('()').-newtype U a = U { runU :: a -> IO () }--instance Contravariant U where- contramap f u = U $ runU u . f--instance Decidable U where- lose f = U $ absurd . f- choose f p q = U $ either (runU p) (runU q) . f--instance Divisible U where- divide f p q = U $ \a -> do- let (b,c) = f a- runU p b- runU q c- conquer = mempty--instance Monoid (U a) where- mempty = U . const $ pure ()- mappend = (<>)--instance Semigroup (U a) where- u <> v = U $ \a -> runU u a >> runU v a------------------------------------------------------------------------------------- Unit instance -----------------------------------------------------------------instance Uniform () where- toU _ _ = mempty------------------------------------------------------------------------------------- Int32 instances ----------------------------------------------------------------- scalar-instance Uniform Int32 where- toU prog l = U $ glProgramUniform1i prog l---- D2-instance Uniform (Int32,Int32) where- toU prog l = U $ \(x,y) -> glProgramUniform2i prog l x y--instance Uniform (V2 Int32) where- toU prog l = U $ \(V2 x y) -> glProgramUniform2i prog l x y--instance Uniform (V 2 Int32) where- toU prog l = U $ \(V v) -> case toList v of- [x,y] -> glProgramUniform2i prog l x y- _ -> pure ()- --- D3-instance Uniform (Int32,Int32,Int32) where- toU prog l = U $ \(x,y,z) -> glProgramUniform3i prog l x y z--instance Uniform (V3 Int32) where- toU prog l = U $ \(V3 x y z) -> glProgramUniform3i prog l x y z--instance Uniform (V 3 Int32) where- toU prog l = U $ \(V v) -> case toList v of- [x,y,z] -> glProgramUniform3i prog l x y z- _ -> pure ()---- D4-instance Uniform (Int32,Int32,Int32,Int32) where- toU prog l = U $ \(x,y,z,w) -> glProgramUniform4i prog l x y z w--instance Uniform (V4 Int32) where- toU prog l = U $ \(V4 x y z w) -> glProgramUniform4i prog l x y z w--instance Uniform (V 4 Int32) where- toU prog l = U $ \(V v) -> case toList v of- [x,y,z,w] -> glProgramUniform4i prog l x y z w- _ -> pure ()---- scalar array-instance Uniform [Int32] where- toU prog l = U $ \v -> withArrayLen v $ glProgramUniform1iv prog l . fromIntegral---- D2 array-instance Uniform [(Int32,Int32)] where- toU prog l = U $ \v -> withArrayLen (concatMap unPair v) $- glProgramUniform2iv prog l . fromIntegral--instance Uniform [V2 Int32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform2iv prog l (fromIntegral size) (castPtr p)--instance Uniform [V 2 Int32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform2iv prog l (fromIntegral size) (castPtr p)---- D3 array-instance Uniform [(Int32,Int32,Int32)] where- toU prog l = U $ \v -> withArrayLen (concatMap unTriple v) $- glProgramUniform3iv prog l . fromIntegral--instance Uniform [V3 Int32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform3iv prog l (fromIntegral size) (castPtr p)--instance Uniform [V 3 Int32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform3iv prog l (fromIntegral size) (castPtr p)---- D4 array-instance Uniform [(Int32,Int32,Int32,Int32)] where- toU prog l = U $ \v -> withArrayLen (concatMap unQuad v) $- glProgramUniform4iv prog l . fromIntegral--instance Uniform [V4 Int32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform4iv prog l (fromIntegral size) (castPtr p)--instance Uniform [V 4 Int32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform4iv prog l (fromIntegral size) (castPtr p)------------------------------------------------------------------------------------- Word32 instances ---------------------------------------------------------------- scalar-instance Uniform Word32 where- toU prog l = U $ glProgramUniform1ui prog l---- D2-instance Uniform (Word32,Word32) where- toU prog l = U $ \(x,y) -> glProgramUniform2ui prog l x y--instance Uniform (V2 Word32) where- toU prog l = U $ \(V2 x y) -> glProgramUniform2ui prog l x y--instance Uniform (V 2 Word32) where- toU prog l = U $ \(V v) -> case toList v of- [x,y] -> glProgramUniform2ui prog l x y- _ -> pure ()---- D3-instance Uniform (Word32,Word32,Word32) where- toU prog l = U $ \(x,y,z) -> glProgramUniform3ui prog l x y z--instance Uniform (V3 Word32) where- toU prog l = U $ \(V3 x y z) -> glProgramUniform3ui prog l x y z--instance Uniform (V 3 Word32) where- toU prog l = U $ \(V v) -> case toList v of- [x,y,z] -> glProgramUniform3ui prog l x y z- _ -> pure ()---- D4-instance Uniform (Word32,Word32,Word32,Word32) where- toU prog l = U $ \(x,y,z,w) -> glProgramUniform4ui prog l x y z w--instance Uniform (V4 Word32) where- toU prog l = U $ \(V4 x y z w) -> glProgramUniform4ui prog l x y z w--instance Uniform (V 4 Word32) where- toU prog l = U $ \(V v) -> case toList v of- [x,y,z,w] -> glProgramUniform4ui prog l x y z w- _ -> pure ()---- scalar array-instance Uniform [Word32] where- toU prog l = U $ \v -> withArrayLen v $- glProgramUniform1uiv prog l . fromIntegral---- D2 array-instance Uniform [(Word32,Word32)] where- toU prog l = U $ \v -> withArrayLen (concatMap unPair v) $- glProgramUniform2uiv prog l . fromIntegral--instance Uniform [V2 Word32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform2uiv prog l (fromIntegral size) (castPtr p)--instance Uniform [V 2 Word32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform2uiv prog l (fromIntegral size) (castPtr p)---- D3 array-instance Uniform [(Word32,Word32,Word32)] where- toU prog l = U $ \v -> withArrayLen (concatMap unTriple v) $- glProgramUniform3uiv prog l . fromIntegral--instance Uniform [V3 Word32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform3uiv prog l (fromIntegral size) (castPtr p)--instance Uniform [V 3 Word32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform3uiv prog l (fromIntegral size) (castPtr p)---- D4 array-instance Uniform [(Word32,Word32,Word32,Word32)] where- toU prog l = U $ \v -> withArrayLen (concatMap unQuad v) $- glProgramUniform4uiv prog l . fromIntegral--instance Uniform [V4 Word32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform4uiv prog l (fromIntegral size) (castPtr p)--instance Uniform [V 4 Word32] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform4uiv prog l (fromIntegral size) (castPtr p)------------------------------------------------------------------------------------- Float instances ----------------------------------------------------------------- scalar-instance Uniform Float where- toU prog l = U $ glProgramUniform1f prog l---- D2-instance Uniform (Float,Float) where- toU prog l = U $ \(x,y) -> glProgramUniform2f prog l x y--instance Uniform (V2 Float) where- toU prog l = U $ \(V2 x y) -> glProgramUniform2f prog l x y--instance Uniform (V 2 Float) where- toU prog l = U $ \(V v) -> case toList v of- [x,y] -> glProgramUniform2f prog l x y- _ -> pure ()---- D3-instance Uniform (Float,Float,Float) where- toU prog l = U $ \(x,y,z) -> glProgramUniform3f prog l x y z--instance Uniform (V3 Float) where- toU prog l = U $ \(V3 x y z) -> glProgramUniform3f prog l x y z--instance Uniform (V 3 Float) where- toU prog l = U $ \(V v) -> case toList v of- [x,y,z] -> glProgramUniform3f prog l x y z- _ -> pure ()---- D4-instance Uniform (Float,Float,Float,Float) where- toU prog l = U $ \(x,y,z,w) -> glProgramUniform4f prog l x y z w--instance Uniform (V4 Float) where- toU prog l = U $ \(V4 x y z w) -> glProgramUniform4f prog l x y z w--instance Uniform (V 4 Float) where- toU prog l = U $ \(V v) -> case toList v of- [x,y,z,w] -> glProgramUniform4f prog l x y z w- _ -> pure ()---- scalar array-instance Uniform [Float] where- toU prog l = U $ \v -> withArrayLen v $- glProgramUniform1fv prog l . fromIntegral---- D2 array-instance Uniform [(Float,Float)] where- toU prog l = U $ \v -> withArrayLen (concatMap unPair v) $- glProgramUniform2fv prog l . fromIntegral--instance Uniform [V2 Float] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform2fv prog l (fromIntegral size) (castPtr p)--instance Uniform [V 2 Float] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform2fv prog l (fromIntegral size) (castPtr p)---- D3 array-instance Uniform [(Float,Float,Float)] where- toU prog l = U $ \v -> withArrayLen (concatMap unTriple v) $- glProgramUniform3fv prog l . fromIntegral--instance Uniform [V3 Float] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform3fv prog l (fromIntegral size) (castPtr p)--instance Uniform [V 3 Float] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform3fv prog l (fromIntegral size) (castPtr p)---- D4 array-instance Uniform [(Float,Float,Float,Float)] where- toU prog l = U $ \v -> withArrayLen (concatMap unQuad v) $- glProgramUniform4fv prog l . fromIntegral--instance Uniform [V4 Float] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform4fv prog l (fromIntegral size) (castPtr p)--instance Uniform [V 4 Float] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniform4fv prog l (fromIntegral size) (castPtr p)------------------------------------------------------------------------------------- Matrices ---------------------------------------------------------------------instance Uniform (M44 Float) where- toU prog l = U $ \v -> with v $ glProgramUniformMatrix4fv prog l 1 GL_FALSE . castPtr--instance Uniform [M44 Float] where- toU prog l = U $ \v -> withArrayLen v $ \size p ->- glProgramUniformMatrix4fv prog l (fromIntegral size) GL_FALSE (castPtr p)------------------------------------------------------------------------------------- Textures ----------------------------------------------------------------------instance Uniform (Texture1D f) where- toU prog l = U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . texture1DBase--instance Uniform (Texture2D f) where- toU prog l = U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . texture2DBase--instance Uniform (Texture3D f) where- toU prog l = U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . texture3DBase--instance Uniform (Cubemap f) where- toU prog l = U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . cubemapBase------------------------------------------------------------------------------------- Untuple functions -------------------------------------------------------------unPair :: (a,a) -> [a]-unPair (x,y) = [x,y]--unTriple :: (a,a,a) -> [a]-unTriple (x,y,z) = [x,y,z]--unQuad :: (a,a,a,a) -> [a]-unQuad (x,y,z,w) = [x,y,z,w]
src/Graphics/Luminance/Core/Shader/UniformBlock.hs view
@@ -56,10 +56,6 @@ default sizeOfSTD140 :: (Generic a,GUniformBlock (Rep a)) => proxy a -> Int sizeOfSTD140 _ = gsizeOfSTD140 (Proxy :: Proxy (Rep a)) - paddingSTD140 :: proxy a -> Int- default paddingSTD140 :: (Generic a,GUniformBlock (Rep a)) => proxy a -> Int- paddingSTD140 _ = gpaddingSTD140 (Proxy :: Proxy (Rep a))- peekSTD140 :: (MonadIO m) => Ptr b -> Int -> m a default peekSTD140 :: (Generic a,GUniformBlock (Rep a),MonadIO m) => Ptr b -> Int -> m a peekSTD140 p o = liftIO $ fmap to (gpeekSTD140 p o)@@ -68,6 +64,7 @@ default pokeSTD140 :: (Generic a,GUniformBlock (Rep a),MonadIO m) => Ptr b -> Int -> a -> m () pokeSTD140 p o a = liftIO $ gpokeSTD140 p o (from a) +-- Round 'a' up to a multiple of 'u'. roundUp :: Int -> Int -> Int roundUp u a = a + mod (u - a) u @@ -77,54 +74,47 @@ class GUniformBlock f where galignmentSTD140 :: proxy f -> Int gsizeOfSTD140 :: proxy f -> Int- gpaddingSTD140 :: proxy f -> Int gpeekSTD140 :: (MonadIO m) => Ptr b -> Int -> m (f a) gpokeSTD140 :: (MonadIO m) => Ptr b -> Int -> f a -> m () instance GUniformBlock U1 where galignmentSTD140 _ = 1 gsizeOfSTD140 _ = 0- gpaddingSTD140 _ = 0 gpeekSTD140 _ _ = pure U1 gpokeSTD140 _ _ _ = pure () instance (GUniformBlock f,GUniformBlock g) => GUniformBlock (f :*: g) where galignmentSTD140 _ = galignmentSTD140 (Proxy :: Proxy f) `max` galignmentSTD140 (Proxy :: Proxy g)- gsizeOfSTD140 _ = gsizeOfSTD140 (Proxy :: Proxy f) - gpaddingSTD140 (Proxy :: Proxy f) + gsizeOfSTD140 (Proxy :: Proxy g)- gpaddingSTD140 _ = gsizeOfSTD140 (Proxy :: Proxy (f :*: g)) `rem` 16+ gsizeOfSTD140 _ = roundUp (galignmentSTD140 (Proxy :: Proxy g)) (gsizeOfSTD140 (Proxy :: Proxy f)) + gsizeOfSTD140 (Proxy :: Proxy g) gpeekSTD140 p o = liftIO $ (:*:) <$> gpeekSTD140 p o- <*> gpeekSTD140 p (o + gsizeOfSTD140 (Proxy :: Proxy f) - gpaddingSTD140 (Proxy :: Proxy f))+ <*> gpeekSTD140 p (o + roundUp (galignmentSTD140 (Proxy :: Proxy g)) (gsizeOfSTD140 (Proxy :: Proxy f))) gpokeSTD140 p o (f :*: g) = liftIO $ do gpokeSTD140 p o f- gpokeSTD140 p (o + gsizeOfSTD140 (Proxy :: Proxy f) - gpaddingSTD140 (Proxy :: Proxy f)) g+ gpokeSTD140 p (o + roundUp (galignmentSTD140 (Proxy :: Proxy g)) (gsizeOfSTD140 (Proxy :: Proxy f))) g instance (GUniformBlock f) => GUniformBlock (D1 c f) where galignmentSTD140 _ = galignmentSTD140 (Proxy :: Proxy f) gsizeOfSTD140 _ = gsizeOfSTD140 (Proxy :: Proxy f)- gpaddingSTD140 _ = gpaddingSTD140 (Proxy :: Proxy f) gpeekSTD140 p o = fmap M1 (gpeekSTD140 p o) gpokeSTD140 p o (M1 a) = gpokeSTD140 p o a instance (GUniformBlock f) => GUniformBlock (C1 c f) where- galignmentSTD140 _ = galignmentSTD140 (Proxy :: Proxy f)+ galignmentSTD140 _ = roundUp 16 $ galignmentSTD140 (Proxy :: Proxy f) gsizeOfSTD140 _ = gsizeOfSTD140 (Proxy :: Proxy f)- gpaddingSTD140 _ = gpaddingSTD140 (Proxy :: Proxy f) gpeekSTD140 p o = fmap M1 (gpeekSTD140 p o) gpokeSTD140 p o (M1 a) = gpokeSTD140 p o a instance (GUniformBlock f) => GUniformBlock (S1 c f) where galignmentSTD140 _ = galignmentSTD140 (Proxy :: Proxy f) gsizeOfSTD140 _ = gsizeOfSTD140 (Proxy :: Proxy f)- gpaddingSTD140 _ = gpaddingSTD140 (Proxy :: Proxy f) gpeekSTD140 p o = fmap M1 (gpeekSTD140 p o) gpokeSTD140 p o (M1 a) = gpokeSTD140 p o a instance (UniformBlock c) => GUniformBlock (K1 i c) where galignmentSTD140 _ = alignmentSTD140 (Proxy :: Proxy c) gsizeOfSTD140 _ = sizeOfSTD140 (Proxy :: Proxy c)- gpaddingSTD140 _ = paddingSTD140 (Proxy :: Proxy c) gpeekSTD140 p o = fmap K1 (peekSTD140 p o) gpokeSTD140 p o (K1 a) = pokeSTD140 p o a @@ -135,7 +125,6 @@ isStruct _ = False alignmentSTD140 _ = 4 sizeOfSTD140 _ = 4- paddingSTD140 _ = 0 peekSTD140 p o = liftIO (peekByteOff p o) pokeSTD140 p o a = liftIO (pokeByteOff p o a) @@ -143,7 +132,6 @@ isStruct _ = False alignmentSTD140 _ = 4 sizeOfSTD140 _ = 4- paddingSTD140 _ = 0 peekSTD140 p o = liftIO (peekByteOff p o) pokeSTD140 p o a = liftIO (pokeByteOff p o a) @@ -151,7 +139,6 @@ isStruct _ = False alignmentSTD140 _ = 4 sizeOfSTD140 _ = 4- paddingSTD140 _ = 0 peekSTD140 p o = liftIO (peekByteOff p o) pokeSTD140 p o a = liftIO (pokeByteOff p o a) @@ -159,7 +146,6 @@ isStruct _ = False alignmentSTD140 _ = 4 sizeOfSTD140 _ = 4- paddingSTD140 _ = 0 peekSTD140 p o = liftIO (fmap toBool $ peekByteOff p o) pokeSTD140 p o a = liftIO (pokeByteOff p o $ fromBool a) @@ -167,7 +153,6 @@ isStruct _ = False alignmentSTD140 _ = alignmentSTD140 (Proxy :: Proxy a) * 2 sizeOfSTD140 _ = sizeOfSTD140 (Proxy :: Proxy a) * 2- paddingSTD140 _ = 0 peekSTD140 p o = liftIO (peekByteOff p o) pokeSTD140 p o a = liftIO (pokeByteOff p o a) @@ -175,7 +160,6 @@ isStruct _ = False alignmentSTD140 _ = alignmentSTD140 (Proxy :: Proxy a) * 4 sizeOfSTD140 _ = sizeOfSTD140 (Proxy :: Proxy a) * 4- paddingSTD140 _ = sizeOfSTD140 (Proxy :: Proxy a) peekSTD140 p o = liftIO (peekByteOff p o) pokeSTD140 p o a = liftIO (pokeByteOff p o a) @@ -183,7 +167,6 @@ isStruct _ = False alignmentSTD140 _ = alignmentSTD140 (Proxy :: Proxy a) * 4 sizeOfSTD140 _ = sizeOfSTD140 (Proxy :: Proxy a) * 4- paddingSTD140 _ = 0 peekSTD140 p o = liftIO (peekByteOff p o) pokeSTD140 p o a = liftIO (pokeByteOff p o a)
src/Graphics/Luminance/Core/Texture.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -22,7 +23,10 @@ import Foreign.Marshal.Utils ( with ) import Foreign.Storable ( Storable(peek) ) import Graphics.GL+#ifdef __GL_BINDLESS_TEXTURES import Graphics.GL.Ext.ARB.BindlessTexture+#endif+import Graphics.Luminance.Core.Debug import Numeric.Natural ( Natural ) ----------------------------------------------------------------------------------------------------@@ -122,11 +126,16 @@ -> IO () -- OpenGL texture.+#if defined(__GL45) && defined(__GL_BINDLESS_TEXTURES) data BaseTexture = BaseTexture { baseTextureID :: GLuint , baseTextureHnd :: GLuint64 } deriving (Eq,Show)-+#elif defined(__GL32)+newtype BaseTexture = BaseTexture {+ baseTextureID :: GLuint+ } deriving (Eq,Show)+#endif -- |'createTexture w h levels sampling' a new 'w'*'h' texture with 'levels' levels. The format is -- set through the type.@@ -135,21 +144,38 @@ -> Natural -> Sampling -> m t+#if defined(__GL45) && defined(__GL_BINDLESS_TEXTURES) createTexture size levels sampling = do- (tid,texH) <- liftIO . alloca $ \p -> do- glCreateTextures (textureTypeEnum (Proxy :: Proxy t)) 1 p+ (tid,texH) <- liftIO . alloca $ \p -> do+ debugGL $ glCreateTextures (textureTypeEnum (Proxy :: Proxy t)) 1 p+ tid <- peek p+ textureStorage (Proxy :: Proxy t) tid (fromIntegral levels) size+ debugGL $ glTextureParameteri tid GL_TEXTURE_BASE_LEVEL 0+ debugGL $ glTextureParameteri tid GL_TEXTURE_MAX_LEVEL (fromIntegral levels - 1)+ setTextureSampling tid sampling+ texH <- glGetTextureHandleARB tid + debugGL $ glMakeTextureHandleResidentARB texH+ pure (tid,texH)+ _ <- register $ do+ debugGL $ glMakeTextureHandleNonResidentARB texH+ with tid (glDeleteTextures 1)+ pure $ fromBaseTexture (BaseTexture tid texH) size+#elif defined(__GL32)+createTexture size levels sampling = do+ tid <- liftIO . alloca $ \p -> do+ debugGL $ glGenTextures 1 p tid <- peek p+ debugGL $ glBindTexture target tid+ debugGL $ glTexParameteri target GL_TEXTURE_BASE_LEVEL 0+ debugGL $ glTexParameteri target GL_TEXTURE_MAX_LEVEL (fromIntegral levels - 1)+ setTextureSampling target sampling textureStorage (Proxy :: Proxy t) tid (fromIntegral levels) size- glTextureParameteri tid GL_TEXTURE_BASE_LEVEL 0- glTextureParameteri tid GL_TEXTURE_MAX_LEVEL (fromIntegral levels - 1)- setTextureSampling tid sampling- texH <- glGetTextureHandleARB tid - glMakeTextureHandleResidentARB texH- pure (tid,texH)- _ <- register $ do- glMakeTextureHandleNonResidentARB texH- with tid $ glDeleteTextures 1- pure $ fromBaseTexture (BaseTexture tid texH) size+ pure tid+ _ <- register $ with tid (glDeleteTextures 1)+ pure $ fromBaseTexture (BaseTexture tid) size+ where+ target = textureTypeEnum (Proxy :: Proxy t)+#endif ---------------------------------------------------------------------------------------------------- -- Sampling objects --------------------------------------------------------------------------------@@ -188,24 +214,28 @@ -- Apply a 'Sampling' object for a given type of object (texture, sampler, etc.). setSampling :: (Eq a,Eq b,MonadIO m,Num a,Num b) => (GLenum -> a -> b -> IO ()) -> GLenum -> Sampling -> m ()-setSampling f objID s = liftIO $ do+setSampling f oid s = liftIO $ do -- wraps- f objID GL_TEXTURE_WRAP_S . fromWrap $ samplingWrapS s- f objID GL_TEXTURE_WRAP_T . fromWrap $ samplingWrapT s- f objID GL_TEXTURE_WRAP_R . fromWrap $ samplingWrapR s+ debugGL $ f oid GL_TEXTURE_WRAP_S . fromWrap $ samplingWrapS s+ debugGL $ f oid GL_TEXTURE_WRAP_T . fromWrap $ samplingWrapT s+ debugGL $ f oid GL_TEXTURE_WRAP_R . fromWrap $ samplingWrapR s -- filters- f objID GL_TEXTURE_MIN_FILTER . fromFilter $ samplingMinFilter s- f objID GL_TEXTURE_MAG_FILTER . fromFilter $ samplingMagFilter s+ debugGL $ f oid GL_TEXTURE_MIN_FILTER . fromFilter $ samplingMinFilter s+ debugGL $ f oid GL_TEXTURE_MAG_FILTER . fromFilter $ samplingMagFilter s -- comparison function case samplingCompareFunction s of Just cmpf -> do- f objID GL_TEXTURE_COMPARE_FUNC $ fromCompareFunc cmpf- f objID GL_TEXTURE_COMPARE_MODE GL_COMPARE_REF_TO_TEXTURE+ debugGL $ f oid GL_TEXTURE_COMPARE_FUNC $ fromCompareFunc cmpf+ debugGL $ f oid GL_TEXTURE_COMPARE_MODE GL_COMPARE_REF_TO_TEXTURE Nothing ->- f objID GL_TEXTURE_COMPARE_MODE GL_NONE+ debugGL $ f oid GL_TEXTURE_COMPARE_MODE GL_NONE setTextureSampling :: (MonadIO m) => GLenum -> Sampling -> m ()+#ifdef __GL45 setTextureSampling = setSampling glTextureParameteri+#elif defined(__GL32)+setTextureSampling = setSampling glTexParameteri+#endif setSamplerSampling :: (MonadIO m) => GLenum -> Sampling -> m () setSamplerSampling = setSampling glSamplerParameteri@@ -213,6 +243,7 @@ ---------------------------------------------------------------------------------------------------- -- Samplers ---------------------------------------------------------------------------------------- +{- newtype Sampler = Sampler { samplerID :: GLuint } deriving (Eq,Show) createSampler :: (MonadIO m,MonadResource m)@@ -226,6 +257,7 @@ pure sid _ <- register . with sid $ glDeleteSamplers 1 pure $ Sampler sid+-} ---------------------------------------------------------------------------------------------------- -- Texture operations ------------------------------------------------------------------------------@@ -242,7 +274,11 @@ -> m () uploadSub tex offset size autolvl texels = liftIO $ do transferTexelsSub (Proxy :: Proxy t) tid offset size texels- when autolvl $ glGenerateTextureMipmap tid+#ifdef __GL45+ debugGL . when autolvl $ glGenerateTextureMipmap tid+#elif defined(__GL32)+ debugGL . when autolvl $ glGenerateMipmap (textureTypeEnum (Proxy :: Proxy t))+#endif where tid = baseTextureID (toBaseTexture tex) @@ -256,6 +292,10 @@ -> m () fillSub tex offset size autolvl filling = liftIO $ do fillTextureSub (Proxy :: Proxy t) tid offset size filling- when autolvl $ glGenerateTextureMipmap tid+#ifdef __GL45+ debugGL . when autolvl $ glGenerateTextureMipmap tid+#elif defined(__GL32)+ debugGL . when autolvl $ glGenerateMipmap (textureTypeEnum (Proxy :: Proxy t))+#endif where tid = baseTextureID (toBaseTexture tex)
src/Graphics/Luminance/Core/Texture1D.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -13,9 +14,10 @@ module Graphics.Luminance.Core.Texture1D where +import Data.Foldable ( for_ ) import Data.Proxy ( Proxy(..) ) import Data.Vector.Storable ( unsafeWith )-import Foreign.Ptr ( castPtr )+import Foreign.Ptr ( castPtr, nullPtr ) import Graphics.Luminance.Core.Texture ( BaseTexture(..), Texture(..) ) import Graphics.Luminance.Core.Pixel ( Pixel(..) ) import Graphics.GL@@ -34,15 +36,32 @@ toBaseTexture = texture1DBase textureTypeEnum _ = GL_TEXTURE_1D textureSize = texture1DW+#ifdef __GL45 textureStorage _ tid levels w = glTextureStorage1D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral w)+#elif defined(__GL32)+ textureStorage _ _ levels w = do+ for_ [0..levels-1] $ \lvl -> do+ let divisor = 2 ^ lvl+ glTexImage1D GL_TEXTURE_1D lvl (fromIntegral $ pixelIFormat pf) (fromIntegral w `div` divisor) 0+ (pixelFormat pf) (pixelType pf) nullPtr+ where pf = Proxy :: Proxy f+#endif+#ifdef __GL45 transferTexelsSub _ tid x w texels = unsafeWith texels $ glTextureSubImage1D tid 0 (fromIntegral x) (fromIntegral w) fmt typ . castPtr+#elif defined(__GL32)+ transferTexelsSub _ tid x w texels = do+ glBindTexture GL_TEXTURE_1D tid+ unsafeWith texels $ glTexSubImage1D GL_TEXTURE_1D 0 (fromIntegral x) (fromIntegral w) fmt+ typ . castPtr+#endif where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#ifdef __GL45 fillTextureSub _ tid x w filling = unsafeWith filling $ glClearTexSubImage tid 0 (fromIntegral x) 0 0 (fromIntegral w) 1 1 fmt typ . castPtr@@ -50,3 +69,6 @@ proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#elif defined(__GL32)+ fillTextureSub p tid x w filling = transferTexelsSub p tid x w filling+#endif
src/Graphics/Luminance/Core/Texture1DArray.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -14,9 +15,10 @@ module Graphics.Luminance.Core.Texture1DArray where +import Data.Foldable ( for_ ) import Data.Proxy ( Proxy(..) ) import Data.Vector.Storable ( unsafeWith )-import Foreign.Ptr ( castPtr )+import Foreign.Ptr ( castPtr, nullPtr ) import GHC.TypeLits ( KnownNat, Nat, natVal ) import Graphics.Luminance.Core.Texture ( BaseTexture(..), Texture(..) ) import Graphics.Luminance.Core.Pixel ( Pixel(..) )@@ -38,16 +40,34 @@ toBaseTexture = texture1DArrayBase textureTypeEnum _ = GL_TEXTURE_1D_ARRAY textureSize = texture1DArrayW+#ifdef __GL45 textureStorage _ tid levels w = glTextureStorage2D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral w) (fromIntegral $ natVal (Proxy :: Proxy n))+#elif defined(__GL32)+ textureStorage _ _ levels w = do+ for_ [0..levels-1] $ \lvl -> do+ let divisor = 2 ^ lvl+ glTexImage2D GL_TEXTURE_1D_ARRAY lvl (fromIntegral $ pixelIFormat pf)+ (fromIntegral w `div` divisor) (fromIntegral $ natVal (Proxy :: Proxy n)) 0+ (pixelFormat pf) (pixelType pf) nullPtr+ where pf = Proxy :: Proxy f+#endif+#ifdef __GL45 transferTexelsSub _ tid (layer,x) w texels = unsafeWith texels $ glTextureSubImage2D tid 0 (fromIntegral x) (fromIntegral w) (fromIntegral layer) 1 fmt typ . castPtr+#elif defined(__GL32)+ transferTexelsSub _ tid (layer,x) w texels = do+ glBindTexture GL_TEXTURE_1D_ARRAY tid+ unsafeWith texels $ glTexSubImage2D GL_TEXTURE_1D_ARRAY 0 (fromIntegral x) (fromIntegral w) (fromIntegral layer) 1 fmt+ typ . castPtr+#endif where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#ifdef __GL45 fillTextureSub _ tid (layer,x) w filling = unsafeWith filling $ glClearTexSubImage tid 0 (fromIntegral x) (fromIntegral layer) 0 (fromIntegral w) (fromIntegral $ natVal (Proxy :: Proxy n)) 1 fmt typ . castPtr@@ -55,3 +75,6 @@ proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#elif defined(__GL32)+ fillTextureSub p tid o w filling = transferTexelsSub p tid o w filling+#endif
src/Graphics/Luminance/Core/Texture2D.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -13,12 +14,14 @@ module Graphics.Luminance.Core.Texture2D where +import Data.Foldable ( for_ ) import Data.Proxy ( Proxy(..) ) import Data.Vector.Storable ( unsafeWith )-import Foreign.Ptr ( castPtr )+import Foreign.Ptr ( castPtr, nullPtr ) import Graphics.Luminance.Core.Texture ( BaseTexture(..), Texture(..) ) import Graphics.Luminance.Core.Pixel ( Pixel(..) ) import Graphics.GL+import Graphics.Luminance.Core.Debug import Numeric.Natural ( Natural ) -- |A 2D texture.@@ -35,19 +38,40 @@ toBaseTexture = texture2DBase textureTypeEnum _ = GL_TEXTURE_2D textureSize (Texture2D _ w h) = (w,h)+#if defined(__GL45) textureStorage _ tid levels (w,h) =- glTextureStorage2D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral w) (fromIntegral h)+ debugGL $ glTextureStorage2D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral w) (fromIntegral h)+#elif defined(__GL32)+ textureStorage _ _ levels (w,h) = do+ for_ [0..levels-1] $ \lvl -> do+ let divisor = 2 ^ lvl+ debugGL $ glTexImage2D GL_TEXTURE_2D lvl (fromIntegral $ pixelIFormat pf)+ (fromIntegral w `div` divisor) (fromIntegral h `div` divisor) 0 (pixelFormat pf)+ (pixelType pf) nullPtr+ where pf = Proxy :: Proxy f+#endif+#if defined(__GL45) transferTexelsSub _ tid (x,y) (w,h) texels =- unsafeWith texels $ glTextureSubImage2D tid 0 (fromIntegral x) (fromIntegral y)+ debugGL . unsafeWith texels $ glTextureSubImage2D tid 0 (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) fmt typ . castPtr+#elif defined(__GL32)+ transferTexelsSub _ tid (x,y) (w,h) texels = do+ debugGL $ glBindTexture GL_TEXTURE_2D tid+ debugGL . unsafeWith texels $ glTexSubImage2D GL_TEXTURE_2D 0 (fromIntegral x) (fromIntegral y)+ (fromIntegral w) (fromIntegral h) fmt typ . castPtr+#endif where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#if defined(__GL45) fillTextureSub _ tid (x,y) (w,h) filling =- unsafeWith filling $ glClearTexSubImage tid 0 (fromIntegral x)+ debugGL . unsafeWith filling $ glClearTexSubImage tid 0 (fromIntegral x) (fromIntegral y) 0 (fromIntegral w) (fromIntegral h) 1 fmt typ . castPtr where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#elif defined(__GL32)+ fillTextureSub p tid o w filling = transferTexelsSub p tid o w filling+#endif
src/Graphics/Luminance/Core/Texture2DArray.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -14,9 +15,10 @@ module Graphics.Luminance.Core.Texture2DArray where +import Data.Foldable ( for_ ) import Data.Proxy ( Proxy(..) ) import Data.Vector.Storable ( unsafeWith )-import Foreign.Ptr ( castPtr )+import Foreign.Ptr ( castPtr, nullPtr ) import GHC.TypeLits ( KnownNat, Nat, natVal ) import Graphics.Luminance.Core.Texture ( BaseTexture(..), Texture(..) ) import Graphics.Luminance.Core.Pixel ( Pixel(..) )@@ -39,16 +41,34 @@ toBaseTexture = texture2DArrayBase textureTypeEnum _ = GL_TEXTURE_2D_ARRAY textureSize (Texture2DArray _ w h) = (w,h)+#ifdef __GL45 textureStorage _ tid levels (w,h) = glTextureStorage3D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral w) (fromIntegral h) (fromIntegral $ natVal (Proxy :: Proxy n))+#elif defined(__GL32)+ textureStorage _ _ levels (w,h) = do+ for_ [0..levels-1] $ \lvl -> do+ let divisor = 2 ^ lvl+ glTexImage3D GL_TEXTURE_2D_ARRAY lvl (fromIntegral $ pixelIFormat pf)+ (fromIntegral w `div` divisor) (fromIntegral h `div` divisor)+ (fromIntegral $ natVal (Proxy :: Proxy n)) 0 (pixelFormat pf) (pixelType pf) nullPtr+ where pf = Proxy :: Proxy f+#endif+#ifdef __GL45 transferTexelsSub _ tid (layer,x,y) (w,h) texels = unsafeWith texels $ glTextureSubImage3D tid 0 (fromIntegral x) (fromIntegral y) (fromIntegral layer) (fromIntegral w) (fromIntegral h) 1 fmt typ . castPtr+#elif defined(__GL32)+ transferTexelsSub _ tid (layer,x,y) (w,h) texels = do+ glBindTexture GL_TEXTURE_2D_ARRAY tid+ unsafeWith texels $ glTexSubImage3D GL_TEXTURE_2D_ARRAY 0 (fromIntegral x) (fromIntegral y)+ (fromIntegral layer) (fromIntegral w) (fromIntegral h) 1 fmt typ . castPtr+#endif where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#ifdef __GL45 fillTextureSub _ tid (layer,x,y) (w,h) filling = unsafeWith filling $ glClearTexSubImage tid 0 (fromIntegral x) (fromIntegral y) (fromIntegral layer) (fromIntegral w) (fromIntegral h) (fromIntegral $ natVal (Proxy :: Proxy n)) fmt typ . castPtr@@ -56,3 +76,6 @@ proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#elif defined(__GL32)+ fillTextureSub p tid o w filling = transferTexelsSub p tid o w filling+#endif
src/Graphics/Luminance/Core/Texture3D.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -13,9 +14,10 @@ module Graphics.Luminance.Core.Texture3D where +import Data.Foldable ( for_ ) import Data.Proxy ( Proxy(..) ) import Data.Vector.Storable ( unsafeWith )-import Foreign.Ptr ( castPtr )+import Foreign.Ptr ( castPtr, nullPtr ) import Graphics.Luminance.Core.Texture ( BaseTexture(..), Texture(..) ) import Graphics.Luminance.Core.Pixel ( Pixel(..) ) import Graphics.GL@@ -36,16 +38,34 @@ toBaseTexture = texture3DBase textureTypeEnum _ = GL_TEXTURE_3D textureSize (Texture3D _ w h d) = (w,h,d)+#ifdef __GL45 textureStorage _ tid levels (w,h,d) = glTextureStorage3D tid levels (pixelIFormat (Proxy :: Proxy f)) (fromIntegral w) (fromIntegral h) (fromIntegral d)+#elif defined(__GL32)+ textureStorage _ _ levels (w,h,d) = do+ for_ [0..levels-1] $ \lvl -> do+ let divisor = 2 ^ lvl+ glTexImage3D GL_TEXTURE_3D lvl (fromIntegral $ pixelIFormat pf)+ (fromIntegral w `div` divisor) (fromIntegral h `div` divisor)+ (fromIntegral d `div` divisor) 0 (pixelFormat pf) (pixelType pf) nullPtr+ where pf = Proxy :: Proxy f+#endif+#ifdef __GL45 transferTexelsSub _ tid (x,y,z) (w,h,d) texels = unsafeWith texels $ glTextureSubImage3D tid 0 (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) fmt typ . castPtr+#elif defined(__GL32)+ transferTexelsSub _ tid (x,y,z) (w,h,d) texels = do+ glBindTexture GL_TEXTURE_3D tid+ unsafeWith texels $ glTexSubImage3D GL_TEXTURE_3D 0 (fromIntegral x) (fromIntegral y)+ (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) fmt typ . castPtr+#endif where proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#ifdef __GL45 fillTextureSub _ tid (x,y,z) (w,h,d) filling = unsafeWith filling $ glClearTexSubImage tid 0 (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) fmt typ . castPtr@@ -53,3 +73,6 @@ proxy = Proxy :: Proxy f fmt = pixelFormat proxy typ = pixelType proxy+#elif defined(__GL32)+ fillTextureSub p tid o w filling = transferTexelsSub p tid o w filling+#endif
src/Graphics/Luminance/Core/Vertex.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -16,7 +17,9 @@ module Graphics.Luminance.Core.Vertex ( VertexAttribute(..) , Vertex(..)+#ifdef __GL45 , vertexBindingIndex+#endif , module Linear.V , vec2 , vec3@@ -28,6 +31,9 @@ import Data.Proxy ( Proxy(..) ) import Data.Word ( Word32 ) import Foreign.Storable ( Storable(sizeOf) )+#ifdef __GL32+import Foreign.Ptr ( nullPtr )+#endif import GHC.TypeLits ( KnownNat, natVal ) import Graphics.GL import Graphics.Luminance.Core.Tuple@@ -69,10 +75,16 @@ setFormatV :: (MonadIO m) => GLuint -> GLuint -> GLuint -> proxy v -> m (GLuint,GLuint) instance (KnownNat n,Storable a,VertexAttribute a) => Vertex (V n a) where+#ifdef __GL45 setFormatV vid index offset _ = do glVertexArrayAttribFormat vid index (fromIntegral $ natVal (Proxy :: Proxy n)) (vertexGLType (Proxy :: Proxy a)) GL_FALSE offset glVertexArrayAttribBinding vid index vertexBindingIndex glEnableVertexArrayAttrib vid index+#elif defined(__GL32)+ setFormatV _ index offset _ = do+ glVertexAttribPointer index (fromIntegral $ natVal (Proxy :: Proxy n)) (vertexGLType (Proxy :: Proxy a)) GL_FALSE (fromIntegral offset) nullPtr+ glEnableVertexAttribArray index+#endif pure (succ index,offset + fromIntegral (sizeOf (undefined :: V n a))) instance (Vertex a,Vertex b) => Vertex (a :. b) where@@ -80,6 +92,8 @@ (nextIndex,nextOffset) <- setFormatV vid index offset (Proxy :: Proxy a) setFormatV vid nextIndex nextOffset (Proxy :: Proxy b) +#ifdef __GL45 -- Used to connect vertex attribute to the vertex buffer binding point. Should be 0. vertexBindingIndex :: GLuint vertexBindingIndex = 0+#endif
src/Graphics/Luminance/Shader.hs view
@@ -11,9 +11,7 @@ module Graphics.Luminance.Shader ( module Graphics.Luminance.Shader.Program , module Graphics.Luminance.Shader.Stage- , module Graphics.Luminance.Shader.Uniform ) where import Graphics.Luminance.Shader.Program import Graphics.Luminance.Shader.Stage-import Graphics.Luminance.Shader.Uniform
src/Graphics/Luminance/Shader/Program.hs view
@@ -14,9 +14,16 @@ , programID , createProgram , createProgram_+ -- * Uniform+ , Uniform+ , U+ -- * Uniform block+ , UniformBlock+ , UB(..) -- * Error handling , ProgramError(..) , HasProgramError(..) ) where import Graphics.Luminance.Core.Shader.Program+import Graphics.Luminance.Core.Shader.UniformBlock
src/Graphics/Luminance/Shader/Stage.hs view
@@ -11,13 +11,9 @@ module Graphics.Luminance.Shader.Stage ( -- * Shader stage creation Stage+ , StageType(..) , stageID- , createTessCtrlShader- , createTessEvalShader- , createVertexShader- , createGeometryShader- , createFragmentShader- , createComputeShader+ , createStage -- * Error handling , StageError(..) , HasStageError(..)
− src/Graphics/Luminance/Shader/Uniform.hs
@@ -1,21 +0,0 @@--------------------------------------------------------------------------------- |--- Copyright : (C) 2015 Dimitri Sabadie--- License : BSD3------ Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------module Graphics.Luminance.Shader.Uniform (- -- * Uniform- Uniform- , U- -- * Uniform block- , UniformBlock- , UB(..)- ) where--import Graphics.Luminance.Core.Shader.Uniform-import Graphics.Luminance.Core.Shader.UniformBlock
src/Graphics/Luminance/Texture.hs view
@@ -44,12 +44,10 @@ -- ** Cubemaps , Cubemap , CubeFace(..)- , cubemapW- , cubemapH+ , cubemapSize -- ** Array textures , CubemapArray- , cubemapArrayW- , cubemapArrayH+ , cubemapArraySize ) where import Graphics.Luminance.Core.Cubemap