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 ( toList, traverse_ )
import Data.Functor.Contravariant ( Contravariant(..) )
import Data.Int ( Int32 )
import Data.Proxy ( Proxy(..) )
import Data.Semigroup ( Semigroup(..) )
import Data.Word ( Word32 )
import Foreign.C ( peekCString, withCString )
import Foreign.Marshal.Alloc ( alloca )
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 ( Buffer(..), 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.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 )
data Program u = Program {
programID :: GLuint
, programInterface :: u
} deriving (Eq,Show)
createProgram :: (HasProgramError e,MonadError e m,MonadResource m)
=> [Stage]
-> ((forall a. UniformName a -> UniformInterface m (U a)) -> UniformInterface m i)
-> m (Program i)
createProgram stages buildIface = do
(pid,linked,cl) <- liftIO $ do
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)
unless linked $ do
liftIO (glDeleteProgram pid)
throwError . fromProgramError $ LinkFailed cl
_ <- register $ glDeleteProgram pid
a <- runUniformInterface $ buildIface (uniformize pid)
pure (Program pid a)
createProgram_ :: (HasProgramError e,MonadError e m,MonadIO m,MonadResource m)
=> [Stage]
-> m (Program ())
createProgram_ stages = createProgram stages (\_ -> pure ())
isLinked :: GLuint -> IO Bool
isLinked pid = do
ok <- debugGL . alloca $ liftA2 (*>) (glGetProgramiv pid GL_LINK_STATUS) peek
pure $ ok == GL_TRUE
clogLength :: GLuint -> IO Int
clogLength pid =
fmap fromIntegral . debugGL . alloca $ liftA2 (*>) (glGetProgramiv pid GL_INFO_LOG_LENGTH) peek
clog :: Int -> GLuint -> IO String
clog l pid =
debugGL . allocaArray l $
liftA2 (*>) (glGetProgramInfoLog pid (fromIntegral l) nullPtr) (peekCString . castPtr)
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
data UniformInterfaceCtxt = UniformInterfaceCtxt {
uniformInterfaceBufferBinding :: GLuint
#if !defined(__GL_BINDLESS_TEXTURES)
, uniformInterfaceTextureUnit :: GLenum
#endif
} deriving (Eq,Show)
emptyUniformInterfaceCtxt :: UniformInterfaceCtxt
emptyUniformInterfaceCtxt = UniformInterfaceCtxt {
uniformInterfaceBufferBinding = 0
#if !defined(__GL_BINDLESS_TEXTURES)
, uniformInterfaceTextureUnit = 0
#endif
}
data UniformName :: * -> * where
UniformName :: (Uniform a) => String -> UniformName a
UniformSemantic :: (Uniform a) => Natural -> UniformName a
UniformBlockName :: (UniformBlock a) => String -> UniformName (Buffer rw (UB a))
data SomeUniformName = forall a. SomeUniformName (UniformName a)
instance Eq SomeUniformName where
SomeUniformName (UniformName a) == SomeUniformName (UniformName b) = a == b
SomeUniformName (UniformSemantic a) == SomeUniformName (UniformSemantic b) = a == b
SomeUniformName (UniformBlockName a) == SomeUniformName (UniformBlockName b) = a == b
_ == _ = False
instance Show SomeUniformName where
show (SomeUniformName name) = case name of
UniformName n -> "UniformName " ++ n
UniformSemantic s -> "UniformSemantic " ++ show s
UniformBlockName n -> "UniformBlockName " ++ n
uniformize :: (HasProgramError e,MonadError e m,MonadIO m)
=> GLuint
-> UniformName a
-> UniformInterface m (U a)
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)
runUniformInterface' (toU pid location)
UniformSemantic sem -> do
when (sem == 1) . throwError . fromProgramError $ InactiveUniform (SomeUniformName getter)
runUniformInterface' (toU pid $ fromIntegral sem)
UniformBlockName name -> runUniformInterface (uniformizeBlock pid name $ InactiveUniform (SomeUniformName getter))
uniformizeBlock :: forall a e m rw. (HasProgramError e,MonadError e m,MonadIO m,UniformBlock a)
=> GLuint
-> String
-> ProgramError
-> 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)
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 r)
(fromIntegral $ bufferOffset r)
(fromIntegral $ bufferSize 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
updateUniforms :: (MonadIO m) => Program a -> (a -> U') -> m ()
updateUniforms prog f = do
#ifdef __GL33
glUseProgram (programID prog)
#endif
liftIO . runU' . f $ programInterface prog
newtype U a = U { runU :: a -> IO () }
instance Contravariant U where
contramap f u = U $ runU u . f
newtype U' = U' { runU' :: IO () }
instance Monoid U' where
mempty = U' $ pure ()
mappend = (<>)
instance Semigroup U' where
a <> b = U' $ runU' a >> runU' b
(.=) :: U a -> a -> U'
u .= a = U' (runU u a)
class Uniform a where
toU :: (Monad m) => GLuint -> GLint -> UniformInterface m (U a)
instance Uniform () where
toU _ _ = pure . U . const $ pure ()
instance Uniform Int32 where
#ifdef __GL45
toU prog l = pure $ U (glProgramUniform1i prog l)
#elif defined(__GL33)
toU _ l = pure $ U (glUniform1i l)
#endif
instance Uniform (Int32,Int32) where
#ifdef __GL45
toU prog l = pure . U $ \(x,y) -> glProgramUniform2i prog l x y
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \(V v) -> case toList v of
[x,y] -> glUniform2i l x y
_ -> pure ()
#endif
instance Uniform (Int32,Int32,Int32) where
#ifdef __GL45
toU prog l = pure . U $ \(x,y,z) -> glProgramUniform3i prog l x y z
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \(V v) -> case toList v of
[x,y,z] -> glUniform3i l x y z
_ -> pure ()
#endif
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(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \(V v) -> case toList v of
[x,y,z,w] -> glUniform4i l x y z w
_ -> pure ()
#endif
instance Uniform [Int32] where
#ifdef __GL45
toU prog l = pure . U $ \v -> withArrayLen v $ glProgramUniform1iv prog l . fromIntegral
#elif defined(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ glUniform1iv l . fromIntegral
#endif
instance Uniform [(Int32,Int32)] where
#ifdef __GL45
toU prog l = pure . U $ \v -> withArrayLen (concatMap unPair v) $
glProgramUniform2iv prog l . fromIntegral
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniform2iv l (fromIntegral size) (castPtr p)
#endif
instance Uniform [(Int32,Int32,Int32)] where
#ifdef __GL45
toU prog l = pure . U $ \v -> withArrayLen (concatMap unTriple v) $
glProgramUniform3iv prog l . fromIntegral
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniform3iv l (fromIntegral size) (castPtr p)
#endif
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(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniform4iv l (fromIntegral size) (castPtr p)
#endif
instance Uniform Word32 where
#ifdef __GL45
toU prog l = pure . U $ glProgramUniform1ui prog l
#elif defined(__GL33)
toU _ l = pure . U $ glUniform1ui l
#endif
instance Uniform (Word32,Word32) where
#ifdef __GL45
toU prog l = pure . U $ \(x,y) -> glProgramUniform2ui prog l x y
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \(V v) -> case toList v of
[x,y] -> glUniform2ui l x y
_ -> pure ()
#endif
instance Uniform (Word32,Word32,Word32) where
#ifdef __GL45
toU prog l = pure . U $ \(x,y,z) -> glProgramUniform3ui prog l x y z
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \(V v) -> case toList v of
[x,y,z] -> glUniform3ui l x y z
_ -> pure ()
#endif
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(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \(V v) -> case toList v of
[x,y,z,w] -> glUniform4ui l x y z w
_ -> pure ()
#endif
instance Uniform [Word32] where
#ifdef __GL45
toU prog l = pure . U $ \v -> withArrayLen v $
glProgramUniform1uiv prog l . fromIntegral
#elif defined(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $
glUniform1uiv l . fromIntegral
#endif
instance Uniform [(Word32,Word32)] where
#ifdef __GL45
toU prog l = pure . U $ \v -> withArrayLen (concatMap unPair v) $
glProgramUniform2uiv prog l . fromIntegral
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniform2uiv l (fromIntegral size) (castPtr p)
#endif
instance Uniform [(Word32,Word32,Word32)] where
#ifdef __GL45
toU prog l = pure . U $ \v -> withArrayLen (concatMap unTriple v) $
glProgramUniform3uiv prog l . fromIntegral
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniform3uiv l (fromIntegral size) (castPtr p)
#endif
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(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniform4uiv l (fromIntegral size) (castPtr p)
#endif
instance Uniform Float where
#ifdef __GL45
toU prog l = pure . U $ glProgramUniform1f prog l
#elif defined(__GL33)
toU _ l = pure . U $ glUniform1f l
#endif
instance Uniform (Float,Float) where
#ifdef __GL45
toU prog l = pure . U $ \(x,y) -> glProgramUniform2f prog l x y
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \(V v) -> case toList v of
[x,y] -> glUniform2f l x y
_ -> pure ()
#endif
instance Uniform (Float,Float,Float) where
#ifdef __GL45
toU prog l = pure . U $ \(x,y,z) -> glProgramUniform3f prog l x y z
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \(V v) -> case toList v of
[x,y,z] -> glUniform3f l x y z
_ -> pure ()
#endif
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(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \(V v) -> case toList v of
[x,y,z,w] -> glUniform4f l x y z w
_ -> pure ()
#endif
instance Uniform [Float] where
#ifdef __GL45
toU prog l = pure . U $ \v -> withArrayLen v $
glProgramUniform1fv prog l . fromIntegral
#elif defined(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $
glUniform1fv l . fromIntegral
#endif
instance Uniform [(Float,Float)] where
#ifdef __GL45
toU prog l = pure . U $ \v -> withArrayLen (concatMap unPair v) $
glProgramUniform2fv prog l . fromIntegral
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniform2fv l (fromIntegral size) (castPtr p)
#endif
instance Uniform [(Float,Float,Float)] where
#ifdef __GL45
toU prog l = pure . U $ \v -> withArrayLen (concatMap unTriple v) $
glProgramUniform3fv prog l . fromIntegral
#elif defined(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniform3fv l (fromIntegral size) (castPtr p)
#endif
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(__GL33)
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(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniform4fv l (fromIntegral size) (castPtr p)
#endif
instance Uniform (M44 Float) where
#ifdef __GL45
toU prog l = pure . U $ \v -> with v $ glProgramUniformMatrix4fv prog l 1 GL_FALSE . castPtr
#elif defined(__GL33)
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(__GL33)
toU _ l = pure . U $ \v -> withArrayLen v $ \size p ->
glUniformMatrix4fv l (fromIntegral size) GL_FALSE (castPtr p)
#endif
#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(__GL33)
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)
debugGL $ glActiveTexture (GL_TEXTURE0 + texUnit)
debugGL $ glBindTexture (textureTypeEnum (Proxy :: Proxy tex)) (baseTextureID $ toBaseTexture tex)
#endif
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]
data ProgramError
= LinkFailed String
| InactiveUniform SomeUniformName
deriving (Eq,Show)
class HasProgramError a where
fromProgramError :: ProgramError -> a