module Graphics.GLUtil.Shaders (loadShader, linkShaderProgram, namedUniform,
uniformScalar, uniformVec, uniformMat,
namedUniformMat, uniformGLMat4) where
import Control.Monad (unless)
import Graphics.Rendering.OpenGL
import Graphics.Rendering.OpenGL.Raw.Core31
import Graphics.GLUtil.GLError
import Foreign.Ptr (Ptr)
import Unsafe.Coerce (unsafeCoerce)
loadShader :: Shader s => FilePath -> IO s
loadShader filePath = do
src <- readFile filePath
[shader] <- genObjectNames 1
shaderSource shader $= [src]
compileShader shader
printError
ok <- get (compileStatus shader)
infoLog <- get (shaderInfoLog shader)
unless (null infoLog)
(mapM_ putStrLn
["Shader info log for '" ++ filePath ++ "':", infoLog, ""])
unless ok $ do
deleteObjectNames [shader]
ioError (userError "shader compilation failed")
return shader
linkShaderProgram :: [VertexShader] -> [FragmentShader] -> IO Program
linkShaderProgram vs fs = do
[prog] <- genObjectNames 1
attachedShaders prog $= (vs, fs)
linkProgram prog
printError
ok <- get (linkStatus prog)
infoLog <- get (programInfoLog prog)
unless (null infoLog)
(mapM_ putStrLn ["Program info log:", infoLog, ""])
unless ok $ do
deleteObjectNames [prog]
ioError (userError "GLSL linking failed")
return prog
namedUniform :: (Uniform a) => String -> StateVar a
namedUniform name = makeStateVar (loc >>= get) (\x -> loc >>= ($= x))
where loc = do Just p <- get currentProgram
l <- get (uniformLocation p name)
printError
return $ uniform l
withHMatrix :: [[GLfloat]] -> (Ptr GLfloat -> IO a) -> IO a
withHMatrix lstMat m = do
mat <- newMatrix RowMajor (concat lstMat) :: IO (GLmatrix GLfloat)
withMatrix mat (\_ -> m)
unUL :: UniformLocation -> GLint
unUL = unsafeCoerce
uniformScalar :: UniformComponent a => UniformLocation -> SettableStateVar a
uniformScalar loc = makeSettableStateVar $ (uniform loc $=) . Index1
uniformVec :: UniformLocation -> SettableStateVar [GLfloat]
uniformVec loc = makeSettableStateVar aux
where aux [x,y] = glUniform2f loc' x y
aux [x,y,z] = glUniform3f loc' x y z
aux [x,y,z,w] = glUniform4f loc' x y z w
aux _ = ioError . userError $
"Only 2, 3, and 4 dimensional vectors are supported"
loc' = unUL loc
namedUniformMat :: String -> SettableStateVar [[GLfloat]]
namedUniformMat var = makeSettableStateVar (\m -> loc >>= ($= m) . uniformMat)
where loc = do Just p <- get currentProgram
location <- get (uniformLocation p var)
printError
return location
uniformMat :: UniformLocation -> SettableStateVar [[GLfloat]]
uniformMat loc = makeSettableStateVar aux
where aux mat = do withHMatrix mat $ \ptr ->
case length mat of
4 -> glUniformMatrix4fv loc' 1 1 ptr
3 -> glUniformMatrix3fv loc' 1 1 ptr
_ -> ioError . userError $
"Only 3x3 and 4x4 matrices are supported"
loc' = unUL loc
uniformGLMat4 :: UniformLocation -> SettableStateVar (GLmatrix GLfloat)
uniformGLMat4 loc = makeSettableStateVar aux
where aux m = withMatrix m $ \_ -> glUniformMatrix4fv loc' 1 1
loc' = unUL loc