module Graphics.Luminance.Core.Shader.Uniform where
import Data.Functor.Contravariant ( Contravariant(..) )
import Data.Functor.Contravariant.Divisible ( Decidable(..), Divisible(..) )
import Data.Int ( Int32 )
import Data.Semigroup ( Semigroup(..) )
import Data.Void ( absurd )
import Data.Word ( Word32 )
import Foreign.Marshal.Array ( withArrayLen )
import Graphics.GL
import Graphics.GL.Ext.ARB.BindlessTexture ( glProgramUniformHandleui64ARB )
import Graphics.Luminance.Core.Cubemap ( Cubemap(cubemapBase) )
import Graphics.Luminance.Core.Texture ( BaseTexture(baseTextureHnd) )
import Graphics.Luminance.Core.Texture1D ( Texture1D(texture1DBase) )
import Graphics.Luminance.Core.Texture2D ( Texture2D(texture2DBase) )
import Graphics.Luminance.Core.Texture3D ( Texture3D(texture3DBase) )
class Uniform a where
toU :: GLuint -> GLint -> U a
newtype U a = U { runU :: a -> IO () }
instance Contravariant U where
contramap f u = U $ runU u . f
instance Decidable U where
lose f = U $ absurd . f
choose f p q = U $ either (runU p) (runU q) . f
instance Divisible U where
divide f p q = U $ \a -> do
let (b,c) = f a
runU p b
runU q c
conquer = mempty
instance Monoid (U a) where
mempty = U . const $ pure ()
mappend = (<>)
instance Semigroup (U a) where
u <> v = U $ \a -> runU u a >> runU v a
instance Uniform () where
toU _ _ = mempty
instance Uniform Int32 where
toU prog l = U $ glProgramUniform1i prog l
instance Uniform (Int32,Int32) where
toU prog l = U $ \(x,y) -> glProgramUniform2i prog l x y
instance Uniform (Int32,Int32,Int32) where
toU prog l = U $ \(x,y,z) -> glProgramUniform3i prog l x y z
instance Uniform (Int32,Int32,Int32,Int32) where
toU prog l = U $ \(x,y,z,w) -> glProgramUniform4i prog l x y z w
instance Uniform [Int32] where
toU prog l = U $ \v -> withArrayLen v $ glProgramUniform1iv prog l . fromIntegral
instance Uniform [(Int32,Int32)] where
toU prog l = U $ \v -> withArrayLen (concatMap unPair v) $
glProgramUniform2iv prog l . fromIntegral
instance Uniform [(Int32,Int32,Int32)] where
toU prog l = U $ \v -> withArrayLen (concatMap unTriple v) $
glProgramUniform3iv prog l . fromIntegral
instance Uniform [(Int32,Int32,Int32,Int32)] where
toU prog l = U $ \v -> withArrayLen (concatMap unQuad v) $
glProgramUniform4iv prog l . fromIntegral
instance Uniform Word32 where
toU prog l = U $ glProgramUniform1ui prog l
instance Uniform (Word32,Word32) where
toU prog l = U $ \(x,y) -> glProgramUniform2ui prog l x y
instance Uniform (Word32,Word32,Word32) where
toU prog l = U $ \(x,y,z) -> glProgramUniform3ui prog l x y z
instance Uniform (Word32,Word32,Word32,Word32) where
toU prog l = U $ \(x,y,z,w) -> glProgramUniform4ui prog l x y z w
instance Uniform [Word32] where
toU prog l = U $ \v -> withArrayLen v $
glProgramUniform1uiv prog l . fromIntegral
instance Uniform [(Word32,Word32)] where
toU prog l = U $ \v -> withArrayLen (concatMap unPair v) $
glProgramUniform2uiv prog l . fromIntegral
instance Uniform [(Word32,Word32,Word32)] where
toU prog l = U $ \v -> withArrayLen (concatMap unTriple v) $
glProgramUniform3uiv prog l . fromIntegral
instance Uniform [(Word32,Word32,Word32,Word32)] where
toU prog l = U $ \v -> withArrayLen (concatMap unQuad v) $
glProgramUniform4uiv prog l . fromIntegral
instance Uniform Float where
toU prog l = U $ glProgramUniform1f prog l
instance Uniform (Float,Float) where
toU prog l = U $ \(x,y) -> glProgramUniform2f prog l x y
instance Uniform (Float,Float,Float) where
toU prog l = U $ \(x,y,z) -> glProgramUniform3f prog l x y z
instance Uniform (Float,Float,Float,Float) where
toU prog l = U $ \(x,y,z,w) -> glProgramUniform4f prog l x y z w
instance Uniform [Float] where
toU prog l = U $ \v -> withArrayLen v $
glProgramUniform1fv prog l . fromIntegral
instance Uniform [(Float,Float)] where
toU prog l = U $ \v -> withArrayLen (concatMap unPair v) $
glProgramUniform2fv prog l . fromIntegral
instance Uniform [(Float,Float,Float)] where
toU prog l = U $ \v -> withArrayLen (concatMap unTriple v) $
glProgramUniform3fv prog l . fromIntegral
instance Uniform [(Float,Float,Float,Float)] where
toU prog l = U $ \v -> withArrayLen (concatMap unQuad v) $
glProgramUniform4fv prog l . fromIntegral
instance Uniform (Texture1D f) where
toU prog l = U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . texture1DBase
instance Uniform (Texture2D f) where
toU prog l = U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . texture2DBase
instance Uniform (Texture3D f) where
toU prog l = U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . texture3DBase
instance Uniform (Cubemap f) where
toU prog l = U $ glProgramUniformHandleui64ARB prog l . baseTextureHnd . cubemapBase
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]