2020-12-06 07:14:50 +00:00
|
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
|
|
|
|
module Types.Graphics.Shader where
|
|
|
|
|
|
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
|
|
import qualified Graphics.GL as GLRaw
|
|
|
|
|
|
|
|
import Data.StateVar
|
|
|
|
|
|
|
|
import qualified Data.ByteString as B
|
|
|
|
|
|
|
|
import Control.Concurrent.MVar
|
|
|
|
|
|
|
|
import Linear
|
|
|
|
|
|
|
|
import Foreign.Marshal.Array (withArray)
|
|
|
|
import Foreign.Storable
|
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Classes.Graphics.Bindable
|
|
|
|
|
|
|
|
data Shader = Shader
|
|
|
|
{ shaderId :: GL.Program
|
|
|
|
, shaderSources :: [ShaderSource]
|
|
|
|
, shaderUniforms :: MVar [ShaderUniform]
|
|
|
|
}
|
|
|
|
|
|
|
|
-- make Shader Bindable
|
|
|
|
instance Bindable Shader where
|
|
|
|
|
|
|
|
bind s = GL.currentProgram $= Just (shaderId s)
|
|
|
|
|
|
|
|
unbind _ = GL.currentProgram $= Nothing
|
|
|
|
|
|
|
|
data ShaderSource = ShaderSource
|
|
|
|
{ shaderSourceType :: GL.ShaderType
|
|
|
|
, shaderPath :: FilePath
|
|
|
|
}
|
|
|
|
|
|
|
|
data ShaderUniform = ShaderUniform
|
|
|
|
{ shaderUniformName :: String
|
|
|
|
, shaderUniformLocation :: GL.UniformLocation
|
|
|
|
}
|
|
|
|
|
|
|
|
-- orphan instance to make linear's M44 uniforms
|
|
|
|
instance GL.Uniform (M44 GL.GLfloat) where
|
2021-01-11 09:33:20 +00:00
|
|
|
uniform (GL.UniformLocation ul) = makeStateVar getter setter
|
2020-12-06 07:14:50 +00:00
|
|
|
where
|
|
|
|
getter = error "cannot implement: get uniform M44 GLfloat"
|
|
|
|
-- GL.withNewMatrix GL.RowMajor $ getUniformWith GLRaw.glGetUniformfv loc
|
|
|
|
setter (V4
|
|
|
|
(V4 a b c d)
|
|
|
|
(V4 e f g h)
|
|
|
|
(V4 i j k l)
|
|
|
|
(V4 m n o p)) = do
|
|
|
|
mat <- GL.newMatrix GL.RowMajor [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] :: IO (GL.GLmatrix GL.GLfloat)
|
|
|
|
GL.withMatrix mat $ GLRaw.glUniformMatrix4fv ul 1 . isRowMajor
|
2021-01-11 09:33:20 +00:00
|
|
|
uniformv (GL.UniformLocation _) _ _ = error "can not implement uniformv for M44 GLfloat"
|
2020-12-06 07:14:50 +00:00
|
|
|
-- GLRaw.glUniformMatrix4fv ul count 0 (castPtr buf `asTypeOf` elemType buf)
|
|
|
|
-- where
|
|
|
|
-- elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c
|
|
|
|
|
|
|
|
-- getUniformWith :: (GL.GLuint -> GL.GLint -> Ptr a -> IO ()) -> GL.UniformLocation -> Ptr a -> IO ()
|
|
|
|
-- getUniformWith getter (GL.UniformLocation ul) buf = do
|
|
|
|
-- program <- fmap (GL.programID . fromJust) $ get GL.currentProgram
|
|
|
|
-- getter program ul buf
|
|
|
|
|
|
|
|
isRowMajor :: GL.MatrixOrder -> GL.GLboolean
|
|
|
|
isRowMajor p = if (GL.RowMajor == p) then 1 else 0
|
|
|
|
|
|
|
|
-- create new data object of type Shader
|
|
|
|
newShader :: [ShaderSource] -> IO Shader
|
|
|
|
newShader shaderSrc = do
|
|
|
|
-- create program Object
|
|
|
|
program <- GL.createProgram
|
|
|
|
|
|
|
|
-- create shaders from the source codes given
|
|
|
|
compilates <- mapM
|
|
|
|
(\(ShaderSource type_ path) -> do
|
|
|
|
-- read in shader source from File
|
|
|
|
source<- B.readFile path
|
|
|
|
|
|
|
|
-- compile the shader
|
|
|
|
compiledShader <- compileShaderSource type_ source
|
|
|
|
return (type_, compiledShader)
|
|
|
|
)
|
|
|
|
shaderSrc
|
|
|
|
|
|
|
|
-- attach, link and validate the shader program
|
|
|
|
GL.attachedShaders program $= map snd compilates
|
|
|
|
GL.linkProgram program
|
|
|
|
GL.validateProgram program
|
|
|
|
|
|
|
|
ok <- get (GL.validateStatus program)
|
|
|
|
if ok
|
|
|
|
then
|
|
|
|
putStrLn "Shaderprogram linked successfully!"
|
|
|
|
else do
|
|
|
|
info <- get (GL.programInfoLog program)
|
|
|
|
putStrLn "Shaderprogram linking failed!\nInfo log says:"
|
|
|
|
putStrLn info
|
|
|
|
GL.deleteObjectName program
|
|
|
|
|
|
|
|
-- throw away the shaders, since they are linked into the shader program
|
|
|
|
mapM_ (\s -> GL.deleteObjectName s) (map snd compilates)
|
|
|
|
|
|
|
|
-- return data object
|
|
|
|
Shader program shaderSrc <$> newMVar []
|
|
|
|
|
|
|
|
-- pass uniform values into Shader program
|
|
|
|
setUniformList :: (Storable a, GL.Uniform a) => Shader -> String -> [a] -> IO ()
|
2021-01-02 12:32:20 +00:00
|
|
|
setUniformList (Shader shaderProgram _ sUniforms) uniname data_ = do
|
2020-12-06 07:14:50 +00:00
|
|
|
-- check if uniform location is already cached
|
2021-01-02 12:32:20 +00:00
|
|
|
locs <- readMVar sUniforms
|
2020-12-06 07:14:50 +00:00
|
|
|
|
|
|
|
-- retrieve uniform location
|
|
|
|
let unilocs = filter
|
|
|
|
(\(ShaderUniform name _) -> name == uniname)
|
|
|
|
locs
|
|
|
|
|
|
|
|
case unilocs of
|
|
|
|
[] -> do
|
|
|
|
print ("Unknown uniform: " <> uniname)
|
|
|
|
print "Retrieving uniform location from shader program"
|
|
|
|
loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
|
|
|
|
if locNum < 0
|
|
|
|
then
|
|
|
|
print ("Uniform does not exist in shader program: " <> uniname)
|
|
|
|
else do
|
|
|
|
-- set the data
|
|
|
|
withArray data_ $ \ptr ->
|
|
|
|
GL.uniformv loc (fromIntegral $ length data_) ptr
|
|
|
|
--GL.uniform loc $= data_
|
|
|
|
-- add uniform to cache
|
2021-01-02 12:32:20 +00:00
|
|
|
modifyMVar_ sUniforms
|
2020-12-06 07:14:50 +00:00
|
|
|
(\list -> return $ ShaderUniform uniname loc : list)
|
|
|
|
[ShaderUniform _ loc] ->
|
|
|
|
-- set the data
|
|
|
|
withArray data_ $ \ptr ->
|
|
|
|
GL.uniformv loc (fromIntegral $ length data_) ptr
|
|
|
|
|
|
|
|
setUniform :: (GL.Uniform a) => Shader -> String -> a -> IO ()
|
2021-01-02 12:32:20 +00:00
|
|
|
setUniform (Shader shaderProgram _ sUniforms) uniname data_ = do
|
2020-12-06 07:14:50 +00:00
|
|
|
-- check if uniform location is already cached
|
2021-01-02 12:32:20 +00:00
|
|
|
locs <- readMVar sUniforms
|
2020-12-06 07:14:50 +00:00
|
|
|
|
|
|
|
-- retrieve uniform location
|
|
|
|
let unilocs = filter
|
|
|
|
(\(ShaderUniform name _) -> name == uniname)
|
|
|
|
locs
|
|
|
|
|
|
|
|
case unilocs of
|
|
|
|
[] -> do
|
|
|
|
print ("Unknown uniform: " <> uniname)
|
|
|
|
print "Retrieving uniform location from shader program"
|
|
|
|
loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
|
|
|
|
if locNum < 0
|
|
|
|
then
|
|
|
|
print ("Uniform does not exist in shader program: " <> uniname)
|
|
|
|
else do
|
|
|
|
-- set the data
|
|
|
|
--withArray data_ $ \ptr ->
|
|
|
|
-- GL.uniformv loc (length data_) ptr
|
|
|
|
GL.uniform loc $= data_
|
|
|
|
-- add uniform to cache
|
2021-01-02 12:32:20 +00:00
|
|
|
modifyMVar_ sUniforms
|
2020-12-06 07:14:50 +00:00
|
|
|
(\list -> return $ ShaderUniform uniname loc : list)
|
|
|
|
[ShaderUniform _ loc] ->
|
|
|
|
-- set the data
|
|
|
|
GL.uniform loc $= data_
|
|
|
|
|
|
|
|
-- | compile a shader from source
|
|
|
|
compileShaderSource
|
|
|
|
:: GL.ShaderType -- ^ what type of shader we are compiling
|
|
|
|
-> B.ByteString -- ^ its source code
|
|
|
|
-> IO GL.Shader
|
|
|
|
compileShaderSource type_ source = do
|
|
|
|
-- create shader object of specified type
|
|
|
|
shaderObject <- GL.createShader type_
|
|
|
|
|
|
|
|
-- assign source code to shader object
|
|
|
|
GL.shaderSourceBS shaderObject $= source
|
|
|
|
|
|
|
|
-- actually compile the shader
|
|
|
|
GL.compileShader shaderObject
|
|
|
|
|
|
|
|
-- error handling
|
|
|
|
ok <- GL.compileStatus shaderObject
|
|
|
|
|
|
|
|
if ok
|
|
|
|
then
|
|
|
|
putStrLn (show type_ ++ ": compilation successful!")
|
|
|
|
else do
|
|
|
|
info <- get (GL.shaderInfoLog shaderObject)
|
|
|
|
putStrLn (show type_ ++ ": compilation failed!\nInfo log says:")
|
|
|
|
putStrLn info
|
|
|
|
GL.deleteObjectName shaderObject
|
|
|
|
|
|
|
|
return shaderObject
|