pituicat/src/Graphics/Types/Shader.hs

202 lines
6.1 KiB
Haskell

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Graphics.Types.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 Graphics.Classes.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
uniform (GL.UniformLocation ul) = makeStateVar getter setter
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
uniformv (GL.UniformLocation _) _ _ = error "can not implement uniformv for M44 GLfloat"
-- 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 ()
setUniformList (Shader shaderProgram _ sUniforms) uniname data_ = do
-- check if uniform location is already cached
locs <- readMVar sUniforms
-- 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
modifyMVar_ sUniforms
(\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 ()
setUniform (Shader shaderProgram _ sUniforms) uniname data_ = do
-- check if uniform location is already cached
locs <- readMVar sUniforms
-- 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
modifyMVar_ sUniforms
(\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