-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects
-- Copyright   :  (c) Sven Panne 2006-2019
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module corresponds to section 7.3 (Program Objects) of the OpenGL 4.4
-- spec.
--
-----------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GL.Shaders.ProgramObjects (
   -- * Program Objects
   Program, createProgram, programDeleteStatus,
   attachShader, detachShader, attachedShaders,
   linkProgram, linkStatus,
   validateProgram, validateStatus,
   programInfoLog,
   currentProgram,
   programSeparable, programBinaryRetrievableHint,

   -- TODOs:
   --    glCreateShaderProgramv
   --    ProgramInterface type (from 7.3.1)
   --    glGetProgramInterfaceiv
   --    glGetProgramResourceIndex
   --    glGetProgramResourceName
   --    glGetProgramResourceiv
   --    glGetProgramResourceLocation
   --    glGetProgramResourceLocationIndex

   -- * Fragment Data
   bindFragDataLocation, getFragDataLocation
) where

import Data.List
import Data.Maybe
import Data.StateVar
import Foreign.Marshal.Array
import Foreign.Ptr
import Graphics.Rendering.OpenGL.GL.ByteString
import Graphics.Rendering.OpenGL.GL.Framebuffer
import Graphics.Rendering.OpenGL.GL.GLboolean
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.Rendering.OpenGL.GL.Shaders.Program
import Graphics.Rendering.OpenGL.GL.Shaders.Shader
import Graphics.GL

--------------------------------------------------------------------------------

createProgram :: IO Program
createProgram :: IO Program
createProgram = (DrawBufferIndex -> Program) -> IO DrawBufferIndex -> IO Program
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DrawBufferIndex -> Program
Program IO DrawBufferIndex
forall (m :: * -> *). MonadIO m => m DrawBufferIndex
glCreateProgram

--------------------------------------------------------------------------------

attachShader :: Program -> Shader -> IO ()
attachShader :: Program -> Shader -> IO ()
attachShader Program
p Shader
s = DrawBufferIndex -> DrawBufferIndex -> IO ()
forall (m :: * -> *).
MonadIO m =>
DrawBufferIndex -> DrawBufferIndex -> m ()
glAttachShader (Program -> DrawBufferIndex
programID Program
p) (Shader -> DrawBufferIndex
shaderID Shader
s)

detachShader :: Program -> Shader -> IO ()
detachShader :: Program -> Shader -> IO ()
detachShader Program
p Shader
s = DrawBufferIndex -> DrawBufferIndex -> IO ()
forall (m :: * -> *).
MonadIO m =>
DrawBufferIndex -> DrawBufferIndex -> m ()
glDetachShader (Program -> DrawBufferIndex
programID Program
p) (Shader -> DrawBufferIndex
shaderID Shader
s)

attachedShaders :: Program -> StateVar [Shader]
attachedShaders :: Program -> StateVar [Shader]
attachedShaders Program
program =
   IO [Shader] -> ([Shader] -> IO ()) -> StateVar [Shader]
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar (Program -> IO [Shader]
getAttachedShaders Program
program) (Program -> [Shader] -> IO ()
setAttachedShaders Program
program)

getAttachedShaders :: Program -> IO [Shader]
getAttachedShaders :: Program -> IO [Shader]
getAttachedShaders Program
program = do
   GLint
numShaders <- GettableStateVar GLint -> GettableStateVar GLint
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
GettableStateVar GLint -> m GLint
get (Program -> GettableStateVar GLint
numAttachedShaders Program
program)
   [DrawBufferIndex]
ids <- Int
-> (Ptr DrawBufferIndex -> IO [DrawBufferIndex])
-> IO [DrawBufferIndex]
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (GLint -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
numShaders) ((Ptr DrawBufferIndex -> IO [DrawBufferIndex])
 -> IO [DrawBufferIndex])
-> (Ptr DrawBufferIndex -> IO [DrawBufferIndex])
-> IO [DrawBufferIndex]
forall a b. (a -> b) -> a -> b
$ \Ptr DrawBufferIndex
buf -> do
      DrawBufferIndex
-> GLint -> Ptr GLint -> Ptr DrawBufferIndex -> IO ()
forall (m :: * -> *).
MonadIO m =>
DrawBufferIndex
-> GLint -> Ptr GLint -> Ptr DrawBufferIndex -> m ()
glGetAttachedShaders (Program -> DrawBufferIndex
programID Program
program) GLint
numShaders Ptr GLint
forall a. Ptr a
nullPtr Ptr DrawBufferIndex
buf
      Int -> Ptr DrawBufferIndex -> IO [DrawBufferIndex]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (GLint -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
numShaders) Ptr DrawBufferIndex
buf
   [Shader] -> IO [Shader]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Shader] -> IO [Shader]) -> [Shader] -> IO [Shader]
forall a b. (a -> b) -> a -> b
$ (DrawBufferIndex -> Shader) -> [DrawBufferIndex] -> [Shader]
forall a b. (a -> b) -> [a] -> [b]
map DrawBufferIndex -> Shader
Shader [DrawBufferIndex]
ids

setAttachedShaders :: Program -> [Shader] -> IO ()
setAttachedShaders :: Program -> [Shader] -> IO ()
setAttachedShaders Program
program [Shader]
newShaders = do
   [Shader]
currentShaders <- Program -> IO [Shader]
getAttachedShaders Program
program
   (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
program) ([Shader]
newShaders [Shader] -> [Shader] -> [Shader]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Shader]
currentShaders)
   (Shader -> IO ()) -> [Shader] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Program -> Shader -> IO ()
detachShader Program
program) ([Shader]
currentShaders [Shader] -> [Shader] -> [Shader]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Shader]
newShaders)

--------------------------------------------------------------------------------

linkProgram :: Program -> IO ()
linkProgram :: Program -> IO ()
linkProgram = DrawBufferIndex -> IO ()
forall (m :: * -> *). MonadIO m => DrawBufferIndex -> m ()
glLinkProgram (DrawBufferIndex -> IO ())
-> (Program -> DrawBufferIndex) -> Program -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> DrawBufferIndex
programID

currentProgram :: StateVar (Maybe Program)
currentProgram :: StateVar (Maybe Program)
currentProgram =
   IO (Maybe Program)
-> (Maybe Program -> IO ()) -> StateVar (Maybe Program)
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar
      (do Program
p <- (DrawBufferIndex -> Program) -> IO DrawBufferIndex -> IO Program
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DrawBufferIndex -> Program
Program (IO DrawBufferIndex -> IO Program)
-> IO DrawBufferIndex -> IO Program
forall a b. (a -> b) -> a -> b
$ (GLint -> DrawBufferIndex) -> PName1I -> IO DrawBufferIndex
forall p a. GetPName1I p => (GLint -> a) -> p -> IO a
forall a. (GLint -> a) -> PName1I -> IO a
getInteger1 GLint -> DrawBufferIndex
forall a b. (Integral a, Num b) => a -> b
fromIntegral PName1I
GetCurrentProgram
          Maybe Program -> IO (Maybe Program)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Program -> IO (Maybe Program))
-> Maybe Program -> IO (Maybe Program)
forall a b. (a -> b) -> a -> b
$ if Program
p Program -> Program -> Bool
forall a. Eq a => a -> a -> Bool
== Program
noProgram then Maybe Program
forall a. Maybe a
Nothing else Program -> Maybe Program
forall a. a -> Maybe a
Just Program
p)
      (DrawBufferIndex -> IO ()
forall (m :: * -> *). MonadIO m => DrawBufferIndex -> m ()
glUseProgram (DrawBufferIndex -> IO ())
-> (Maybe Program -> DrawBufferIndex) -> Maybe Program -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> DrawBufferIndex
programID (Program -> DrawBufferIndex)
-> (Maybe Program -> Program) -> Maybe Program -> DrawBufferIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> Maybe Program -> Program
forall a. a -> Maybe a -> a
fromMaybe Program
noProgram)

noProgram :: Program
noProgram :: Program
noProgram = DrawBufferIndex -> Program
Program DrawBufferIndex
0

validateProgram :: Program -> IO ()
validateProgram :: Program -> IO ()
validateProgram = DrawBufferIndex -> IO ()
forall (m :: * -> *). MonadIO m => DrawBufferIndex -> m ()
glValidateProgram (DrawBufferIndex -> IO ())
-> (Program -> DrawBufferIndex) -> Program -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> DrawBufferIndex
programID

programInfoLog :: Program -> GettableStateVar String
programInfoLog :: Program -> GettableStateVar String
programInfoLog =
   GettableStateVar String -> GettableStateVar String
forall a. IO a -> IO a
makeGettableStateVar (GettableStateVar String -> GettableStateVar String)
-> (Program -> GettableStateVar String)
-> Program
-> GettableStateVar String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (ByteString -> String) -> IO ByteString -> GettableStateVar String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
unpackUtf8 (IO ByteString -> GettableStateVar String)
-> (Program -> IO ByteString) -> Program -> GettableStateVar String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         (Program -> GettableStateVar GLint)
-> (Program -> GLint -> Ptr GLint -> Ptr GLchar -> IO ())
-> Program
-> IO ByteString
forall a.
(a -> GettableStateVar GLint)
-> (a -> GLint -> Ptr GLint -> Ptr GLchar -> IO ())
-> a
-> IO ByteString
stringQuery Program -> GettableStateVar GLint
programInfoLogLength (DrawBufferIndex -> GLint -> Ptr GLint -> Ptr GLchar -> IO ()
forall (m :: * -> *).
MonadIO m =>
DrawBufferIndex -> GLint -> Ptr GLint -> Ptr GLchar -> m ()
glGetProgramInfoLog (DrawBufferIndex -> GLint -> Ptr GLint -> Ptr GLchar -> IO ())
-> (Program -> DrawBufferIndex)
-> Program
-> GLint
-> Ptr GLint
-> Ptr GLchar
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> DrawBufferIndex
programID)

--------------------------------------------------------------------------------

programSeparable :: Program -> StateVar Bool
programSeparable :: Program -> StateVar Bool
programSeparable = GetProgramPName -> Program -> StateVar Bool
programStateVarBool GetProgramPName
ProgramSeparable

programBinaryRetrievableHint :: Program -> StateVar Bool
programBinaryRetrievableHint :: Program -> StateVar Bool
programBinaryRetrievableHint = GetProgramPName -> Program -> StateVar Bool
programStateVarBool GetProgramPName
ProgramBinaryRetrievableHint

programStateVarBool :: GetProgramPName -> Program -> StateVar Bool
programStateVarBool :: GetProgramPName -> Program -> StateVar Bool
programStateVarBool GetProgramPName
pname Program
program =
   GettableStateVar Bool -> (Bool -> IO ()) -> StateVar Bool
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar
      (GettableStateVar Bool -> GettableStateVar Bool
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => GettableStateVar Bool -> m Bool
get ((GLint -> Bool)
-> GetProgramPName -> Program -> GettableStateVar Bool
forall a.
(GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a
programVar1 GLint -> Bool
forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean GetProgramPName
pname Program
program))
      (DrawBufferIndex -> DrawBufferIndex -> GLint -> IO ()
forall (m :: * -> *).
MonadIO m =>
DrawBufferIndex -> DrawBufferIndex -> GLint -> m ()
glProgramParameteri (Program -> DrawBufferIndex
programID Program
program)
                           (GetProgramPName -> DrawBufferIndex
marshalGetProgramPName GetProgramPName
pname) (GLint -> IO ()) -> (Bool -> GLint) -> Bool -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> GLint
forall a. Num a => Bool -> a
marshalGLboolean)

--------------------------------------------------------------------------------

programDeleteStatus :: Program -> GettableStateVar Bool
programDeleteStatus :: Program -> GettableStateVar Bool
programDeleteStatus = (GLint -> Bool)
-> GetProgramPName -> Program -> GettableStateVar Bool
forall a.
(GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a
programVar1 GLint -> Bool
forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean GetProgramPName
ProgramDeleteStatus

linkStatus :: Program -> GettableStateVar Bool
linkStatus :: Program -> GettableStateVar Bool
linkStatus = (GLint -> Bool)
-> GetProgramPName -> Program -> GettableStateVar Bool
forall a.
(GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a
programVar1 GLint -> Bool
forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean GetProgramPName
LinkStatus

validateStatus :: Program -> GettableStateVar Bool
validateStatus :: Program -> GettableStateVar Bool
validateStatus = (GLint -> Bool)
-> GetProgramPName -> Program -> GettableStateVar Bool
forall a.
(GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a
programVar1 GLint -> Bool
forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean GetProgramPName
ValidateStatus

programInfoLogLength :: Program -> GettableStateVar GLsizei
programInfoLogLength :: Program -> GettableStateVar GLint
programInfoLogLength = (GLint -> GLint)
-> GetProgramPName -> Program -> GettableStateVar GLint
forall a.
(GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a
programVar1 GLint -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral GetProgramPName
ProgramInfoLogLength

numAttachedShaders :: Program -> GettableStateVar GLsizei
numAttachedShaders :: Program -> GettableStateVar GLint
numAttachedShaders = (GLint -> GLint)
-> GetProgramPName -> Program -> GettableStateVar GLint
forall a.
(GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a
programVar1 GLint -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral GetProgramPName
AttachedShaders

--------------------------------------------------------------------------------

-- | 'bindFragDataLocation' binds a varying variable, specified by program and name, to a
-- drawbuffer. The effects only take place after succesfull linking of the program.
-- invalid arguments and conditions are
-- - an index larger than maxDrawBufferIndex
-- - names starting with 'gl_'
-- linking failure will ocure when
-- - one of the arguments was invalid
-- - more than one varying varuable name is bound to the same index
-- It's not an error to specify unused variables, those will be ingored.
bindFragDataLocation :: Program -> String -> SettableStateVar DrawBufferIndex
bindFragDataLocation :: Program -> String -> SettableStateVar DrawBufferIndex
bindFragDataLocation (Program DrawBufferIndex
program) String
varName = (DrawBufferIndex -> IO ()) -> SettableStateVar DrawBufferIndex
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar ((DrawBufferIndex -> IO ()) -> SettableStateVar DrawBufferIndex)
-> (DrawBufferIndex -> IO ()) -> SettableStateVar DrawBufferIndex
forall a b. (a -> b) -> a -> b
$ \DrawBufferIndex
ind ->
   String -> (Ptr GLchar -> IO ()) -> IO ()
forall a. String -> (Ptr GLchar -> IO a) -> IO a
withGLstring String
varName ((Ptr GLchar -> IO ()) -> IO ()) -> (Ptr GLchar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ DrawBufferIndex -> DrawBufferIndex -> Ptr GLchar -> IO ()
forall (m :: * -> *).
MonadIO m =>
DrawBufferIndex -> DrawBufferIndex -> Ptr GLchar -> m ()
glBindFragDataLocation DrawBufferIndex
program DrawBufferIndex
ind

-- | query the binding of a given variable, specified by program and name. The program has to be
-- linked. The result is Nothing if an error occures or the name is not a name of a varying
-- variable. If the program hasn't been linked an 'InvalidOperation' error is generated.
getFragDataLocation :: Program -> String -> IO (Maybe DrawBufferIndex)
getFragDataLocation :: Program -> String -> IO (Maybe DrawBufferIndex)
getFragDataLocation (Program DrawBufferIndex
program) String
varName = do
   GLint
r <- String
-> (Ptr GLchar -> GettableStateVar GLint) -> GettableStateVar GLint
forall a. String -> (Ptr GLchar -> IO a) -> IO a
withGLstring String
varName ((Ptr GLchar -> GettableStateVar GLint) -> GettableStateVar GLint)
-> (Ptr GLchar -> GettableStateVar GLint) -> GettableStateVar GLint
forall a b. (a -> b) -> a -> b
$ DrawBufferIndex -> Ptr GLchar -> GettableStateVar GLint
forall (m :: * -> *).
MonadIO m =>
DrawBufferIndex -> Ptr GLchar -> m GLint
glGetFragDataLocation DrawBufferIndex
program
   if GLint
r GLint -> GLint -> Bool
forall a. Ord a => a -> a -> Bool
< GLint
0
    then Maybe DrawBufferIndex -> IO (Maybe DrawBufferIndex)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DrawBufferIndex
forall a. Maybe a
Nothing
    else Maybe DrawBufferIndex -> IO (Maybe DrawBufferIndex)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DrawBufferIndex -> IO (Maybe DrawBufferIndex))
-> (DrawBufferIndex -> Maybe DrawBufferIndex)
-> DrawBufferIndex
-> IO (Maybe DrawBufferIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawBufferIndex -> Maybe DrawBufferIndex
forall a. a -> Maybe a
Just (DrawBufferIndex -> IO (Maybe DrawBufferIndex))
-> DrawBufferIndex -> IO (Maybe DrawBufferIndex)
forall a b. (a -> b) -> a -> b
$ GLint -> DrawBufferIndex
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
r