    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.Rendering.OpenGL.GL.Shaders
    -- Copyright   :  (c) Sven Panne 2002-2009
    -- License     :  BSD-style (see the file libraries/OpenGL/LICENSE)
    --
    -- Maintainer  :  sven.panne@aedion.de
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- This module corresponds to sections 2.15 (Vertex Shaders) and section 3.11
    -- (Fragment Shaders) of the OpenGL 2.1 specs.
    --
    --------------------------------------------------------------------------------

    module Graphics.Rendering.OpenGL.GL.Shaders (
       -- * Shader Objects
       Shader, VertexShader, FragmentShader, shaderDeleteStatus, shaderSource,
       compileShader, compileStatus, shaderInfoLog,

       -- * Program Objects
       Program, programDeleteStatus, attachedShaders, linkProgram, linkStatus,
       programInfoLog, validateProgram, validateStatus, currentProgram,

       -- * Vertex attributes
       attribLocation, VariableType(..), activeAttribs,

       -- * Uniform variables
       UniformLocation, uniformLocation, activeUniforms, Uniform(..),
       UniformComponent,

       -- * Implementation limits related to GLSL
       maxVertexTextureImageUnits, maxTextureImageUnits,
       maxCombinedTextureImageUnits, maxTextureCoords, maxVertexUniformComponents,
       maxFragmentUniformComponents, maxVertexAttribs, maxVaryingFloats
    ) where

    import Control.Monad
    import Control.Monad.Fix
    import Data.List
    import Data.ObjectName
    import Data.StateVar
    import Data.Tensor
    import Foreign.C.String
    import Foreign.Marshal.Alloc
    import Foreign.Marshal.Array
    import Foreign.Marshal.Utils
    import Foreign.Ptr
    import Foreign.Storable
    import Graphics.Rendering.OpenGL.GL.GLboolean
    import Graphics.Rendering.OpenGL.GL.PeekPoke
    import Graphics.Rendering.OpenGL.GL.QueryUtils
    import Graphics.Rendering.OpenGL.GL.VertexSpec
    import Graphics.Rendering.OpenGL.Raw.Core31

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

    type GLStringLen = (Ptr GLchar, GLsizei)

    peekGLstringLen :: GLStringLen -> IO String
    peekGLstringLen (p,l) = peekCAStringLen (castPtr p, fromIntegral l)

    withGLStringLen :: String -> (GLStringLen -> IO a) -> IO a
    withGLStringLen s act =
       withCAStringLen s $ \(p,len) ->
          act (castPtr p, fromIntegral len)

    withGLString :: String -> (Ptr GLchar -> IO a) -> IO a
    withGLString s act = withCAString s $ act . castPtr

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

    newtype VertexShader = VertexShader { vertexShaderID :: GLuint }
       deriving ( Eq, Ord, Show )

    newtype FragmentShader = FragmentShader { fragmentShaderID :: GLuint }
       deriving ( Eq, Ord, Show )

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

    class (Eq s, Ord s, Show s, ObjectName s) => Shader s where
       shaderID :: s -> GLuint
       makeShader :: GLuint -> s
       shaderType :: s -> GLenum

    instance Shader VertexShader where
       makeShader = VertexShader
       shaderID = vertexShaderID
       shaderType = const gl_VERTEX_SHADER

    instance Shader FragmentShader where
       makeShader = FragmentShader
       shaderID = fragmentShaderID
       shaderType = const gl_FRAGMENT_SHADER

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

    instance ObjectName VertexShader where
       genObjectNames = genShaderNames
       deleteObjectNames = deleteShaderNames
       isObjectName = isShaderName

    instance ObjectName FragmentShader where
       genObjectNames = genShaderNames
       deleteObjectNames = deleteShaderNames
       isObjectName = isShaderName

    genShaderNames :: Shader s => Int -> IO [s]
    genShaderNames n = replicateM n createShader

    createShader :: Shader s => IO s
    createShader = mfix (fmap makeShader . glCreateShader . shaderType)

    deleteShaderNames :: Shader s => [s] -> IO ()
    deleteShaderNames = mapM_ (glDeleteShader . shaderID)

    isShaderName :: Shader s => s -> IO Bool
    isShaderName = fmap unmarshalGLboolean . glIsShader . shaderID

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

    compileShader :: Shader s => s -> IO ()
    compileShader = glCompileShader . shaderID

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

    shaderSource :: Shader s => s -> StateVar [String]
    shaderSource shader =
       makeStateVar (getShaderSource shader) (setShaderSource shader)

    setShaderSource :: Shader s => s -> [String] -> IO ()
    setShaderSource shader srcs = do
       let len = genericLength srcs
       withMany withGLStringLen srcs $ \charBufsAndLengths -> do
          let (charBufs, lengths) = unzip charBufsAndLengths
          withArray charBufs $ \charBufsBuf ->
             withArray (map fromIntegral lengths) $ \lengthsBuf ->
                glShaderSource (shaderID shader) len charBufsBuf lengthsBuf

    getShaderSource :: Shader s => s -> IO [String]
    getShaderSource shader = do
       src <- get (stringQuery (shaderSourceLength shader)
                               (glGetShaderSource (shaderID shader)))
       return [src]

    stringQuery :: GettableStateVar GLsizei -> (GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()) -> GettableStateVar String
    stringQuery lengthVar getStr =
       makeGettableStateVar $ do
          len <- get lengthVar -- Note: This includes the NUL character!
          if len == 0
            then return ""
            else allocaArray (fromIntegral len) $ \buf -> do
                    getStr len nullPtr buf
                    peekGLstringLen (buf, len-1)

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

    shaderInfoLog :: Shader s => s -> GettableStateVar String
    shaderInfoLog shader =
       stringQuery (shaderInfoLogLength shader) (glGetShaderInfoLog (shaderID shader))

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

    shaderDeleteStatus :: Shader s => s -> GettableStateVar Bool
    shaderDeleteStatus = shaderVar unmarshalGLboolean ShaderDeleteStatus

    compileStatus :: Shader s => s -> GettableStateVar Bool
    compileStatus = shaderVar unmarshalGLboolean CompileStatus

    shaderInfoLogLength :: Shader s => s -> GettableStateVar GLsizei
    shaderInfoLogLength = shaderVar fromIntegral ShaderInfoLogLength

    shaderSourceLength :: Shader s => s -> GettableStateVar GLsizei
    shaderSourceLength = shaderVar fromIntegral ShaderSourceLength

    shaderTypeEnum :: Shader s => s -> GettableStateVar GLenum
    shaderTypeEnum = shaderVar fromIntegral ShaderType

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

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

    marshalGetShaderPName :: GetShaderPName -> GLenum
    marshalGetShaderPName x = case x of
       ShaderDeleteStatus -> gl_DELETE_STATUS
       CompileStatus -> gl_COMPILE_STATUS
       ShaderInfoLogLength -> gl_INFO_LOG_LENGTH
       ShaderSourceLength -> gl_SHADER_SOURCE_LENGTH
       ShaderType -> gl_SHADER_TYPE

    shaderVar :: Shader s => (GLint -> a) -> GetShaderPName -> s -> GettableStateVar a
    shaderVar f p shader =
       makeGettableStateVar $
          alloca $ \buf -> do
             glGetShaderiv (shaderID shader) (marshalGetShaderPName p) buf
             peek1 f buf

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

    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) . maybe noProgram id)

    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

    activeAttributes :: Program -> GettableStateVar GLuint
    activeAttributes = programVar fromIntegral ActiveAttributes

    activeAttributeMaxLength :: Program -> GettableStateVar GLsizei
    activeAttributeMaxLength = programVar fromIntegral ActiveAttributeMaxLength

    numActiveUniforms :: Program -> GettableStateVar GLuint
    numActiveUniforms = programVar fromIntegral ActiveUniforms

    activeUniformMaxLength :: Program -> GettableStateVar GLsizei
    activeUniformMaxLength = programVar fromIntegral ActiveUniformMaxLength

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

    data GetProgramPName =
         ProgramDeleteStatus
       | LinkStatus
       | ValidateStatus
       | ProgramInfoLogLength
       | AttachedShaders
       | ActiveAttributes
       | ActiveAttributeMaxLength
       | ActiveUniforms
       | ActiveUniformMaxLength

    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

    programVar :: (GLint -> a) -> GetProgramPName -> Program -> GettableStateVar a
    programVar f p program =
       makeGettableStateVar $
          alloca $ \buf -> do
             glGetProgramiv (programID program) (marshalGetProgramPName p) buf
             peek1 f buf

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

    attribLocation :: Program -> String -> StateVar AttribLocation
    attribLocation program name =
       makeStateVar (getAttribLocation program name)
                    (\location -> bindAttribLocation program location name)

    getAttribLocation :: Program -> String -> IO AttribLocation
    getAttribLocation (Program program) name =
       fmap (AttribLocation . fromIntegral) $
          withGLString name $
             glGetAttribLocation program

    bindAttribLocation :: Program -> AttribLocation -> String -> IO ()
    bindAttribLocation (Program program) (AttribLocation location) name =
       withGLString name $
          glBindAttribLocation program location

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

    -- Table 2.9 of the OpenGL 3.1 spec: OpenGL Shading Language type tokens
    data VariableType =
         Float'
       | FloatVec2
       | FloatVec3
       | FloatVec4
       | Int'
       | IntVec2
       | IntVec3
       | IntVec4
       | UnsignedInt'
       | UnsignedIntVec2
       | UnsignedIntVec3
       | UnsignedIntVec4
       | Bool
       | BoolVec2
       | BoolVec3
       | BoolVec4
       | FloatMat2
       | FloatMat3
       | FloatMat4
       | FloatMat2x3
       | FloatMat2x4
       | FloatMat3x2
       | FloatMat3x4
       | FloatMat4x2
       | FloatMat4x3
       | Sampler1D
       | Sampler2D
       | Sampler3D
       | SamplerCube
       | Sampler1DShadow
       | Sampler2DShadow
       | Sampler1DArray
       | Sampler2DArray
       | Sampler1DArrayShadow
       | Sampler2DArrayShadow
       | SamplerCubeShadow
       | Sampler2DRect
       | Sampler2DRectShadow
       | IntSampler1D
       | IntSampler2D
       | IntSampler3D
       | IntSamplerCube
       | IntSampler1DArray
       | IntSampler2DArray
       | UnsignedIntSampler1D
       | UnsignedIntSampler2D
       | UnsignedIntSampler3D
       | UnsignedIntSamplerCube
       | UnsignedIntSampler1DArray
       | UnsignedIntSampler2DArray
       deriving ( Eq, Ord, Show )

    unmarshalVariableType :: GLenum -> VariableType
    unmarshalVariableType x
       | x == gl_FLOAT = Float'
       | x == gl_FLOAT_VEC2 = FloatVec2
       | x == gl_FLOAT_VEC3 = FloatVec3
       | x == gl_FLOAT_VEC4 = FloatVec4
       | x == gl_INT = Int'
       | x == gl_INT_VEC2 = IntVec2
       | x == gl_INT_VEC3 = IntVec3
       | x == gl_INT_VEC4 = IntVec4
       | x == gl_UNSIGNED_INT = UnsignedInt'
       | x == gl_UNSIGNED_INT_VEC2 = UnsignedIntVec2
       | x == gl_UNSIGNED_INT_VEC3 = UnsignedIntVec3
       | x == gl_UNSIGNED_INT_VEC4 = UnsignedIntVec4
       | x == gl_BOOL = Bool
       | x == gl_BOOL_VEC2 = BoolVec2
       | x == gl_BOOL_VEC3 = BoolVec3
       | x == gl_BOOL_VEC4 = BoolVec4
       | x == gl_FLOAT_MAT2 = FloatMat2
       | x == gl_FLOAT_MAT3 = FloatMat3
       | x == gl_FLOAT_MAT4 = FloatMat4
       | x == gl_FLOAT_MAT2x3 = FloatMat2x3
       | x == gl_FLOAT_MAT2x4 = FloatMat2x4
       | x == gl_FLOAT_MAT3x2 = FloatMat3x2
       | x == gl_FLOAT_MAT3x4 = FloatMat3x4
       | x == gl_FLOAT_MAT4x2 = FloatMat4x2
       | x == gl_FLOAT_MAT4x3 = FloatMat4x3
       | x == gl_SAMPLER_1D = Sampler1D
       | x == gl_SAMPLER_2D = Sampler2D
       | x == gl_SAMPLER_3D = Sampler3D
       | x == gl_SAMPLER_CUBE = SamplerCube
       | x == gl_SAMPLER_1D_SHADOW = Sampler1DShadow
       | x == gl_SAMPLER_2D_SHADOW = Sampler2DShadow
       | x == gl_SAMPLER_1D_ARRAY = Sampler1DArray
       | x == gl_SAMPLER_2D_ARRAY = Sampler2DArray
       | x == gl_SAMPLER_1D_ARRAY_SHADOW = Sampler1DArrayShadow
       | x == gl_SAMPLER_2D_ARRAY_SHADOW = Sampler2DArrayShadow
       | x == gl_SAMPLER_CUBE_SHADOW = SamplerCubeShadow
       | x == gl_SAMPLER_2D_RECT = Sampler2DRect
       | x == gl_SAMPLER_2D_RECT_SHADOW = Sampler2DRectShadow
       | x == gl_INT_SAMPLER_1D = IntSampler1D
       | x == gl_INT_SAMPLER_2D = IntSampler2D
       | x == gl_INT_SAMPLER_3D = IntSampler3D
       | x == gl_INT_SAMPLER_CUBE = IntSamplerCube
       | x == gl_INT_SAMPLER_1D_ARRAY = IntSampler1DArray
       | x == gl_INT_SAMPLER_2D_ARRAY = IntSampler2DArray
       | x == gl_UNSIGNED_INT_SAMPLER_1D = UnsignedIntSampler1D
       | x == gl_UNSIGNED_INT_SAMPLER_2D = UnsignedIntSampler2D
       | x == gl_UNSIGNED_INT_SAMPLER_3D = UnsignedIntSampler3D
       | x == gl_UNSIGNED_INT_SAMPLER_CUBE = UnsignedIntSamplerCube
       | x == gl_UNSIGNED_INT_SAMPLER_1D_ARRAY = UnsignedIntSampler1DArray
       | x == gl_UNSIGNED_INT_SAMPLER_2D_ARRAY = UnsignedIntSampler2DArray
       | otherwise = error ("unmarshalVariableType: illegal value " ++ show x)

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

    activeVars :: (Program -> GettableStateVar GLuint)
               -> (Program -> GettableStateVar GLsizei)
               -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())
               -> Program -> GettableStateVar [(GLint,VariableType,String)]
    activeVars numVars maxLength getter p@(Program program) =
       makeGettableStateVar $ do
          numActiveVars <- get (numVars p)
          maxLen <- get (maxLength p)
          allocaArray (fromIntegral maxLen) $ \nameBuf ->
             alloca $ \nameLengthBuf ->
                alloca $ \sizeBuf ->
                   alloca $ \typeBuf ->
                      flip mapM [0 .. numActiveVars - 1] $ \i -> do
                        getter program i maxLen nameLengthBuf sizeBuf typeBuf nameBuf
                        l <- peek nameLengthBuf
                        s <- peek sizeBuf
                        t <- peek typeBuf
                        n <- peekGLstringLen (nameBuf, l)
                        return (s, unmarshalVariableType t, n)

    activeAttribs :: Program -> GettableStateVar [(GLint,VariableType,String)]
    activeAttribs = activeVars activeAttributes activeAttributeMaxLength glGetActiveAttrib

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

    newtype UniformLocation = UniformLocation GLint
       deriving ( Eq, Ord, Show )

    uniformLocation :: Program -> String -> GettableStateVar UniformLocation
    uniformLocation (Program program) name =
       makeGettableStateVar $
          fmap UniformLocation $
             withGLString name $
                glGetUniformLocation program

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

    activeUniforms :: Program -> GettableStateVar [(GLint,VariableType,String)]
    activeUniforms = activeVars numActiveUniforms activeUniformMaxLength glGetActiveUniform

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

    class Storable a => UniformComponent a where
       uniform1 :: UniformLocation -> a -> IO ()
       uniform2 :: UniformLocation -> a -> a -> IO ()
       uniform3 :: UniformLocation -> a -> a -> a -> IO ()
       uniform4 :: UniformLocation -> a -> a -> a -> a -> IO ()

       getUniform :: Storable (b a) => Program -> UniformLocation -> Ptr (b a) -> IO ()

       uniform1v :: UniformLocation -> GLsizei -> Ptr a -> IO ()
       uniform2v :: UniformLocation -> GLsizei -> Ptr a -> IO ()
       uniform3v :: UniformLocation -> GLsizei -> Ptr a -> IO ()
       uniform4v :: UniformLocation -> GLsizei -> Ptr a -> IO ()

    instance UniformComponent GLint where
       uniform1 (UniformLocation ul) = glUniform1i ul
       uniform2 (UniformLocation ul) = glUniform2i ul
       uniform3 (UniformLocation ul) = glUniform3i ul
       uniform4 (UniformLocation ul) = glUniform4i ul

       getUniform (Program p) (UniformLocation ul) = glGetUniformiv p ul . castPtr

       uniform1v (UniformLocation ul) = glUniform1iv ul
       uniform2v (UniformLocation ul) = glUniform2iv ul
       uniform3v (UniformLocation ul) = glUniform3iv ul
       uniform4v (UniformLocation ul) = glUniform4iv ul

    instance UniformComponent GLuint where
       uniform1 (UniformLocation ul) = glUniform1ui ul
       uniform2 (UniformLocation ul) = glUniform2ui ul
       uniform3 (UniformLocation ul) = glUniform3ui ul
       uniform4 (UniformLocation ul) = glUniform4ui ul

       getUniform (Program p) (UniformLocation ul) = glGetUniformuiv p ul . castPtr

       uniform1v (UniformLocation ul) = glUniform1uiv ul
       uniform2v (UniformLocation ul) = glUniform2uiv ul
       uniform3v (UniformLocation ul) = glUniform3uiv ul
       uniform4v (UniformLocation ul) = glUniform4uiv ul

    instance UniformComponent GLfloat where
       uniform1 (UniformLocation ul) = glUniform1f ul
       uniform2 (UniformLocation ul) = glUniform2f ul
       uniform3 (UniformLocation ul) = glUniform3f ul
       uniform4 (UniformLocation ul) = glUniform4f ul

       getUniform (Program p) (UniformLocation ul) = glGetUniformfv p ul . castPtr

       uniform1v (UniformLocation ul) = glUniform1fv ul
       uniform2v (UniformLocation ul) = glUniform2fv ul
       uniform3v (UniformLocation ul) = glUniform3fv ul
       uniform4v (UniformLocation ul) = glUniform4fv ul

    instance UniformComponent GLclampf where
       uniform1 (UniformLocation ul) x = glUniform1f ul (realToFrac x)
       uniform2 (UniformLocation ul) x y = glUniform2f ul (realToFrac x) (realToFrac y)
       uniform3 (UniformLocation ul) x y z = glUniform3f ul (realToFrac x) (realToFrac y) (realToFrac z)
       uniform4 (UniformLocation ul) x y z w = glUniform4f ul (realToFrac x) (realToFrac y) (realToFrac z) (realToFrac w)

       getUniform (Program p) (UniformLocation ul) = glGetUniformfv p ul . castPtr

       uniform1v (UniformLocation ul) n = glUniform1fv ul n . castPtr
       uniform2v (UniformLocation ul) n = glUniform2fv ul n . castPtr
       uniform3v (UniformLocation ul) n = glUniform3fv ul n . castPtr
       uniform4v (UniformLocation ul) n = glUniform4fv ul n . castPtr

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

    class Uniform a where
       uniform :: UniformLocation -> StateVar a
       uniformv :: UniformLocation -> GLsizei -> Ptr a -> IO ()

    maxComponentSize :: Int
    maxComponentSize = sizeOf (undefined :: GLint) `max` sizeOf (undefined :: GLfloat)

    maxNumComponents :: Int
    maxNumComponents = 16

    maxUniformBufferSize :: Int
    maxUniformBufferSize = maxComponentSize * maxNumComponents

    makeUniformVar :: (UniformComponent a, Storable (b a))
                   => (UniformLocation -> b a -> IO ())
                   -> UniformLocation -> StateVar (b a)
    makeUniformVar setter location = makeStateVar getter (setter location)
       where getter = do
                program <- getCurrentProgram
                allocaBytes maxUniformBufferSize  $ \buf -> do
                getUniform program location buf
                peek buf

    instance UniformComponent a => Uniform (Vertex2 a) where
       uniform = makeUniformVar $ \location (Vertex2 x y) -> uniform2 location x y
       uniformv location count = uniform2v location count . (castPtr :: Ptr (Vertex2 b) -> Ptr b)

    instance UniformComponent a => Uniform (Vertex3 a) where
       uniform = makeUniformVar $ \location (Vertex3 x y z) -> uniform3 location x y z
       uniformv location count = uniform3v location count . (castPtr :: Ptr (Vertex3 b) -> Ptr b)

    instance UniformComponent a => Uniform (Vertex4 a) where
       uniform = makeUniformVar $ \location (Vertex4 x y z w) -> uniform4 location x y z w
       uniformv location count = uniform4v location count . (castPtr :: Ptr (Vertex4 b) -> Ptr b)

    instance UniformComponent a => Uniform (TexCoord1 a) where
       uniform = makeUniformVar $ \location (TexCoord1 s) -> uniform1 location s
       uniformv location count = uniform1v location count . (castPtr :: Ptr (TexCoord1 b) -> Ptr b)

    instance UniformComponent a => Uniform (TexCoord2 a) where
       uniform = makeUniformVar $ \location (TexCoord2 s t) -> uniform2 location s t
       uniformv location count = uniform2v location count . (castPtr :: Ptr (TexCoord2 b) -> Ptr b)

    instance UniformComponent a => Uniform (TexCoord3 a) where
       uniform = makeUniformVar $ \location (TexCoord3 s t r) -> uniform3 location s t  r
       uniformv location count = uniform3v location count . (castPtr :: Ptr (TexCoord3 b) -> Ptr b)

    instance UniformComponent a => Uniform (TexCoord4 a) where
       uniform = makeUniformVar $ \location (TexCoord4 s t r q) -> uniform4 location s t  r q
       uniformv location count = uniform4v location count . (castPtr :: Ptr (TexCoord4 b) -> Ptr b)

    instance UniformComponent a => Uniform (Normal3 a) where
       uniform = makeUniformVar $ \location (Normal3 x y z) -> uniform3 location x y z
       uniformv location count = uniform3v location count . (castPtr :: Ptr (Normal3 b) -> Ptr b)

    instance UniformComponent a => Uniform (FogCoord1 a) where
       uniform = makeUniformVar $ \location (FogCoord1 c) -> uniform1 location c
       uniformv location count = uniform1v location count . (castPtr :: Ptr (FogCoord1 b) -> Ptr b)

    instance UniformComponent a => Uniform (Color3 a) where
       uniform = makeUniformVar $ \location (Color3 r g b) -> uniform3 location r g b
       uniformv location count = uniform3v location count . (castPtr :: Ptr (Color3 b) -> Ptr b)

    instance UniformComponent a => Uniform (Color4 a) where
       uniform = makeUniformVar $ \location (Color4 r g b a) -> uniform4 location r g b a
       uniformv location count = uniform4v location count . (castPtr :: Ptr (Color4 b) -> Ptr b)

    instance UniformComponent a => Uniform (Index1 a) where
       uniform = makeUniformVar $ \location (Index1 i) -> uniform1 location i
       uniformv location count = uniform1v location count . (castPtr :: Ptr (Index1 b) -> Ptr b)

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

    -- | Contains the number of hardware units that can be used to access texture
    -- maps from the vertex processor. The minimum legal value is 0.

    maxVertexTextureImageUnits :: GettableStateVar GLsizei
    maxVertexTextureImageUnits = getLimit GetMaxVertexTextureImageUnits

    -- | Contains the total number of hardware units that can be used to access
    -- texture maps from the fragment processor. The minimum legal value is 2.

    maxTextureImageUnits :: GettableStateVar GLsizei
    maxTextureImageUnits = getLimit GetMaxTextureImageUnits

    -- | Contains the total number of hardware units that can be used to access
    -- texture maps from the vertex processor and the fragment processor combined.
    -- Note: If the vertex shader and the fragment processing stage access the same
    -- texture image unit, then that counts as using two texture image units. The
    -- minimum legal value is 2.

    maxCombinedTextureImageUnits :: GettableStateVar GLsizei
    maxCombinedTextureImageUnits = getLimit GetMaxCombinedTextureImageUnits

    -- | Contains the number of texture coordinate sets that are available. The
    -- minimum legal value is 2.

    maxTextureCoords :: GettableStateVar GLsizei
    maxTextureCoords = getLimit GetMaxTextureCoords

    -- | Contains the number of individual components (i.e., floating-point, integer
    -- or boolean values) that are available for vertex shader uniform variables.
    -- The minimum legal value is 512.
    maxVertexUniformComponents :: GettableStateVar GLsizei
    maxVertexUniformComponents = getLimit GetMaxVertexUniformComponents

    -- | Contains the number of individual components (i.e., floating-point, integer
    -- or boolean values) that are available for fragment shader uniform variables.
    -- The minimum legal value is 64.

    maxFragmentUniformComponents :: GettableStateVar GLsizei
    maxFragmentUniformComponents = getLimit GetMaxFragmentUniformComponents

    -- | Contains the number of active vertex attributes that are available. The
    -- minimum legal value is 16.

    maxVertexAttribs :: GettableStateVar GLsizei
    maxVertexAttribs = getLimit GetMaxVertexAttribs

    -- | Contains the number of individual floating-point values available for
    -- varying variables. The minimum legal value is 32.

    maxVaryingFloats :: GettableStateVar GLsizei
    maxVaryingFloats = getLimit GetMaxVaryingFloats

    getLimit :: GetPName -> GettableStateVar GLsizei
    getLimit = makeGettableStateVar . getSizei1 id