{-# 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