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

module Graphics.Rendering.OpenGL.GL.Shaders.ShaderObjects (
   -- * Shader Objects
   shaderCompiler,
   ShaderType(..), Shader, createShader,
   shaderSourceBS, shaderSource, compileShader, releaseShaderCompiler,

   -- * Shader Queries
   shaderType, shaderDeleteStatus, compileStatus, shaderInfoLog,
   PrecisionType, shaderPrecisionFormat,

   -- * Bytestring utilities
   packUtf8, unpackUtf8
) where

import Control.Monad
import Data.StateVar
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Foreign.Storable
import Graphics.Rendering.OpenGL.GL.ByteString
import Graphics.Rendering.OpenGL.GL.GLboolean
import Graphics.Rendering.OpenGL.GL.PeekPoke
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.Rendering.OpenGL.GL.Shaders.Shader
import Graphics.GL

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

shaderCompiler :: GettableStateVar Bool
shaderCompiler :: GettableStateVar Bool
shaderCompiler =
   forall a. IO a -> IO a
makeGettableStateVar (forall p a. GetPName1I p => (GLboolean -> a) -> p -> IO a
getBoolean1 forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean PName1I
GetShaderCompiler)

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

data ShaderType =
     VertexShader
   | TessControlShader
   | TessEvaluationShader
   | GeometryShader
   | FragmentShader
   | ComputeShader
   deriving ( ShaderType -> ShaderType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShaderType -> ShaderType -> Bool
$c/= :: ShaderType -> ShaderType -> Bool
== :: ShaderType -> ShaderType -> Bool
$c== :: ShaderType -> ShaderType -> Bool
Eq, Eq ShaderType
ShaderType -> ShaderType -> Bool
ShaderType -> ShaderType -> Ordering
ShaderType -> ShaderType -> ShaderType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ShaderType -> ShaderType -> ShaderType
$cmin :: ShaderType -> ShaderType -> ShaderType
max :: ShaderType -> ShaderType -> ShaderType
$cmax :: ShaderType -> ShaderType -> ShaderType
>= :: ShaderType -> ShaderType -> Bool
$c>= :: ShaderType -> ShaderType -> Bool
> :: ShaderType -> ShaderType -> Bool
$c> :: ShaderType -> ShaderType -> Bool
<= :: ShaderType -> ShaderType -> Bool
$c<= :: ShaderType -> ShaderType -> Bool
< :: ShaderType -> ShaderType -> Bool
$c< :: ShaderType -> ShaderType -> Bool
compare :: ShaderType -> ShaderType -> Ordering
$ccompare :: ShaderType -> ShaderType -> Ordering
Ord, Int -> ShaderType -> ShowS
[ShaderType] -> ShowS
ShaderType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShaderType] -> ShowS
$cshowList :: [ShaderType] -> ShowS
show :: ShaderType -> String
$cshow :: ShaderType -> String
showsPrec :: Int -> ShaderType -> ShowS
$cshowsPrec :: Int -> ShaderType -> ShowS
Show )

marshalShaderType :: ShaderType -> GLenum
marshalShaderType :: ShaderType -> GLenum
marshalShaderType ShaderType
x = case ShaderType
x of
   ShaderType
VertexShader -> GLenum
GL_VERTEX_SHADER
   ShaderType
TessControlShader -> GLenum
GL_TESS_CONTROL_SHADER
   ShaderType
TessEvaluationShader -> GLenum
GL_TESS_EVALUATION_SHADER
   ShaderType
GeometryShader -> GLenum
GL_GEOMETRY_SHADER
   ShaderType
FragmentShader -> GLenum
GL_FRAGMENT_SHADER
   ShaderType
ComputeShader -> GLenum
GL_COMPUTE_SHADER

unmarshalShaderType :: GLenum -> ShaderType
unmarshalShaderType :: GLenum -> ShaderType
unmarshalShaderType GLenum
x
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_VERTEX_SHADER = ShaderType
VertexShader
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_TESS_CONTROL_SHADER = ShaderType
TessControlShader
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_TESS_EVALUATION_SHADER = ShaderType
TessEvaluationShader
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_GEOMETRY_SHADER = ShaderType
GeometryShader
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_FRAGMENT_SHADER = ShaderType
FragmentShader
   | GLenum
x forall a. Eq a => a -> a -> Bool
== GLenum
GL_COMPUTE_SHADER = ShaderType
ComputeShader
   | Bool
otherwise = forall a. HasCallStack => String -> a
error (String
"unmarshalShaderType: illegal value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GLenum
x)

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

createShader :: ShaderType -> IO Shader
createShader :: ShaderType -> IO Shader
createShader = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GLenum -> Shader
Shader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadIO m => GLenum -> m GLenum
glCreateShader forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShaderType -> GLenum
marshalShaderType

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

-- | UTF8 encoded.
shaderSourceBS :: Shader -> StateVar ByteString
shaderSourceBS :: Shader -> StateVar ByteString
shaderSourceBS Shader
shader =
   forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar (Shader -> IO ByteString
getShaderSource Shader
shader) (Shader -> ByteString -> IO ()
setShaderSource Shader
shader)

getShaderSource :: Shader -> IO ByteString
getShaderSource :: Shader -> IO ByteString
getShaderSource = forall a.
(a -> GettableStateVar GLint)
-> (a -> GLint -> Ptr GLint -> Ptr GLchar -> IO ())
-> a
-> IO ByteString
stringQuery Shader -> GettableStateVar GLint
shaderSourceLength (forall (m :: * -> *).
MonadIO m =>
GLenum -> GLint -> Ptr GLint -> Ptr GLchar -> m ()
glGetShaderSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shader -> GLenum
shaderID)

shaderSourceLength :: Shader -> GettableStateVar GLsizei
shaderSourceLength :: Shader -> GettableStateVar GLint
shaderSourceLength = forall a.
(GLint -> a) -> GetShaderPName -> Shader -> GettableStateVar a
shaderVar forall a b. (Integral a, Num b) => a -> b
fromIntegral GetShaderPName
ShaderSourceLength

setShaderSource :: Shader -> ByteString -> IO ()
setShaderSource :: Shader -> ByteString -> IO ()
setShaderSource Shader
shader ByteString
src =
   forall b. ByteString -> (Ptr GLchar -> GLint -> IO b) -> IO b
withByteString ByteString
src forall a b. (a -> b) -> a -> b
$ \Ptr GLchar
srcPtr GLint
srcLength ->
      forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Ptr GLchar
srcPtr forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr GLchar)
srcPtrBuf ->
         forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLint
srcLength forall a b. (a -> b) -> a -> b
$ \Ptr GLint
srcLengthBuf ->
            forall (m :: * -> *).
MonadIO m =>
GLenum -> GLint -> Ptr (Ptr GLchar) -> Ptr GLint -> m ()
glShaderSource (Shader -> GLenum
shaderID Shader
shader) GLint
1 Ptr (Ptr GLchar)
srcPtrBuf Ptr GLint
srcLengthBuf

{-# DEPRECATED shaderSource "Use a combination of 'shaderSourceBS' and 'packUtf8' or 'unpackUtf8' instead." #-}
shaderSource :: Shader -> StateVar [String]
shaderSource :: Shader -> StateVar [String]
shaderSource Shader
shader =
   forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar
     (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
unpackUtf8) forall a b. (a -> b) -> a -> b
$ forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Shader -> StateVar ByteString
shaderSourceBS Shader
shader))
     ((Shader -> StateVar ByteString
shaderSourceBS Shader
shader forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
packUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)

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

compileShader :: Shader -> IO ()
compileShader :: Shader -> IO ()
compileShader = forall (m :: * -> *). MonadIO m => GLenum -> m ()
glCompileShader forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shader -> GLenum
shaderID

releaseShaderCompiler :: IO ()
releaseShaderCompiler :: IO ()
releaseShaderCompiler = forall (m :: * -> *). MonadIO m => m ()
glReleaseShaderCompiler

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

shaderType :: Shader -> GettableStateVar ShaderType
shaderType :: Shader -> GettableStateVar ShaderType
shaderType = forall a.
(GLint -> a) -> GetShaderPName -> Shader -> GettableStateVar a
shaderVar (GLenum -> ShaderType
unmarshalShaderType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) GetShaderPName
ShaderType

shaderDeleteStatus :: Shader -> GettableStateVar Bool
shaderDeleteStatus :: Shader -> GettableStateVar Bool
shaderDeleteStatus = forall a.
(GLint -> a) -> GetShaderPName -> Shader -> GettableStateVar a
shaderVar forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean GetShaderPName
ShaderDeleteStatus

compileStatus :: Shader -> GettableStateVar Bool
compileStatus :: Shader -> GettableStateVar Bool
compileStatus = forall a.
(GLint -> a) -> GetShaderPName -> Shader -> GettableStateVar a
shaderVar forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean GetShaderPName
CompileStatus

shaderInfoLog :: Shader -> GettableStateVar String
shaderInfoLog :: Shader -> GettableStateVar String
shaderInfoLog =
   forall a. IO a -> IO a
makeGettableStateVar forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
unpackUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         forall a.
(a -> GettableStateVar GLint)
-> (a -> GLint -> Ptr GLint -> Ptr GLchar -> IO ())
-> a
-> IO ByteString
stringQuery Shader -> GettableStateVar GLint
shaderInfoLogLength (forall (m :: * -> *).
MonadIO m =>
GLenum -> GLint -> Ptr GLint -> Ptr GLchar -> m ()
glGetShaderInfoLog forall b c a. (b -> c) -> (a -> b) -> a -> c
. Shader -> GLenum
shaderID)

shaderInfoLogLength :: Shader -> GettableStateVar GLsizei
shaderInfoLogLength :: Shader -> GettableStateVar GLint
shaderInfoLogLength = forall a.
(GLint -> a) -> GetShaderPName -> Shader -> GettableStateVar a
shaderVar forall a b. (Integral a, Num b) => a -> b
fromIntegral GetShaderPName
ShaderInfoLogLength

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

data GetShaderPName =
     ShaderDeleteStatus
   | CompileStatus
   | ShaderInfoLogLength
   | ShaderSourceLength
   | ShaderType

marshalGetShaderPName :: GetShaderPName -> GLenum
marshalGetShaderPName :: GetShaderPName -> GLenum
marshalGetShaderPName GetShaderPName
x = case GetShaderPName
x of
   GetShaderPName
ShaderDeleteStatus -> GLenum
GL_DELETE_STATUS
   GetShaderPName
CompileStatus -> GLenum
GL_COMPILE_STATUS
   GetShaderPName
ShaderInfoLogLength -> GLenum
GL_INFO_LOG_LENGTH
   GetShaderPName
ShaderSourceLength -> GLenum
GL_SHADER_SOURCE_LENGTH
   GetShaderPName
ShaderType -> GLenum
GL_SHADER_TYPE

shaderVar :: (GLint -> a) -> GetShaderPName -> Shader -> GettableStateVar a
shaderVar :: forall a.
(GLint -> a) -> GetShaderPName -> Shader -> GettableStateVar a
shaderVar GLint -> a
f GetShaderPName
p Shader
shader =
   forall a. IO a -> IO a
makeGettableStateVar forall a b. (a -> b) -> a -> b
$
      forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLint
0 forall a b. (a -> b) -> a -> b
$ \Ptr GLint
buf -> do
         forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> Ptr GLint -> m ()
glGetShaderiv (Shader -> GLenum
shaderID Shader
shader) (GetShaderPName -> GLenum
marshalGetShaderPName GetShaderPName
p) Ptr GLint
buf
         forall a b. Storable a => (a -> b) -> Ptr a -> IO b
peek1 GLint -> a
f Ptr GLint
buf

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

data PrecisionType =
     LowFloat
   | MediumFloat
   | HighFloat
   | LowInt
   | MediumInt
   | HighInt
   deriving ( PrecisionType -> PrecisionType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrecisionType -> PrecisionType -> Bool
$c/= :: PrecisionType -> PrecisionType -> Bool
== :: PrecisionType -> PrecisionType -> Bool
$c== :: PrecisionType -> PrecisionType -> Bool
Eq, Eq PrecisionType
PrecisionType -> PrecisionType -> Bool
PrecisionType -> PrecisionType -> Ordering
PrecisionType -> PrecisionType -> PrecisionType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PrecisionType -> PrecisionType -> PrecisionType
$cmin :: PrecisionType -> PrecisionType -> PrecisionType
max :: PrecisionType -> PrecisionType -> PrecisionType
$cmax :: PrecisionType -> PrecisionType -> PrecisionType
>= :: PrecisionType -> PrecisionType -> Bool
$c>= :: PrecisionType -> PrecisionType -> Bool
> :: PrecisionType -> PrecisionType -> Bool
$c> :: PrecisionType -> PrecisionType -> Bool
<= :: PrecisionType -> PrecisionType -> Bool
$c<= :: PrecisionType -> PrecisionType -> Bool
< :: PrecisionType -> PrecisionType -> Bool
$c< :: PrecisionType -> PrecisionType -> Bool
compare :: PrecisionType -> PrecisionType -> Ordering
$ccompare :: PrecisionType -> PrecisionType -> Ordering
Ord, Int -> PrecisionType -> ShowS
[PrecisionType] -> ShowS
PrecisionType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrecisionType] -> ShowS
$cshowList :: [PrecisionType] -> ShowS
show :: PrecisionType -> String
$cshow :: PrecisionType -> String
showsPrec :: Int -> PrecisionType -> ShowS
$cshowsPrec :: Int -> PrecisionType -> ShowS
Show )

marshalPrecisionType :: PrecisionType -> GLenum
marshalPrecisionType :: PrecisionType -> GLenum
marshalPrecisionType PrecisionType
x = case PrecisionType
x of
   PrecisionType
LowFloat -> GLenum
GL_LOW_FLOAT
   PrecisionType
MediumFloat -> GLenum
GL_MEDIUM_FLOAT
   PrecisionType
HighFloat -> GLenum
GL_HIGH_FLOAT
   PrecisionType
LowInt -> GLenum
GL_LOW_INT
   PrecisionType
MediumInt -> GLenum
GL_MEDIUM_INT
   PrecisionType
HighInt -> GLenum
GL_HIGH_INT

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

shaderPrecisionFormat :: ShaderType
                      -> PrecisionType
                      -> GettableStateVar ((GLint,GLint),GLint)
shaderPrecisionFormat :: ShaderType
-> PrecisionType -> GettableStateVar ((GLint, GLint), GLint)
shaderPrecisionFormat ShaderType
st PrecisionType
pt =
   forall a. IO a -> IO a
makeGettableStateVar forall a b. (a -> b) -> a -> b
$
      forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
2 forall a b. (a -> b) -> a -> b
$ \Ptr GLint
rangeBuf ->
         forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr GLint
precisionBuf -> do
            forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> Ptr GLint -> Ptr GLint -> m ()
glGetShaderPrecisionFormat (ShaderType -> GLenum
marshalShaderType ShaderType
st)
                                       (PrecisionType -> GLenum
marshalPrecisionType PrecisionType
pt)
                                       Ptr GLint
rangeBuf
                                       Ptr GLint
precisionBuf
            forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall a b. Storable a => (a -> a -> b) -> Ptr a -> IO b
peek2 (,) Ptr GLint
rangeBuf) (forall a. Storable a => Ptr a -> IO a
peek Ptr GLint
precisionBuf)