-- |Utilities for working with fragment and vertex shader programs.
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' is based on the ogl2brick example in the GLUT package.

-- |Load a shader program from a file.
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 fileName shaderType src@ loads a shader from source
-- code, @src@. The file name is used only for error reporting.
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

-- |Link shaders into a 'Program'.
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 ())

-- |Link shaders into a 'Program' with the given action performed
-- after attaching shaders, but before linking the program. This is
-- most commonly used to set the 'bindFragDataLocation' state
-- variable.
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

-- |Work with a named uniform shader parameter. Note that this looks
-- up the variable name on each access, so uniform parameters that
-- will be accessed frequently should instead be resolved to a
-- 'UniformLocation'.
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

-- Allocate an OpenGL matrix from a nested list matrix, and pass a
-- pointer to that matrix to an 'IO' action.
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)

-- Not all raw uniform setters are wrapped by the OpenGL interface,
-- but the UniformLocation newtype is still helpful for type
-- discipline.
unUL :: UniformLocation -> GLint
unUL :: UniformLocation -> GLint
unUL = UniformLocation -> GLint
forall a b. a -> b
unsafeCoerce

-- |Set a 'UniformLocation' to a scalar value.
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

-- |Set a 'UniformLocation' from a list representation of a
-- low-dimensional vector of 'GLfloat's. Only 2, 3, and 4 dimensional
-- vectors are supported.
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

-- |Set a named uniform shader parameter from a nested list matrix
-- representation. Only 3x3 and 4x4 matrices are supported.
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

-- |Set a uniform shader location from a nested list matrix
-- representation. Only 3x3 and 4x4 matrices are supported.
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

-- |Set a uniform shader location with a 4x4 'GLmatrix'.
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