module Graphics.Rendering.OpenGL.GL.Shaders.Program (
Program(..), programDeleteStatus, attachedShaders, linkProgram, linkStatus,
programInfoLog, validateProgram, validateStatus, currentProgram,
bindFragDataLocation, getFragDataLocation,
GetProgramPName(..), programVar, getCurrentProgram
) where
import Control.Monad
import Data.List
import Data.Maybe (fromMaybe)
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Graphics.Rendering.OpenGL.GL.ObjectName
import Graphics.Rendering.OpenGL.GL.StateVar
import Graphics.Rendering.OpenGL.GL.Framebuffer
import Graphics.Rendering.OpenGL.GL.GLboolean
import Graphics.Rendering.OpenGL.GL.GLstring
import Graphics.Rendering.OpenGL.GL.PeekPoke
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.Rendering.OpenGL.Raw.Core31
import Graphics.Rendering.OpenGL.GL.Shaders.Shaders
newtype Program = Program { programID :: GLuint }
deriving ( Eq, Ord, Show )
instance ObjectName Program where
genObjectNames n = replicateM n $ fmap Program glCreateProgram
deleteObjectNames = mapM_ (glDeleteProgram . programID)
isObjectName = fmap unmarshalGLboolean . glIsProgram . programID
attachedShaders :: Program -> StateVar ([VertexShader],[FragmentShader])
attachedShaders program =
makeStateVar (getAttachedShaders program) (setAttachedShaders program)
getAttachedShaders :: Program -> IO ([VertexShader],[FragmentShader])
getAttachedShaders program = getAttachedShaderIDs program >>= splitShaderIDs
getAttachedShaderIDs :: Program -> IO [GLuint]
getAttachedShaderIDs program = do
numShaders <- get (numAttachedShaders program)
allocaArray (fromIntegral numShaders) $ \buf -> do
glGetAttachedShaders (programID program) numShaders nullPtr buf
peekArray (fromIntegral numShaders) buf
splitShaderIDs :: [GLuint] -> IO ([VertexShader],[FragmentShader])
splitShaderIDs ids = do
(vs, fs) <- partitionM isVertexShaderID ids
return (map VertexShader vs, map FragmentShader fs)
isVertexShaderID :: GLuint -> IO Bool
isVertexShaderID x = do
t <- get (shaderTypeEnum (VertexShader x))
return $ t == shaderType (undefined :: VertexShader)
partitionM :: (a -> IO Bool) -> [a] -> IO ([a],[a])
partitionM p = foldM select ([],[])
where select (ts, fs) x = do
b <- p x
return $ if b then (x:ts, fs) else (ts, x:fs)
setAttachedShaders :: Program -> ([VertexShader],[FragmentShader]) -> IO ()
setAttachedShaders p@(Program program) (vs, fs) = do
currentIDs <- getAttachedShaderIDs p
let newIDs = map shaderID vs ++ map shaderID fs
mapM_ (glAttachShader program) (newIDs \\ currentIDs)
mapM_ (glDetachShader program) (currentIDs \\ newIDs)
linkProgram :: Program -> IO ()
linkProgram (Program program) = glLinkProgram program
currentProgram :: StateVar (Maybe Program)
currentProgram =
makeStateVar
(do p <- getCurrentProgram
return $ if p == noProgram then Nothing else Just p)
((\(Program p) -> glUseProgram p) . fromMaybe noProgram)
getCurrentProgram :: IO Program
getCurrentProgram = fmap Program $ getInteger1 fromIntegral GetCurrentProgram
noProgram :: Program
noProgram = Program 0
validateProgram :: Program -> IO ()
validateProgram (Program program) = glValidateProgram program
programInfoLog :: Program -> GettableStateVar String
programInfoLog p =
stringQuery (programInfoLogLength p) (glGetProgramInfoLog (programID p))
programDeleteStatus :: Program -> GettableStateVar Bool
programDeleteStatus = programVar unmarshalGLboolean ProgramDeleteStatus
linkStatus :: Program -> GettableStateVar Bool
linkStatus = programVar unmarshalGLboolean LinkStatus
validateStatus :: Program -> GettableStateVar Bool
validateStatus = programVar unmarshalGLboolean ValidateStatus
programInfoLogLength :: Program -> GettableStateVar GLsizei
programInfoLogLength = programVar fromIntegral ProgramInfoLogLength
numAttachedShaders :: Program -> GettableStateVar GLsizei
numAttachedShaders = programVar fromIntegral AttachedShaders
data GetProgramPName =
ProgramDeleteStatus
| LinkStatus
| ValidateStatus
| ProgramInfoLogLength
| AttachedShaders
| ActiveAttributes
| ActiveAttributeMaxLength
| ActiveUniforms
| ActiveUniformMaxLength
| TransformFeedbackBufferMode
| TransformFeedbackVaryings
| TransformFeedbackVaryingMaxLength
marshalGetProgramPName :: GetProgramPName -> GLenum
marshalGetProgramPName x = case x of
ProgramDeleteStatus -> gl_DELETE_STATUS
LinkStatus -> gl_LINK_STATUS
ValidateStatus -> gl_VALIDATE_STATUS
ProgramInfoLogLength -> gl_INFO_LOG_LENGTH
AttachedShaders -> gl_ATTACHED_SHADERS
ActiveAttributes -> gl_ACTIVE_ATTRIBUTES
ActiveAttributeMaxLength -> gl_ACTIVE_ATTRIBUTE_MAX_LENGTH
ActiveUniforms -> gl_ACTIVE_UNIFORMS
ActiveUniformMaxLength -> gl_ACTIVE_UNIFORM_MAX_LENGTH
TransformFeedbackBufferMode -> gl_TRANSFORM_FEEDBACK_BUFFER_MODE
TransformFeedbackVaryings -> gl_TRANSFORM_FEEDBACK_VARYINGS
TransformFeedbackVaryingMaxLength -> gl_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH
programVar :: (GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a
programVar f p program =
makeGettableStateVar $
alloca $ \buf -> do
glGetProgramiv (programID program) (marshalGetProgramPName p) buf
peek1 f buf
bindFragDataLocation :: Program -> String -> SettableStateVar DrawBufferIndex
bindFragDataLocation (Program program) varName = makeSettableStateVar $ \ind ->
withGLString varName $ glBindFragDataLocation program ind
getFragDataLocation :: Program -> String -> IO (Maybe DrawBufferIndex)
getFragDataLocation (Program program) varName = do
r <- withGLString varName $ glGetFragDataLocation program
if r < 0
then return Nothing
else return . Just $ fromIntegral r