module Graphics.GLUtil.Shaders (loadShader, loadShaderBS,
linkShaderProgram, linkShaderProgramWith,
namedUniform,
uniformScalar, uniformVec, uniformMat,
namedUniformMat, uniformGLMat4) where
import Control.Monad (unless)
import qualified Data.ByteString as BS
import Graphics.Rendering.OpenGL
import Graphics.GL.Core31
import Graphics.GLUtil.GLError
import Foreign.Ptr (Ptr)
import Unsafe.Coerce (unsafeCoerce)
loadShader :: ShaderType -> FilePath -> IO Shader
loadShader :: ShaderType -> FilePath -> IO Shader
loadShader st :: ShaderType
st filePath :: FilePath
filePath = FilePath -> IO ByteString
BS.readFile FilePath
filePath IO ByteString -> (ByteString -> IO Shader) -> IO Shader
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ShaderType -> ByteString -> IO Shader
loadShaderBS FilePath
filePath ShaderType
st
loadShaderBS :: FilePath -> ShaderType -> BS.ByteString -> IO Shader
loadShaderBS :: FilePath -> ShaderType -> ByteString -> IO Shader
loadShaderBS filePath :: FilePath
filePath st :: ShaderType
st src :: ByteString
src = do
Shader
shader <- ShaderType -> IO Shader
createShader ShaderType
st
Shader -> StateVar ByteString
shaderSourceBS Shader
shader StateVar ByteString -> ByteString -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= ByteString
src
Shader -> IO ()
compileShader Shader
shader
IO ()
printError
Bool
ok <- GettableStateVar Bool -> GettableStateVar Bool
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Shader -> GettableStateVar Bool
compileStatus Shader
shader)
FilePath
infoLog <- GettableStateVar FilePath -> GettableStateVar FilePath
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Shader -> GettableStateVar FilePath
shaderInfoLog Shader
shader)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
infoLog Bool -> Bool -> Bool
|| FilePath
infoLog FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "\NUL")
((FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
putStrLn
["Shader info log for '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filePath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ "':", FilePath
infoLog, ""])
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Shader -> IO ()
forall a (m :: * -> *). (ObjectName a, MonadIO m) => a -> m ()
deleteObjectName Shader
shader
IOError -> IO ()
forall a. IOError -> IO a
ioError (FilePath -> IOError
userError "shader compilation failed")
Shader -> IO Shader
forall (m :: * -> *) a. Monad m => a -> m a
return Shader
shader
linkShaderProgram :: [Shader] -> IO Program
linkShaderProgram :: [Shader] -> IO Program
linkShaderProgram shaders :: [Shader]
shaders = [Shader] -> (Program -> IO ()) -> IO Program
linkShaderProgramWith [Shader]
shaders (IO () -> Program -> IO ()
forall a b. a -> b -> a
const (IO () -> Program -> IO ()) -> IO () -> Program -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
linkShaderProgramWith :: [Shader] -> (Program -> IO ()) -> IO Program
linkShaderProgramWith :: [Shader] -> (Program -> IO ()) -> IO Program
linkShaderProgramWith shaders :: [Shader]
shaders prelink :: Program -> IO ()
prelink = do Program
p <- IO Program
createProgram
(Shader -> IO ()) -> [Shader] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Program -> Shader -> IO ()
attachShader Program
p) [Shader]
shaders
Program -> IO ()
prelink Program
p
Program -> IO ()
linkProgram Program
p
Program -> IO Program
forall (m :: * -> *) a. Monad m => a -> m a
return Program
p
namedUniform :: Uniform a => String -> StateVar a
namedUniform :: FilePath -> StateVar a
namedUniform name :: FilePath
name = IO a -> (a -> IO ()) -> StateVar a
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar (IO (StateVar a)
loc IO (StateVar a) -> (StateVar a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateVar a -> IO a
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get) (\x :: a
x -> IO (StateVar a)
loc IO (StateVar a) -> (StateVar a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StateVar a -> a -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= a
x))
where loc :: IO (StateVar a)
loc = do Just p :: Program
p <- StateVar (Maybe Program) -> IO (Maybe Program)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar (Maybe Program)
currentProgram
UniformLocation
l <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> FilePath -> GettableStateVar UniformLocation
uniformLocation Program
p FilePath
name)
IO ()
printError
StateVar a -> IO (StateVar a)
forall (m :: * -> *) a. Monad m => a -> m a
return (StateVar a -> IO (StateVar a)) -> StateVar a -> IO (StateVar a)
forall a b. (a -> b) -> a -> b
$ UniformLocation -> StateVar a
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
l
withHMatrix :: [[GLfloat]] -> (Ptr GLfloat -> IO a) -> IO a
withHMatrix :: [[GLfloat]] -> (Ptr GLfloat -> IO a) -> IO a
withHMatrix lstMat :: [[GLfloat]]
lstMat m :: Ptr GLfloat -> IO a
m = do
GLmatrix GLfloat
mat <- MatrixOrder -> [GLfloat] -> IO (GLmatrix GLfloat)
forall (m :: * -> *) c.
(Matrix m, MatrixComponent c) =>
MatrixOrder -> [c] -> IO (m c)
newMatrix MatrixOrder
RowMajor ([[GLfloat]] -> [GLfloat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[GLfloat]]
lstMat) :: IO (GLmatrix GLfloat)
GLmatrix GLfloat -> (MatrixOrder -> Ptr GLfloat -> IO a) -> IO a
forall (m :: * -> *) c a.
(Matrix m, MatrixComponent c) =>
m c -> (MatrixOrder -> Ptr c -> IO a) -> IO a
withMatrix GLmatrix GLfloat
mat (\_ -> Ptr GLfloat -> IO a
m)
unUL :: UniformLocation -> GLint
unUL :: UniformLocation -> GLint
unUL = UniformLocation -> GLint
forall a b. a -> b
unsafeCoerce
uniformScalar :: UniformComponent a => UniformLocation -> SettableStateVar a
uniformScalar :: UniformLocation -> SettableStateVar a
uniformScalar loc :: UniformLocation
loc = (a -> IO ()) -> SettableStateVar a
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar ((a -> IO ()) -> SettableStateVar a)
-> (a -> IO ()) -> SettableStateVar a
forall a b. (a -> b) -> a -> b
$ (UniformLocation -> StateVar (Index1 a)
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
loc StateVar (Index1 a) -> Index1 a -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$=) (Index1 a -> IO ()) -> (a -> Index1 a) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Index1 a
forall a. a -> Index1 a
Index1
uniformVec :: UniformLocation -> SettableStateVar [GLfloat]
uniformVec :: UniformLocation -> SettableStateVar [GLfloat]
uniformVec loc :: UniformLocation
loc = ([GLfloat] -> IO ()) -> SettableStateVar [GLfloat]
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar [GLfloat] -> IO ()
aux
where aux :: [GLfloat] -> IO ()
aux [x :: GLfloat
x,y :: GLfloat
y] = GLint -> GLfloat -> GLfloat -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> GLfloat -> GLfloat -> m ()
glUniform2f GLint
loc' GLfloat
x GLfloat
y
aux [x :: GLfloat
x,y :: GLfloat
y,z :: GLfloat
z] = GLint -> GLfloat -> GLfloat -> GLfloat -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> GLfloat -> GLfloat -> GLfloat -> m ()
glUniform3f GLint
loc' GLfloat
x GLfloat
y GLfloat
z
aux [x :: GLfloat
x,y :: GLfloat
y,z :: GLfloat
z,w :: GLfloat
w] = GLint -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> GLfloat -> GLfloat -> GLfloat -> GLfloat -> m ()
glUniform4f GLint
loc' GLfloat
x GLfloat
y GLfloat
z GLfloat
w
aux _ = IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> (FilePath -> IOError) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOError
userError (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
"Only 2, 3, and 4 dimensional vectors are supported"
loc' :: GLint
loc' = UniformLocation -> GLint
unUL UniformLocation
loc
namedUniformMat :: String -> SettableStateVar [[GLfloat]]
namedUniformMat :: FilePath -> SettableStateVar [[GLfloat]]
namedUniformMat var :: FilePath
var = ([[GLfloat]] -> IO ()) -> SettableStateVar [[GLfloat]]
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar (\m :: [[GLfloat]]
m -> GettableStateVar UniformLocation
loc GettableStateVar UniformLocation
-> (UniformLocation -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SettableStateVar [[GLfloat]] -> [[GLfloat]] -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= [[GLfloat]]
m) (SettableStateVar [[GLfloat]] -> IO ())
-> (UniformLocation -> SettableStateVar [[GLfloat]])
-> UniformLocation
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniformLocation -> SettableStateVar [[GLfloat]]
uniformMat)
where loc :: GettableStateVar UniformLocation
loc = do Just p :: Program
p <- StateVar (Maybe Program) -> IO (Maybe Program)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar (Maybe Program)
currentProgram
UniformLocation
location <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> FilePath -> GettableStateVar UniformLocation
uniformLocation Program
p FilePath
var)
IO ()
printError
UniformLocation -> GettableStateVar UniformLocation
forall (m :: * -> *) a. Monad m => a -> m a
return UniformLocation
location
uniformMat :: UniformLocation -> SettableStateVar [[GLfloat]]
uniformMat :: UniformLocation -> SettableStateVar [[GLfloat]]
uniformMat loc :: UniformLocation
loc = ([[GLfloat]] -> IO ()) -> SettableStateVar [[GLfloat]]
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar [[GLfloat]] -> IO ()
aux
where aux :: [[GLfloat]] -> IO ()
aux mat :: [[GLfloat]]
mat = do [[GLfloat]] -> (Ptr GLfloat -> IO ()) -> IO ()
forall a. [[GLfloat]] -> (Ptr GLfloat -> IO a) -> IO a
withHMatrix [[GLfloat]]
mat ((Ptr GLfloat -> IO ()) -> IO ())
-> (Ptr GLfloat -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr GLfloat
ptr ->
case [[GLfloat]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[GLfloat]]
mat of
4 -> GLint -> GLint -> GLboolean -> Ptr GLfloat -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> GLint -> GLboolean -> Ptr GLfloat -> m ()
glUniformMatrix4fv GLint
loc' 1 1 Ptr GLfloat
ptr
3 -> GLint -> GLint -> GLboolean -> Ptr GLfloat -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> GLint -> GLboolean -> Ptr GLfloat -> m ()
glUniformMatrix3fv GLint
loc' 1 1 Ptr GLfloat
ptr
_ -> IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> (FilePath -> IOError) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOError
userError (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
"Only 3x3 and 4x4 matrices are supported"
loc' :: GLint
loc' = UniformLocation -> GLint
unUL UniformLocation
loc
uniformGLMat4 :: UniformLocation -> SettableStateVar (GLmatrix GLfloat)
uniformGLMat4 :: UniformLocation -> SettableStateVar (GLmatrix GLfloat)
uniformGLMat4 loc :: UniformLocation
loc = (GLmatrix GLfloat -> IO ()) -> SettableStateVar (GLmatrix GLfloat)
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar GLmatrix GLfloat -> IO ()
forall (m :: * -> *). Matrix m => m GLfloat -> IO ()
aux
where aux :: m GLfloat -> IO ()
aux m :: m GLfloat
m = m GLfloat -> (MatrixOrder -> Ptr GLfloat -> IO ()) -> IO ()
forall (m :: * -> *) c a.
(Matrix m, MatrixComponent c) =>
m c -> (MatrixOrder -> Ptr c -> IO a) -> IO a
withMatrix m GLfloat
m ((MatrixOrder -> Ptr GLfloat -> IO ()) -> IO ())
-> (MatrixOrder -> Ptr GLfloat -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \_ -> GLint -> GLint -> GLboolean -> Ptr GLfloat -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLint -> GLint -> GLboolean -> Ptr GLfloat -> m ()
glUniformMatrix4fv GLint
loc' 1 1
loc' :: GLint
loc' = UniformLocation -> GLint
unUL UniformLocation
loc