luminance 0.9.1.2 → 0.10
raw patch · 46 files changed
+333/−345 lines, 46 files
Files
- CHANGELOG.md +13/−0
- luminance.cabal +7/−6
- src/Control/Some.hs +20/−0
- src/Graphics/Luminance.hs +5/−3
- src/Graphics/Luminance/Batch.hs +0/−23
- src/Graphics/Luminance/Blending.hs +1/−1
- src/Graphics/Luminance/Buffer.hs +4/−7
- src/Graphics/Luminance/Cmd.hs +3/−1
- src/Graphics/Luminance/Core/Batch.hs +0/−109
- src/Graphics/Luminance/Core/Blending.hs +1/−1
- src/Graphics/Luminance/Core/Buffer.hs +68/−80
- src/Graphics/Luminance/Core/Cmd.hs +4/−2
- src/Graphics/Luminance/Core/Cubemap.hs +1/−1
- src/Graphics/Luminance/Core/CubemapArray.hs +1/−1
- src/Graphics/Luminance/Core/Debug.hs +1/−1
- src/Graphics/Luminance/Core/Framebuffer.hs +1/−1
- src/Graphics/Luminance/Core/Geometry.hs +9/−9
- src/Graphics/Luminance/Core/Pixel.hs +1/−1
- src/Graphics/Luminance/Core/Query.hs +1/−1
- src/Graphics/Luminance/Core/RW.hs +1/−1
- src/Graphics/Luminance/Core/Region.hs +65/−0
- src/Graphics/Luminance/Core/RenderCmd.hs +7/−20
- src/Graphics/Luminance/Core/Renderbuffer.hs +1/−1
- src/Graphics/Luminance/Core/Shader/Program.hs +45/−40
- src/Graphics/Luminance/Core/Shader/Stage.hs +23/−14
- src/Graphics/Luminance/Core/Shader/UniformBlock.hs +1/−1
- src/Graphics/Luminance/Core/Texture.hs +1/−1
- src/Graphics/Luminance/Core/Texture1D.hs +1/−1
- src/Graphics/Luminance/Core/Texture1DArray.hs +1/−1
- src/Graphics/Luminance/Core/Texture2D.hs +1/−1
- src/Graphics/Luminance/Core/Texture2DArray.hs +1/−1
- src/Graphics/Luminance/Core/Texture3D.hs +1/−1
- src/Graphics/Luminance/Core/Tuple.hs +1/−1
- src/Graphics/Luminance/Core/Vertex.hs +1/−1
- src/Graphics/Luminance/Framebuffer.hs +3/−1
- src/Graphics/Luminance/Geometry.hs +1/−1
- src/Graphics/Luminance/Pixel.hs +1/−1
- src/Graphics/Luminance/Query.hs +1/−1
- src/Graphics/Luminance/RW.hs +1/−1
- src/Graphics/Luminance/Region.hs +21/−0
- src/Graphics/Luminance/RenderCmd.hs +1/−2
- src/Graphics/Luminance/Shader.hs +1/−1
- src/Graphics/Luminance/Shader/Program.hs +8/−1
- src/Graphics/Luminance/Shader/Stage.hs +1/−1
- src/Graphics/Luminance/Texture.hs +1/−1
- src/Graphics/Luminance/Vertex.hs +1/−1
CHANGELOG.md view
@@ -1,3 +1,16 @@+### 0.10++#### Breaking changes++- `Region` was removed in favor of `Buffer`; just a type renaming, don’t freak out.+- Removed batches in favor of `Region`s.+- Removed `Decidable` and `Divisible` instances for `U` as uniforms are not supposed to be used this+ way.++#### Patch changes++- Internal changes to make `createStage` errors more verbose about the type of the stage.+ ### 0.9.1.2 - Support for `contravariant-1.4`.
luminance.cabal view
@@ -1,5 +1,5 @@ name: luminance-version: 0.9.1.2+version: 0.10 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@@ -72,8 +72,8 @@ if flag(gl33) cpp-options: -D__GL33 - exposed-modules: Graphics.Luminance- , Graphics.Luminance.Batch+ exposed-modules: Control.Some+ , Graphics.Luminance , Graphics.Luminance.Blending , Graphics.Luminance.Buffer , Graphics.Luminance.Cmd@@ -82,16 +82,16 @@ , Graphics.Luminance.Geometry , Graphics.Luminance.Pixel , Graphics.Luminance.Query- , Graphics.Luminance.RW+ , Graphics.Luminance.Region , Graphics.Luminance.RenderCmd+ , Graphics.Luminance.RW , Graphics.Luminance.Shader , Graphics.Luminance.Shader.Program , Graphics.Luminance.Shader.Stage , Graphics.Luminance.Texture , Graphics.Luminance.Vertex - other-modules: Graphics.Luminance.Core.Batch- , Graphics.Luminance.Core.Blending+ other-modules: Graphics.Luminance.Core.Blending , Graphics.Luminance.Core.Buffer , Graphics.Luminance.Core.Cmd , Graphics.Luminance.Core.Cubemap@@ -101,6 +101,7 @@ , Graphics.Luminance.Core.Geometry , Graphics.Luminance.Core.Pixel , Graphics.Luminance.Core.Query+ , Graphics.Luminance.Core.Region , Graphics.Luminance.Core.RenderCmd , Graphics.Luminance.Core.Renderbuffer , Graphics.Luminance.Core.RW
+ src/Control/Some.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015, 2016 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+----------------------------------------------------------------------------++module Control.Some (+ -- * Free existential quantification+ Some(..)+ ) where++data Some :: (k -> *) -> * where+ Some :: f a -> Some f
src/Graphics/Luminance.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -299,7 +299,7 @@ ----------------------------------------------------------------------- module Graphics.Luminance (- module Graphics.Luminance.Batch+ module Control.Some , module Graphics.Luminance.Blending , module Graphics.Luminance.Buffer , module Graphics.Luminance.Cmd@@ -308,6 +308,7 @@ , module Graphics.Luminance.Geometry , module Graphics.Luminance.Pixel , module Graphics.Luminance.Query+ , module Graphics.Luminance.Region , module Graphics.Luminance.RenderCmd , module Graphics.Luminance.RW , module Graphics.Luminance.Shader@@ -315,7 +316,7 @@ , module Graphics.Luminance.Vertex ) where -import Graphics.Luminance.Batch+import Control.Some import Graphics.Luminance.Blending import Graphics.Luminance.Buffer import Graphics.Luminance.Cmd@@ -324,6 +325,7 @@ import Graphics.Luminance.Geometry import Graphics.Luminance.Pixel import Graphics.Luminance.Query+import Graphics.Luminance.Region import Graphics.Luminance.RenderCmd import Graphics.Luminance.RW import Graphics.Luminance.Shader
− src/Graphics/Luminance/Batch.hs
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Copyright : (C) 2015 Dimitri Sabadie--- License : BSD3------ Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>--- Stability : experimental--- Portability : portable--------------------------------------------------------------------------------module Graphics.Luminance.Batch (- -- * Framebuffer batch- FBBatch- , framebufferBatch- -- * Shader program batch- , SPBatch- , AnySPBatch- , anySPBatch- , shaderProgramBatch- , shaderProgramBatch_- ) where--import Graphics.Luminance.Core.Batch
src/Graphics/Luminance/Blending.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Buffer.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -10,15 +10,12 @@ module Graphics.Luminance.Buffer ( -- * Buffer creation- Buffer- , bufferID- , createBuffer- , createBuffer_+ createBuffer -- * Buffer access , BufferRW -- * Buffer regions- , Region- , BuildRegion+ , Buffer + , BuildBuffer , newRegion -- * Operations on buffer regions , readWhole
src/Graphics/Luminance/Cmd.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -9,12 +9,14 @@ ----------------------------------------------------------------------------- module Graphics.Luminance.Cmd (+ {- -- * Command type Cmd , runCmd -- * Available commands , draw , blit+ -} ) where import Graphics.Luminance.Core.Cmd
− src/Graphics/Luminance/Core/Batch.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}---------------------------------------------------------------------------------- |--- Copyright : (C) 2015 Dimitri Sabadie--- License : BSD3------ Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>--- Stability : experimental--- Portability : portable--------------------------------------------------------------------------------module Graphics.Luminance.Core.Batch where--import Control.Monad.IO.Class ( MonadIO(..) )-import Data.Bits-import Data.Foldable ( traverse_ )-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(..), U(..) )-import Graphics.Luminance.Core.RenderCmd ( RenderCmd(..) )------------------------------------------------------------------------------------- Framebuffer batch --------------------------------------------------------------- |'Framebuffer' batch.------ A 'FBBatch' is used to expose a 'Framebuffer' and share it between several shader program--- batches.-data FBBatch rw c d = FBBatch {- fbBatchFramebuffer :: Framebuffer rw c d- , fbBatchSPBatch :: [AnySPBatch rw c d]- }---- |Run a 'FBBatch'.-runFBBatch :: (MonadIO m) => FBBatch rw c d -> m ()-runFBBatch (FBBatch fb spbs) = do- 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.-framebufferBatch :: Framebuffer rw c d -> [AnySPBatch rw c d] -> FBBatch rw c d-framebufferBatch = FBBatch------------------------------------------------------------------------------------- Shader program batch ------------------------------------------------------------ |Shader 'Program' batch.------ Such a batch is used to share a 'Program' between several 'RenderCmd'. It also--- gathers a uniform @'U' u@ and a 'u' value to send to the uniform.------ The 'u' type can be used to send uniforms for the whole batch. It can be useful--- for cold values – that won’t change very often for a given frame – like the resolution of the--- screen, the mouse cursor coordinates, the time, and so on and so forth.------ The 'v' type variable is used to add uniforms per-'RenderCmd'.-data SPBatch rw c d u v = SPBatch {- spBatchShaderProgram :: Program- , spBatchUniform :: U u- , spBatchUniformValue :: u- , spBatchGeometries :: [RenderCmd rw c d v Geometry]- }---- |Abstract 'SPBatch' over uniform interface.-data AnySPBatch rw c d = forall u v. AnySPBatch (SPBatch rw c d u v)---- FIXME: should we call this function 'abstractSPBatch'?--- |Abstract 'SPBatch'.-anySPBatch :: SPBatch rw c d u v -> AnySPBatch rw c d-anySPBatch = AnySPBatch---- Run a 'SPBatch' in 'MonadIO'.-runSPBatch :: (MonadIO m) => SPBatch rw c d u v -> m ()-runSPBatch (SPBatch prog uni u geometries) = do- liftIO $ do- debugGL $ glUseProgram (programID prog)- runU uni u- traverse_ drawGeometry geometries---- |Create a new 'SPBatch'.-shaderProgramBatch :: Program -> U u -> u -> [RenderCmd rw c d v Geometry] -> SPBatch rw c d u v-shaderProgramBatch = SPBatch---- |Create a new 'SPBatch' with no uniform interface.-shaderProgramBatch_ :: Program -> [RenderCmd rw c d v Geometry] -> SPBatch rw c d () v-shaderProgramBatch_ p = SPBatch p mempty ()------------------------------------------------------------------------------------- Geometry draw function ---------------------------------------------------------- Draw the 'Geometry' held by a 'RenderCmd'.-drawGeometry :: (MonadIO m) => RenderCmd rw c d u Geometry -> m ()-drawGeometry (RenderCmd blending depthTest uni u geometry) = do- setBlending blending- (if depthTest then glEnable else glDisable) GL_DEPTH_TEST- liftIO (runU uni u)- case geometry of- DirectGeometry (VertexArray vid mode vbNb) -> do- debugGL $ glBindVertexArray vid- debugGL $ glDrawArrays mode 0 vbNb- IndexedGeometry (VertexArray vid mode ixNb) -> do- debugGL $ glBindVertexArray vid- debugGL $ glDrawElements mode ixNb GL_UNSIGNED_INT nullPtr
src/Graphics/Luminance/Core/Blending.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Buffer.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -32,16 +32,11 @@ import Graphics.GL import Graphics.Luminance.Core.RW --- |A 'Buffer' is an opaque and untyped region of abstract GPU memory. You cannot do much with it--- and you might even not see the type in the user interface as it’s not really needed. It’s shown--- for informational purposes only.-newtype Buffer = Buffer { bufferID :: GLuint } deriving (Eq,Show)---- Create a new 'Buffer' and return its GPU address by mapping it to a @Ptr ()@.+-- Create a new bufferand return its GPU address by mapping it to a @Ptr ()@. mkBuffer :: (MonadIO m,MonadResource m) => GLbitfield -> Int- -> m (Buffer,Ptr ())+ -> m (GLuint,Ptr ()) #ifdef __GL45 mkBuffer flags size = do (bid,mapped) <- liftIO . alloca $ \p -> do@@ -50,7 +45,7 @@ mapped <- createStorage bid flags size pure (bid,mapped) _ <- register . with bid $ glDeleteBuffers 1- pure (Buffer bid,mapped)+ pure (bid,mapped) #elif defined(__GL33) mkBuffer flags size = do (bid,mapped) <- liftIO . alloca $ \p -> do@@ -59,7 +54,7 @@ mapped <- createStorage bid flags size pure (bid,mapped) _ <- register . with bid $ glDeleteBuffers 1- pure (Buffer bid,mapped)+ pure (bid,mapped) #endif -- Create the required OpenGL storage for a 'Buffer'.@@ -80,22 +75,22 @@ 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'.+-- Create a new buffer using regions through the 'BuildBuffer monadic type. The buffer is+-- returned as well as the computed 'a' value in the 'BuildBuffer. ----- Typically, the user will wrap the 'Region' in the 'a' type.+-- Typically, the user will wrap the 'Buffer' in the 'a' type. mkBufferWithRegions :: (MonadIO m,MonadResource m) => GLbitfield- -> BuildRegion rw a- -> m (a,Buffer)+ -> BuildBuffer rw a+ -> m (a,GLuint) mkBufferWithRegions flags buildRegions = do (buffer,mapped) <- mkBuffer flags bytes pure (fst $ evalRWS built (buffer,mapped) 0,buffer) where- built = runBuildRegion buildRegions- (bytes,_) = execRWS built (Buffer 0,nullPtr) 0+ built = runBuildBuffer buildRegions+ (bytes,_) = execRWS built (0,nullPtr) 0 --- |'Buffer'’s 'Region's can have reads and writes. That typeclass makes implements all possible+-- |'Buffer's can have reads and writes. That typeclass makes implements all possible -- cases. class BufferRW rw where bufferFlagsFromRW :: proxy rw -> GLenum@@ -109,20 +104,13 @@ instance BufferRW W where bufferFlagsFromRW _ = GL_MAP_WRITE_BIT --- |Create a new 'Buffer' and expose 'Region's. Through the 'BuildRegion' type, you can yield new--- regions and embed them in the type of your choice. The function returns that type.+-- |Create a new 'Buffer'. Through the 'BuildBuild type, you can yield new regions and embed them+-- in the type of your choice. The function returns that type. createBuffer :: forall a m rw. (BufferRW rw,MonadIO m,MonadResource m)- => BuildRegion rw a+ => BuildBuffer rw a -> m a 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 (Proxy :: Proxy rw) .|. persistentCoherentBits- persistentCoherentBits :: GLbitfield #ifdef __GL45 persistentCoherentBits = GL_MAP_PERSISTENT_BIT .|. GL_MAP_COHERENT_BIT@@ -130,117 +118,117 @@ persistentCoherentBits = 0 #endif --- |A 'Region' is a GPU typed memory area. It can be pictured as a GPU array.+-- |A 'Buffer' 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+data Buffer rw a = Buffer {+ bufferPtr :: Ptr a -- mapped pointer (into GPU memory)+ , bufferOffset :: Int -- offset in the memory of the buffer+ , bufferSize :: Int -- number of elements living in that region+ , bufferID :: GLuint -- OpenGL buffer the region lays in } deriving (Eq,Show) #elif defined(__GL33) -- 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+data Buffer rw a = Buffer {+ bufferOffset :: Int -- offset in the memory of the buffer+ , bufferSize :: Int -- number of elements living in that region+ , bufferID :: GLuint -- buffer the region lays in } deriving (Eq,Show) #endif --- |Convenient type to build 'Region's.-newtype BuildRegion rw a = BuildRegion {- runBuildRegion :: RWS (Buffer,Ptr ()) () Int a+-- |Convenient type to build 'Buffer's.+newtype BuildBuffer rw a = BuildBuffer {+ runBuildBuffer :: RWS (GLuint,Ptr ()) () Int a } deriving (Applicative,Functor,Monad) --- |Create a new 'Region' by providing the number of wished elements.-newRegion :: forall rw a. (Storable a) => Word32 -> BuildRegion rw (Region rw a)-newRegion size = BuildRegion $ do+-- |Create a new 'Buffer' by providing the number of wished elements.+newRegion :: forall rw a. (Storable a) => Word32 -> BuildBuffer rw (Buffer rw a)+newRegion size = BuildBuffer $ do offset <- get put $ offset + fromIntegral size * sizeOf (undefined :: a) #ifdef __GL45 (buffer,ptr) <- ask- pure $ Region {- regionPtr = (castPtr $ ptr `plusPtr` fromIntegral offset)- , regionOffset = offset- , regionSize = fromIntegral size- , regionBuffer = buffer+ pure $ Buffer {+ bufferPtr = (castPtr $ ptr `plusPtr` fromIntegral offset)+ , bufferOffset = offset+ , bufferSize = fromIntegral size+ , bufferID = buffer } #elif defined(__GL33) (buffer,_) <- ask- pure $ Region {- regionOffset = offset- , regionSize = fromIntegral size- , regionBuffer = buffer+ pure $ Buffer {+ bufferOffset = offset+ , bufferSize = fromIntegral size+ , bufferID = buffer } #endif --- |Read a whole 'Region'.-readWhole :: (MonadIO m,Readable r,Storable a) => Region r a -> m [a]+-- |Read a whole 'Buffer'.+readWhole :: (MonadIO m,Readable r,Storable a) => Buffer r a -> m [a] #ifdef __GL45 readWhole r = liftIO $ peekArray (regionSize r) (regionPtr r) #elif defined(__GL33) 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)+ glBindBuffer GL_ARRAY_BUFFER (bufferID r)+ p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ bufferOffset r) (fromIntegral $ bufferSize r) GL_MAP_READ_BIT+ a <- peekArray (bufferSize 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.+-- |Write the whole 'Buffer'. If values are missing, only the provided values will replace the+-- existing ones. If there are more values than the size of the 'Buffer', they are ignored. writeWhole :: (Foldable f,MonadIO m,Storable a,Writable w)- => Region w a+ => Buffer w a -> f a -> m () #ifdef __GL45 writeWhole r values = liftIO . pokeArray (regionPtr r) . take (regionSize r) $ toList values #elif defined(__GL33) 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+ glBindBuffer GL_ARRAY_BUFFER (bufferID r)+ p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ bufferOffset r) (fromIntegral $ bufferSize r) GL_MAP_WRITE_BIT+ pokeArray (castPtr p) . take (bufferSize 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 = writeWhole r (replicate (regionSize r) a)+-- |Fill a 'Buffer' with a value.+fill :: (MonadIO m,Storable a,Writable w) => Buffer w a -> a -> m ()+fill r a = writeWhole r (replicate (bufferSize 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)+(@?) :: (MonadIO m,Storable a,Readable r) => Buffer r a -> Word32 -> m (Maybe a) r @? i- | i >= fromIntegral (regionSize r) = pure Nothing+ | i >= fromIntegral (bufferSize r) = pure Nothing | otherwise = fmap Just (r @! i) -- |Index getter. Unsafe version of '(@?)'.-(@!) :: (MonadIO m,Storable a,Readable r) => Region r a -> Word32 -> m a+(@!) :: (MonadIO m,Storable a,Readable r) => Buffer r a -> Word32 -> m a #ifdef __GL45-r @! i = liftIO $ peekElemOff (regionPtr r) (fromIntegral i)+r @! i = liftIO $ peekElemOff (bufferPtr r) (fromIntegral i) #elif defined(__GL33) 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+ glBindBuffer GL_ARRAY_BUFFER (bufferID r)+ p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ bufferOffset r) (fromIntegral $ bufferSize 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 :: (MonadIO m,Storable a,Writable w) => Buffer w a -> Word32 -> a -> m () writeAt r i a- | i >= fromIntegral (regionSize r) = pure ()+ | i >= fromIntegral (bufferSize r) = pure () | otherwise = writeAt' r i a --- |Index setter. Unsafe version of 'writeAt''.-writeAt' :: (MonadIO m,Storable a,Writable w) => Region w a -> Word32 -> a -> m ()+-- |Index setter. Unsafe version of 'writeAt'.+writeAt' :: (MonadIO m,Storable a,Writable w) => Buffer w a -> Word32 -> a -> m () #ifdef __GL45-writeAt' r i a = liftIO $ pokeElemOff (regionPtr r) (fromIntegral i) a+writeAt' r i a = liftIO $ pokeElemOff (bufferPtr r) (fromIntegral i) a #elif defined(__GL33) 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+ glBindBuffer GL_ARRAY_BUFFER (bufferID r)+ p <- glMapBufferRange GL_ARRAY_BUFFER (fromIntegral $ bufferOffset r) (fromIntegral $ bufferSize r) GL_MAP_WRITE_BIT pokeElemOff (castPtr p) (fromIntegral i) a () <$ glUnmapBuffer GL_ARRAY_BUFFER #endif
src/Graphics/Luminance/Core/Cmd.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -13,12 +13,12 @@ module Graphics.Luminance.Core.Cmd where import Control.Monad.IO.Class ( MonadIO(..) )-import Graphics.Luminance.Core.Batch import Graphics.Luminance.Core.Framebuffer import Graphics.Luminance.Core.RW ( Readable, Writable ) import Graphics.Luminance.Core.Texture ( Filter ) import Numeric.Natural ( Natural ) +{- -- |Command type. Used to accumulate GPU commands. Use 'runCmd' to execute -- the whole chain of commands. newtype Cmd a = Cmd (IO a) deriving (Applicative,Functor,Monad)@@ -51,3 +51,5 @@ blit r w rx ry rwidth rheight wx wy wwidth wheight mask flt = Cmd $ do framebufferBlit r w rx ry rwidth rheight wx wy wwidth wheight mask flt pure (framebufferOutput w)++-}
src/Graphics/Luminance/Core/Cubemap.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/CubemapArray.hs view
@@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Debug.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Framebuffer.hs view
@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Geometry.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -86,17 +86,17 @@ peek p _ <- register . with vid $ glDeleteVertexArrays 1 -- vertex buffer- (vreg :: Region W v,vbo) <- createBuffer_ $ newRegion (fromIntegral vertNb)+ vreg :: Buffer W v <- createBuffer $ newRegion (fromIntegral vertNb) writeWhole vreg vertices- liftIO $ glVertexArrayVertexBuffer vid vertexBindingIndex (bufferID vbo) 0 (fromIntegral $ sizeOf (undefined :: v))+ liftIO $ glVertexArrayVertexBuffer vid vertexBindingIndex (bufferID reg) 0 (fromIntegral $ sizeOf (undefined :: v)) _ <- 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)+ ireg :: Buffer W Word32 <- createBuffer $ newRegion (fromIntegral ixNb) writeWhole ireg indices'- glVertexArrayElementBuffer vid (bufferID ibo)+ glVertexArrayElementBuffer vid (bufferID ireg) pure . IndexedGeometry $ VertexArray vid mode' (fromIntegral ixNb) Nothing -> pure . DirectGeometry $ VertexArray vid mode' (fromIntegral vertNb) where@@ -111,17 +111,17 @@ _ <- register . with vid $ glDeleteVertexArrays 1 glBindVertexArray vid -- vertex buffer- (vreg :: Region W v,vbo) <- createBuffer_ $ newRegion (fromIntegral vertNb)+ vreg :: Buffer W v <- createBuffer $ newRegion (fromIntegral vertNb) writeWhole vreg vertices- liftIO $ glBindBuffer GL_ARRAY_BUFFER (bufferID vbo)+ liftIO $ glBindBuffer GL_ARRAY_BUFFER (bufferID vreg) _ <- 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)+ ireg :: Buffer W Word32 <- createBuffer $ newRegion (fromIntegral ixNb) writeWhole ireg indices'- glBindBuffer GL_ELEMENT_ARRAY_BUFFER(bufferID ibo)+ glBindBuffer GL_ELEMENT_ARRAY_BUFFER (bufferID ireg) glBindVertexArray 0 pure . IndexedGeometry $ VertexArray vid mode' (fromIntegral ixNb) Nothing -> do
src/Graphics/Luminance/Core/Pixel.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Query.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/RW.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
+ src/Graphics/Luminance/Core/Region.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015, 2016 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------++module Graphics.Luminance.Core.Region where++import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Trans ( MonadTrans(..) )+import Control.Some ( Some(..) )+import Data.Bits+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.RenderCmd ( RenderCmd(..) )++-- |A 'Region' is a monad transformer used to create relationships between two monadic layers+-- and ensure GPU safety.+newtype Region r m a = Region { runRegion :: m a } deriving (Applicative,Functor,Monad,MonadIO)++instance MonadTrans (Region r) where+ lift = Region++-- |The /GPU/ main 'Region'. This 'Region' is the highest and more general you can find. You’ll need+-- to enter it if you want to enter any /GPU/ specific regions.+gpuRegion :: Region () m a -> m a+gpuRegion = runRegion++-- |The 'Framebuffer' 'Region'. This 'Region' binds a 'Framebuffer' for all children regions.+newFrame :: (MonadIO m) => Framebuffer rw c d -> Region Framebuffer m a -> Region () m a+newFrame fb fbRegion = do+ liftIO . debugGL $ glBindFramebuffer GL_DRAW_FRAMEBUFFER (fromIntegral $ framebufferID fb)+ liftIO . debugGL $ glClear $ GL_DEPTH_BUFFER_BIT .|. GL_COLOR_BUFFER_BIT+ lift (runRegion fbRegion)++-- |The 'Program' 'Region'. This 'Region' binds a 'Program' for all children regions.+newShading :: (MonadIO m) => Some Program -> Region Program m a -> Region Framebuffer m a+newShading (Some prog) progRegion = do+ liftIO . debugGL $ glUseProgram (programID prog)+ lift (runRegion progRegion)++-- |Draw the 'Geometry' held by a 'RenderCmd'.+drawGeometry :: (MonadIO m) => RenderCmd rw c d Geometry -> Region Program m ()+drawGeometry (RenderCmd blending depthTest geometry) = do+ setBlending blending+ (if depthTest then glEnable else glDisable) GL_DEPTH_TEST+ case geometry of+ DirectGeometry (VertexArray vid mode vbNb) -> do+ debugGL $ glBindVertexArray vid+ debugGL $ glDrawArrays mode 0 vbNb+ IndexedGeometry (VertexArray vid mode ixNb) -> do+ debugGL $ glBindVertexArray vid+ debugGL $ glDrawElements mode ixNb GL_UNSIGNED_INT nullPtr
src/Graphics/Luminance/Core/RenderCmd.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -11,7 +11,6 @@ module Graphics.Luminance.Core.RenderCmd where import Graphics.Luminance.Core.Blending-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?@@ -25,36 +24,24 @@ -- to pass @'Just' (mode,srcK,dstK)@, where @mode@ is the 'BlendingMode' and @srcK@ and @dstK@ -- are both 'BlendingFactor' representing the source and destination factors. -- - /depth test/: the depth test can be enabled by passing 'True' and disabled with 'False'.--- - a /per draw command uniform interface and uniform value/: that is the way you can customize--- the draw calls. You just have to pass the uniform interface and the value to send down to the--- shader. -- -- Finally, a 'RenderCmd' holds a value. That value will be consumed later by other functions. In -- general, it’ll be 'Geometry'.-data RenderCmd rw c d u a = RenderCmd (Maybe (BlendingMode,BlendingFactor,BlendingFactor)) Bool (U u) u a+data RenderCmd rw c d a = RenderCmd (Maybe (BlendingMode,BlendingFactor,BlendingFactor)) Bool a -instance Functor (RenderCmd rw c d u) where- fmap f (RenderCmd blending depthTest uni u a) = RenderCmd blending depthTest uni u (f a)+instance Functor (RenderCmd rw c d) where+ fmap f (RenderCmd blending depthTest a) = RenderCmd blending depthTest (f a) --- |@'renderCmd' blending depthTest uniformInterface u a@ constructs a new 'RenderCmd'.+-- |@'renderCmd' blending depthTest a@ constructs a new 'RenderCmd'. renderCmd :: Maybe (BlendingMode,BlendingFactor,BlendingFactor) -> Bool- -> U u- -> u -> a - -> RenderCmd rw c d u a+ -> RenderCmd rw c d a renderCmd = RenderCmd -- |A standard 'RenderCmd' builder. -- -- - no /blending/ -- - /depth test/ enabled-stdRenderCmd :: U u -> u -> a -> RenderCmd rw c d u a+stdRenderCmd :: a -> RenderCmd rw c d a stdRenderCmd = RenderCmd Nothing True---- |A standard 'RenderCmd' builder with no uniform interface.------ - no /blending/--- - /depth test/ enabled-stdRenderCmd_ :: a -> RenderCmd rw c d () a-stdRenderCmd_ = stdRenderCmd mempty ()
src/Graphics/Luminance/Core/Renderbuffer.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Shader/Program.hs view
@@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -28,11 +28,9 @@ import Control.Monad.Trans.State ( StateT, evalStateT, gets, modify ) 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 )@@ -40,7 +38,7 @@ 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.Buffer ( Buffer(..), bufferID ) import Graphics.Luminance.Core.Debug import Graphics.Luminance.Core.Cubemap ( Cubemap(..) ) import Graphics.Luminance.Core.Pixel ( Pixel )@@ -62,7 +60,10 @@ -- Shader program -------------------------------------------------------------- -- |Shader program.-newtype Program = Program { programID :: GLuint } deriving (Eq,Show)+data Program u = Program {+ programID :: GLuint+ , programInterface :: u+ } deriving (Eq,Show) -- |Create a new shader 'Program'. --@@ -78,7 +79,7 @@ createProgram :: (HasProgramError e,MonadError e m,MonadIO m,MonadResource m) => [Stage] -> ((forall a. UniformName a -> UniformInterface m (U a)) -> UniformInterface m i)- -> m (Program,i)+ -> m (Program i) createProgram stages buildIface = do (pid,linked,cl) <- liftIO $ do pid <- debugGL glCreateProgram@@ -92,16 +93,15 @@ liftIO (glDeleteProgram pid) throwError . fromProgramError $ LinkFailed cl _ <- register $ glDeleteProgram pid- let prog = Program pid- a <- runUniformInterface $ buildIface (uniformize prog)- pure (prog,a)+ a <- runUniformInterface $ buildIface (uniformize pid)+ pure (Program pid a) -- |A simpler version of 'createProgram'. That function assumes you don’t need a uniform interface -- and then just returns the 'Program'. createProgram_ :: (HasProgramError e,MonadError e m,MonadIO m,MonadResource m) => [Stage]- -> m Program-createProgram_ stages = fmap fst $ createProgram stages (\_ -> pure ())+ -> m (Program ())+createProgram_ stages = createProgram stages (\_ -> pure ()) -- |Is a shader program linked? isLinked :: GLuint -> IO Bool@@ -151,7 +151,7 @@ data UniformName :: * -> * where UniformName :: (Uniform a) => String -> UniformName a UniformSemantic :: (Uniform a) => Natural -> UniformName a- UniformBlockName :: (UniformBlock a) => String -> UniformName (Region rw (UB a))+ UniformBlockName :: (UniformBlock a) => String -> UniformName (Buffer rw (UB a)) -- |A uniform name with type-erasure. You can only access the constructors and the carried name but -- you can’t reconstruct the phantom type.@@ -171,10 +171,10 @@ -- |A way to get several kind of uniforms through a single interface. uniformize :: (HasProgramError e,MonadError e m,MonadIO m)- => Program+ => GLuint -> UniformName a -> UniformInterface m (U a)-uniformize program@Program{programID = pid} getter = UniformInterface $ case getter of+uniformize pid getter = UniformInterface $ case getter of UniformName name -> do location <- liftIO . debugGL . withCString name $ glGetUniformLocation pid when (location == -1) . throwError . fromProgramError $ InactiveUniform (SomeUniformName getter)@@ -182,15 +182,15 @@ UniformSemantic sem -> do when (sem == -1) . throwError . fromProgramError $ InactiveUniform (SomeUniformName getter) runUniformInterface' (toU pid $ fromIntegral sem)- UniformBlockName name -> runUniformInterface (uniformizeBlock program name $ InactiveUniform (SomeUniformName getter))+ UniformBlockName name -> runUniformInterface (uniformizeBlock pid name $ InactiveUniform (SomeUniformName getter)) -- |Map a 'String' to a uniform block. uniformizeBlock :: forall a e m rw. (HasProgramError e,MonadError e m,MonadIO m,UniformBlock a)- => Program+ => GLuint -> String -> ProgramError- -> UniformInterface m (U (Region rw (UB a)))-uniformizeBlock Program{programID = pid} name onError = UniformInterface $ do+ -> UniformInterface m (U (Buffer rw (UB a)))+uniformizeBlock pid name onError = UniformInterface $ do index <- liftIO . debugGL . withCString name $ glGetUniformBlockIndex pid when (index == GL_INVALID_INDEX) (throwError $ fromProgramError onError) -- retrieve a new binding value and use it@@ -201,9 +201,9 @@ debugGL $ glBindBufferRange GL_UNIFORM_BUFFER binding- (bufferID $ regionBuffer r)- (fromIntegral $ regionOffset r)- (fromIntegral $ regionSize r * sizeOfSTD140 (Proxy :: Proxy a))+ (bufferID r)+ (fromIntegral $ bufferOffset r)+ (fromIntegral $ bufferSize r * sizeOfSTD140 (Proxy :: Proxy a)) #if !defined(__GL_BINDLESS_TEXTURES) nextTextureUnit :: (Monad m) => UniformInterface m GLuint@@ -213,6 +213,18 @@ pure texUnit #endif +-- |Update uniforms in a program. That function enables you to update only the uniforms you want+-- and not the whole.+--+-- If you want to update several uniforms (not only one), you can use the 'Semigroup'/'Monoid'+-- instances (use '(<>)' or 'sconcat'/'mconcat' for instance).+updateUniforms :: (MonadIO m) => Program a -> (a -> U') -> m ()+updateUniforms prog f = do+#ifdef __GL33+ glUseProgram (programID prog)+#endif+ liftIO . runU' . f $ programInterface prog+ -------------------------------------------------------------------------------- -- Uniform --------------------------------------------------------------------- @@ -220,38 +232,31 @@ -- 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.+-- interesting uniform types. -- -- 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 ('()').+-- 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+newtype U' = U' { runU' :: IO () } -instance Monoid (U a) where- mempty = U . const $ pure ()+instance Monoid U' where+ mempty = U' $ pure () mappend = (<>) -instance Semigroup (U a) where- u <> v = U $ \a -> runU u a >> runU v a+instance Semigroup U' where+ a <> b = U' $ runU' a >> runU' b +-- |Feed @'U' a@ with a value.+(.=) :: U a -> a -> U'+u .= a = U' (runU u 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.@@ -264,7 +269,7 @@ -- Unit instance --------------------------------------------------------------- instance Uniform () where- toU _ _ = pure mempty+ toU _ _ = pure . U . const $ pure () -------------------------------------------------------------------------------- -- Int32 instances -------------------------------------------------------------
src/Graphics/Luminance/Core/Shader/Stage.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -42,6 +42,14 @@ | FragmentShader deriving (Eq,Show) +fromStageType :: StageType -> GLenum+fromStageType st = case st of+ TessControlShader -> GL_TESS_CONTROL_SHADER+ TessEvaluationShader -> GL_TESS_EVALUATION_SHADER+ VertexShader -> GL_VERTEX_SHADER+ GeometryShader -> GL_GEOMETRY_SHADER+ FragmentShader -> GL_FRAGMENT_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@@ -50,26 +58,27 @@ => 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+createStage stageType src = do+ -- check whether we can create such a stage+ case stageType of+ TessControlShader -> checkTessSupport+ TessEvaluationShader -> checkTessSupport+ _ -> pure ()+ mkShader stageType src where- checkTessSupport stage = do+ checkTessSupport = do exts <- getGLExtensions- unless ("GL_ARB_tessellation_shader" `elem` exts) $- throwError $ fromStageError (UnsupportedStage stage)+ unless ("GL_ARB_tessellation_shader" `elem` exts) . throwError $+ fromStageError (UnsupportedStage stageType) -- Create a shader from the kind of shader and its source code 'String' representation. mkShader :: (HasStageError e,MonadError e m,MonadIO m,MonadResource m)- => GLenum+ => StageType -> String -> m Stage-mkShader target src = do+mkShader stageType src = do (sid,compiled,cl) <- liftIO $ do- sid <- debugGL $ glCreateShader target+ sid <- debugGL $ glCreateShader (fromStageType stageType) withCString (prependGLSLPragma src) $ \cstr -> do with cstr $ \pcstr -> debugGL $ glShaderSource sid 1 pcstr nullPtr debugGL $ glCompileShader sid@@ -79,7 +88,7 @@ pure (sid,compiled,cl) unless compiled $ do liftIO (glDeleteShader sid)- throwError . fromStageError $ CompilationFailed cl+ throwError . fromStageError . CompilationFailed $ show stageType ++ ": " ++ cl _ <- register $ glDeleteShader sid pure $ Stage sid
src/Graphics/Luminance/Core/Shader/UniformBlock.hs view
@@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Texture.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Texture1D.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Texture1DArray.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Texture2D.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Texture2DArray.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Texture3D.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Tuple.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Core/Vertex.hs view
@@ -6,7 +6,7 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Framebuffer.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -29,6 +29,8 @@ , FramebufferBlitMask(..) -- * Special framebuffers , defaultFramebuffer+ -- * Special operations on framebuffers+ , framebufferBlit -- * Framebuffer errors , FramebufferError(..) , HasFramebufferError(..)
src/Graphics/Luminance/Geometry.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Pixel.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Query.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/RW.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
+ src/Graphics/Luminance/Region.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015, 2016 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------++module Graphics.Luminance.Region (+ -- * Regions+ Region+ , gpuRegion+ , newFrame+ , newShading+ -- * Drawing+ , drawGeometry+ ) where++import Graphics.Luminance.Core.Region
src/Graphics/Luminance/RenderCmd.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -14,7 +14,6 @@ , renderCmd -- * Special render commands , stdRenderCmd- , stdRenderCmd_ ) where import Graphics.Luminance.Core.RenderCmd
src/Graphics/Luminance/Shader.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Shader/Program.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>@@ -17,16 +17,23 @@ -- * Uniform , Uniform , U+ , U'+ , (.=) , UniformInterface , UniformName(..) , SomeUniformName(..)+ , updateUniforms -- * Uniform block , UniformBlock , UB(..) -- * Error handling , ProgramError(..) , HasProgramError(..)+ -- * Re-exported+ , (<>)+ , sconcat ) where import Graphics.Luminance.Core.Shader.Program import Graphics.Luminance.Core.Shader.UniformBlock+import Data.Semigroup
src/Graphics/Luminance/Shader/Stage.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Texture.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>
src/Graphics/Luminance/Vertex.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Copyright : (C) 2015 Dimitri Sabadie+-- Copyright : (C) 2015, 2016 Dimitri Sabadie -- License : BSD3 -- -- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>