luminance 0.5.2.1 → 0.6
raw patch · 6 files changed
+255/−29 lines, 6 files
Files
- CHANGELOG.md +19/−4
- luminance.cabal +2/−1
- src/Graphics/Luminance/Core/Shader/Program.hs +65/−24
- src/Graphics/Luminance/Core/Shader/Uniform.hs +2/−0
- src/Graphics/Luminance/Core/Shader/UniformBlock.hs +163/−0
- src/Graphics/Luminance/Shader/Uniform.hs +4/−0
CHANGELOG.md view
@@ -1,3 +1,18 @@+# 0.6++#### Breaking changes++- Added a new function to the `createProgram` and `createProgram_` uniform interface builder+ argument. That function can now be used to retrieve `U (Region rw (UB a))`, which is a *UBO*.+- The uniform interface creation is not performed in a arbitrary, user-defined monad anymore. A+ dedicated type was introduced for that very purpose – `UniformInterface` – constraining the user+ to only use the uniformize functions to map semantics to `U` values.++#### Non-breaking changes++- Added `UB`, which can be used along with `Buffer` to create *UBO* buffers and pass them to+ shaders.+ ### 0.5.2.1 - Relaxed lower bound of `linear` to accept `linear-1.19.*`. That changes should enable `lumimance`@@ -6,7 +21,7 @@ ## 0.5.2 -#### Minor changes+#### Non-breaking changes - Added texture arrays: + `Texture1DArray`@@ -15,7 +30,7 @@ ## 0.5.1 -#### Minor changes+#### Non-breaking changes - Added several `Uniform` instances for [linear](http://hackage.haskell.org/package/linear). @@ -26,12 +41,12 @@ ### 0.5 -#### Major changes+#### Breaking changes - Changed the interface of texels transfer and filling. We dropped the `Foldable` instance and now require a `Data.Vector.Storable.Vector` for performance purposes. -#### Minor changes+#### Non-breaking changes - Added `MirrorRepeat` constructor to `Wrap`.
luminance.cabal view
@@ -1,5 +1,5 @@ name: luminance-version: 0.5.2.1+version: 0.6 synopsis: Type-safe, dependently-typed 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@@ -86,6 +86,7 @@ , 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 , Graphics.Luminance.Core.Texture1DArray
src/Graphics/Luminance/Core/Shader/Program.hs view
@@ -14,14 +14,17 @@ 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 Foreign.C ( peekCString, withCString ) import Foreign.Marshal.Alloc ( alloca ) import Foreign.Marshal.Array ( allocaArray ) import Foreign.Ptr ( castPtr, nullPtr )-import Foreign.Storable ( peek )+import Foreign.Storable ( Storable(peek, sizeOf) )+import Graphics.Luminance.Core.Buffer ( Region(..), bufferID ) import Graphics.Luminance.Core.Shader.Stage ( Stage(..) )-import Graphics.Luminance.Core.Shader.Uniform ( U, Uniform(..) )+import Graphics.Luminance.Core.Shader.Uniform ( U(..), Uniform(..) )+import Graphics.Luminance.Core.Shader.UniformBlock ( UB, UniformBlock ) import Graphics.GL import Numeric.Natural ( Natural ) @@ -44,7 +47,7 @@ -- the function you pass as argument. You can use that value to gather uniforms for instance. createProgram :: (HasProgramError e,MonadError e m,MonadIO m,MonadResource m) => [Stage]- -> ((forall a. (Uniform a) => Either String Natural -> m (U a)) -> m i)+ -> ((forall a. (Uniform a) => Either String Natural -> UniformInterface m (U a)) -> (forall a. (Storable a,UniformBlock a) => String -> UniformInterface m (U (Region rw (UB a)))) -> UniformInterface m i) -> m (Program,i) createProgram stages buildIface = do (pid,linked,cl) <- liftIO $ do@@ -56,11 +59,11 @@ cl <- clog ll pid pure (pid,linked,cl) if- | linked -> do+ | linked -> do _ <- register $ glDeleteProgram pid let prog = Program pid- iface <- buildIface $ ifaceWith prog- pure (prog,iface)+ a <- runUniformInterface $ buildIface (uniformize prog) (uniformizeBlock prog)+ pure (prog,a) | otherwise -> throwError . fromProgramError $ LinkFailed cl -- |A simpler version of 'createProgram'. That function assumes you don’t need a uniform interface@@ -68,7 +71,7 @@ createProgram_ :: (HasProgramError e,MonadError e m,MonadIO m,MonadResource m) => [Stage] -> m Program-createProgram_ stages = fmap fst $ createProgram stages (\_ -> pure ())+createProgram_ stages = fmap fst $ createProgram stages (\_ _ -> pure ()) -- |Is a shader program linked? isLinked :: GLuint -> IO Bool@@ -89,25 +92,62 @@ liftA2 (*>) (glGetProgramInfoLog pid (fromIntegral l) nullPtr) (peekCString . castPtr) +--------------------------------------------------------------------------------+-- Uniform interface -----------------------------------------------------------++newtype UniformInterface m a = UniformInterface {+ runUniformInterface' :: StateT UniformInterfaceCtxt m a+ } deriving (Applicative,Functor,Monad)++runUniformInterface :: (Monad m) => UniformInterface m a -> m a+runUniformInterface ui = evalStateT (runUniformInterface' ui) emptyUniformInterfaceCtxt++newtype UniformInterfaceCtxt = UniformInterfaceCtxt {+ uniformInterfaceBufferBinding :: GLuint+ } deriving (Eq,Show)++emptyUniformInterfaceCtxt :: UniformInterfaceCtxt+emptyUniformInterfaceCtxt = UniformInterfaceCtxt {+ uniformInterfaceBufferBinding = 0+ }+ -- |Either map a 'String' or 'Natural' to a uniform.-ifaceWith :: (HasProgramError e,MonadError e m,MonadIO m,Uniform a)- => Program- -> Either String Natural- -> m (U a)-ifaceWith prog access = case access of- Left name -> do- location <- liftIO . withCString name $ glGetUniformLocation pid- if- | isActive location -> pure $ toU pid location- | otherwise -> throwError . fromProgramError $ InactiveUniform access- Right sem- | isActive sem -> pure $ toU pid (fromIntegral sem)- | otherwise -> throwError . fromProgramError $ InactiveUniform access- where- pid = programID prog- isActive :: (Ord a,Num a) => a -> Bool- isActive = (> -1)+uniformize :: (HasProgramError e,MonadError e m,MonadIO m,Uniform a)+ => Program+ -> Either String Natural+ -> 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 +-- |Map a 'String' to a uniform block.+uniformizeBlock :: forall a e m rw. (HasProgramError e,MonadError e m,MonadIO m,Storable a,UniformBlock a)+ => Program+ -> 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 * sizeOf (undefined :: a))+ | otherwise -> throwError . fromProgramError $ InactiveUniformBlock name+ -------------------------------------------------------------------------------- -- Shader program errors ------------------------------------------------------- @@ -120,6 +160,7 @@ data ProgramError = LinkFailed String | InactiveUniform (Either String Natural)+ | InactiveUniformBlock String deriving (Eq,Show) -- |Types that can handle 'ProgramError' – read as, “have”.
src/Graphics/Luminance/Core/Shader/Uniform.hs view
@@ -39,6 +39,8 @@ -- 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
+ src/Graphics/Luminance/Core/Shader/UniformBlock.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveTraversable #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Dimitri Sabadie+-- License : BSD3+--+-- Maintainer : Dimitri Sabadie <dimitri.sabadie@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------++module Graphics.Luminance.Core.Shader.UniformBlock where++import Control.Monad.IO.Class ( MonadIO(..) ) +import Data.Int ( Int32 )+import Data.Proxy ( Proxy(..) )+import Data.Word ( Word32 )+import Foreign.Ptr ( Ptr )+import Foreign.Storable ( Storable(..), peekByteOff, pokeByteOff )+import GHC.Generics+import Linear.V2 ( V2 )+import Linear.V3 ( V3 )+import Linear.V4 ( V4 )++--------------------------------------------------------------------------------+-- UB wrapper type -------------------------------------------------------------++newtype UB a = UB { unUB :: a } deriving (Eq,Foldable,Functor,Ord,Show,Traversable)++instance (UniformBlock a) => Storable (UB a) where+ alignment _ = alignmentSTD140 (Proxy :: Proxy a)+ sizeOf _ = sizeOfSTD140 (Proxy :: Proxy a)+ peekByteOff p o = fmap UB (peekSTD140 p o)+ pokeByteOff p o = pokeSTD140 p o . unUB++--------------------------------------------------------------------------------+-- Uniform block ---------------------------------------------------------------++class UniformBlock a where+ alignmentSTD140 :: proxy a -> Int+ default alignmentSTD140 :: (Generic a,GUniformBlock (Rep a)) => proxy a -> Int+ alignmentSTD140 _ = galignmentSTD140 (Proxy :: Proxy (Rep a))++ sizeOfSTD140 :: proxy a -> Int+ default sizeOfSTD140 :: (Generic a,GUniformBlock (Rep a)) => proxy a -> Int+ sizeOfSTD140 _ = gsizeOfSTD140 (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)++ pokeSTD140 :: (MonadIO m) => Ptr b -> Int -> a -> m ()+ default pokeSTD140 :: (Generic a,GUniformBlock (Rep a),MonadIO m) => Ptr b -> Int -> a -> m ()+ pokeSTD140 p o a = liftIO $ gpokeSTD140 p o (from a)++roundUp :: Int -> Int -> Int+roundUp u a = a + mod (u - a) u++--------------------------------------------------------------------------------+-- Generic UniformBlock --------------------------------------------------------++class GUniformBlock f where+ galignmentSTD140 :: proxy f -> Int+ gsizeOfSTD140 :: 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+ 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) + gsizeOfSTD140 (Proxy :: Proxy g)+ gpeekSTD140 p o = liftIO $+ (:*:)+ <$> gpeekSTD140 p o+ <*> gpeekSTD140 p (o + roundUp 32 (gsizeOfSTD140 (Proxy :: Proxy f)))+ gpokeSTD140 p o (f :*: g) = liftIO $ do+ gpokeSTD140 p o f+ gpokeSTD140 p (o + roundUp 32 (gsizeOfSTD140 (Proxy :: Proxy f))) g++instance (GUniformBlock f) => GUniformBlock (D1 c f) where+ galignmentSTD140 _ = galignmentSTD140 (Proxy :: Proxy f)+ gsizeOfSTD140 _ = gsizeOfSTD140 (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 _ = roundUp 32 (galignmentSTD140 (Proxy :: Proxy f))+ gsizeOfSTD140 _ = roundUp 32 (gsizeOfSTD140 (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)+ 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)+ gpeekSTD140 p o = fmap K1 (peekSTD140 p o)+ gpokeSTD140 p o (K1 a) = pokeSTD140 p o a++--------------------------------------------------------------------------------+-- Basic instances -------------------------------------------------------------++instance UniformBlock Int32 where+ alignmentSTD140 _ = 4+ sizeOfSTD140 _ = 4+ peekSTD140 p o = liftIO (peekByteOff p o)+ pokeSTD140 p o a = liftIO (pokeByteOff p o a)++instance UniformBlock Word32 where+ alignmentSTD140 _ = 4+ sizeOfSTD140 _ = 4+ peekSTD140 p o = liftIO (peekByteOff p o)+ pokeSTD140 p o a = liftIO (pokeByteOff p o a)++instance UniformBlock Float where+ alignmentSTD140 _ = 4+ sizeOfSTD140 _ = 4+ peekSTD140 p o = liftIO (peekByteOff p o)+ pokeSTD140 p o a = liftIO (pokeByteOff p o a)++instance UniformBlock Bool where+ alignmentSTD140 _ = 4+ sizeOfSTD140 _ = 4+ peekSTD140 p o = liftIO (fmap toBool $ peekByteOff p o)+ pokeSTD140 p o a = liftIO (pokeByteOff p o $ fromBool a)++instance (Storable a,UniformBlock a) => UniformBlock (V2 a) where+ alignmentSTD140 _ = alignmentSTD140 (Proxy :: Proxy a) * 2+ sizeOfSTD140 _ = sizeOfSTD140 (Proxy :: Proxy a) * 2+ peekSTD140 p o = liftIO (peekByteOff p o)+ pokeSTD140 p o a = liftIO (pokeByteOff p o a)++instance (Storable a,UniformBlock a) => UniformBlock (V3 a) where+ alignmentSTD140 _ = alignmentSTD140 (Proxy :: Proxy a) * 4+ sizeOfSTD140 _ = sizeOfSTD140 (Proxy :: Proxy a) * 4+ peekSTD140 p o = liftIO (peekByteOff p o)+ pokeSTD140 p o a = liftIO (pokeByteOff p o a)++instance (Storable a,UniformBlock a) => UniformBlock (V4 a) where+ alignmentSTD140 _ = alignmentSTD140 (Proxy :: Proxy a) * 4+ sizeOfSTD140 _ = sizeOfSTD140 (Proxy :: Proxy a) * 4+ peekSTD140 p o = liftIO (peekByteOff p o)+ pokeSTD140 p o a = liftIO (pokeByteOff p o a)++fromBool :: Bool -> Int32+fromBool False = 0+fromBool True = 1++toBool :: Int32 -> Bool+toBool 0 = False+toBool _ = True
src/Graphics/Luminance/Shader/Uniform.hs view
@@ -12,6 +12,10 @@ -- * Uniform Uniform , U+ -- * Uniform block+ , UniformBlock+ , UB(..) ) where import Graphics.Luminance.Core.Shader.Uniform+import Graphics.Luminance.Core.Shader.UniformBlock