module LambdaCube.GL.Util (
    queryUniforms,
    queryStreams,
    mkUniformSetter,
    mkSSetter,
    compileShader,
    printProgramLog,
    glGetShaderiv1,
    glGetProgramiv1,
    Buffer(..),
    ArrayDesc(..),
    StreamSetter,
    streamToInputType,
    arrayTypeToGLType,
    comparisonFunctionToGLType,
    logicOperationToGLType,
    blendEquationToGLType,
    blendingFactorToGLType,
    checkGL,
    textureDataTypeToGLType,
    textureDataTypeToGLArityType,
    glGetIntegerv1,
    setSampler,
    checkFBO,
    createGLTextureObject
) where

import Control.Applicative
import Control.Exception
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import Data.IORef
import Data.List as L
import Data.Trie as T
import Foreign
import qualified Data.ByteString.Char8 as SB
import qualified Data.Vector as V
import Data.Vector.Unboxed.Mutable (IOVector)
import qualified Data.Vector.Unboxed.Mutable as MV

import Graphics.Rendering.OpenGL.Raw.Core32
    ( GLchar
    , GLenum
    , GLint
    , GLsizei
    , GLuint
    , gl_FALSE
    , gl_TRUE
    , glGetIntegerv

    -- ERROR CHECKING related
    -- error handling
    , glGetError
    , glCheckFramebufferStatus
    -- error checking
    , gl_COMPILE_STATUS
    , gl_DRAW_FRAMEBUFFER
    , gl_FRAMEBUFFER_COMPLETE
    , gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT
    , gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER
    , gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS
    , gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE
    , gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER
    , gl_FRAMEBUFFER_UNDEFINED
    , gl_FRAMEBUFFER_UNSUPPORTED
    , gl_INFO_LOG_LENGTH
    , gl_INVALID_ENUM
    , gl_INVALID_FRAMEBUFFER_OPERATION
    , gl_INVALID_OPERATION
    , gl_INVALID_VALUE
    , gl_NO_ERROR
    , gl_OUT_OF_MEMORY

    -- TEXTURE related
    -- texture data
    , glActiveTexture
    , glBindTexture
    , glGenTextures
    , glTexImage2D
    , glTexImage3D
    , glTexParameteri
    , gl_TEXTURE0

    -- texture parameters
    , gl_CLAMP_TO_BORDER
    , gl_CLAMP_TO_EDGE
    , gl_MIRRORED_REPEAT
    , gl_REPEAT
    , gl_LINEAR
    , gl_NEAREST

    , gl_TEXTURE_CUBE_MAP
    , gl_TEXTURE_CUBE_MAP_POSITIVE_X
    , gl_TEXTURE_CUBE_MAP_NEGATIVE_X
    , gl_TEXTURE_CUBE_MAP_POSITIVE_Y
    , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y
    , gl_TEXTURE_CUBE_MAP_POSITIVE_Z
    , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z
    , gl_TEXTURE_2D
    , gl_TEXTURE_2D_ARRAY
    , gl_TEXTURE_MAG_FILTER
    , gl_TEXTURE_MIN_FILTER
    , gl_TEXTURE_WRAP_S
    , gl_TEXTURE_WRAP_T
    , gl_TEXTURE_BASE_LEVEL
    , gl_TEXTURE_MAX_LEVEL

    -- texture format
    , gl_R32F
    , gl_R32I
    , gl_R32UI
    , gl_RED
    , gl_RG
    , gl_RG32F
    , gl_RG32I
    , gl_RG32UI
    , gl_RGB
    , gl_RGB32F
    , gl_RGB32I
    , gl_RGB32UI
    , gl_RGBA
    , gl_RGBA32F
    , gl_RGBA32I
    , gl_RGBA32UI

    -- SHADER related
    -- shader program
    , glCompileShader
    , glGetActiveAttrib
    , glGetActiveUniform
    , glGetAttribLocation
    , glGetProgramInfoLog
    , glGetProgramiv
    , glGetShaderInfoLog
    , glGetShaderiv
    , glGetUniformLocation
    , glShaderSource

    -- stream data (stream parameter)
    , glBindBuffer
    , glDisableVertexAttribArray
    , glEnableVertexAttribArray
    , glVertexAttrib1fv
    , glVertexAttrib2fv
    , glVertexAttrib3fv
    , glVertexAttrib4fv
    , glVertexAttribI1iv
    , glVertexAttribI1uiv
    , glVertexAttribI2iv
    , glVertexAttribI2uiv
    , glVertexAttribI3iv
    , glVertexAttribI3uiv
    , glVertexAttribI4iv
    , glVertexAttribI4uiv
    , glVertexAttribIPointer
    , glVertexAttribPointer
    , gl_ACTIVE_ATTRIBUTES
    , gl_ACTIVE_ATTRIBUTE_MAX_LENGTH
    , gl_ARRAY_BUFFER

    -- stream value representation
    , gl_BYTE
    , gl_HALF_FLOAT
    , gl_SHORT
    , gl_UNSIGNED_BYTE
    , gl_UNSIGNED_SHORT

    -- uniform data (constant parameter)
    , glUniform1fv
    , glUniform1i
    , glUniform1iv
    , glUniform1uiv
    , glUniform2fv
    , glUniform2iv
    , glUniform2uiv
    , glUniform3fv
    , glUniform3iv
    , glUniform3uiv
    , glUniform4fv
    , glUniform4iv
    , glUniform4uiv
    , glUniformMatrix2fv
    , glUniformMatrix2x3fv
    , glUniformMatrix2x4fv
    , glUniformMatrix3fv
    , glUniformMatrix3x2fv
    , glUniformMatrix3x4fv
    , glUniformMatrix4fv
    , glUniformMatrix4x2fv
    , glUniformMatrix4x3fv
    , gl_ACTIVE_UNIFORMS
    , gl_ACTIVE_UNIFORM_MAX_LENGTH

    -- uniform types (constant value types)
    , gl_BOOL
    , gl_BOOL_VEC2
    , gl_BOOL_VEC3
    , gl_BOOL_VEC4
    , gl_FLOAT
    , gl_FLOAT_MAT2
    , gl_FLOAT_MAT2x3
    , gl_FLOAT_MAT2x4
    , gl_FLOAT_MAT3
    , gl_FLOAT_MAT3x2
    , gl_FLOAT_MAT3x4
    , gl_FLOAT_MAT4
    , gl_FLOAT_MAT4x2
    , gl_FLOAT_MAT4x3
    , gl_FLOAT_VEC2
    , gl_FLOAT_VEC3
    , gl_FLOAT_VEC4
    , gl_INT
    , gl_INT_SAMPLER_1D
    , gl_INT_SAMPLER_1D_ARRAY
    , gl_INT_SAMPLER_2D
    , gl_INT_SAMPLER_2D_ARRAY
    , gl_INT_SAMPLER_2D_MULTISAMPLE
    , gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY
    , gl_INT_SAMPLER_2D_RECT
    , gl_INT_SAMPLER_3D
    , gl_INT_SAMPLER_BUFFER
    , gl_INT_SAMPLER_CUBE
    , gl_INT_VEC2
    , gl_INT_VEC3
    , gl_INT_VEC4
    , gl_SAMPLER_1D
    , gl_SAMPLER_1D_ARRAY
    , gl_SAMPLER_1D_ARRAY_SHADOW
    , gl_SAMPLER_1D_SHADOW
    , gl_SAMPLER_2D
    , gl_SAMPLER_2D_ARRAY
    , gl_SAMPLER_2D_ARRAY_SHADOW
    , gl_SAMPLER_2D_MULTISAMPLE
    , gl_SAMPLER_2D_MULTISAMPLE_ARRAY
    , gl_SAMPLER_2D_RECT
    , gl_SAMPLER_2D_RECT_SHADOW
    , gl_SAMPLER_2D_SHADOW
    , gl_SAMPLER_3D
    , gl_SAMPLER_BUFFER
    , gl_SAMPLER_CUBE
    , gl_SAMPLER_CUBE_SHADOW
    , gl_UNSIGNED_INT
    , gl_UNSIGNED_INT_SAMPLER_1D
    , gl_UNSIGNED_INT_SAMPLER_1D_ARRAY
    , gl_UNSIGNED_INT_SAMPLER_2D
    , gl_UNSIGNED_INT_SAMPLER_2D_ARRAY
    , gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE
    , gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY
    , gl_UNSIGNED_INT_SAMPLER_2D_RECT
    , gl_UNSIGNED_INT_SAMPLER_3D
    , gl_UNSIGNED_INT_SAMPLER_BUFFER
    , gl_UNSIGNED_INT_SAMPLER_CUBE
    , gl_UNSIGNED_INT_VEC2
    , gl_UNSIGNED_INT_VEC3
    , gl_UNSIGNED_INT_VEC4

    -- CONTEXT PARAMETER realted
    -- depth and stencil operation
    , gl_ALWAYS
    , gl_EQUAL
    , gl_GEQUAL
    , gl_GREATER
    , gl_LEQUAL
    , gl_LESS
    , gl_NEVER
    , gl_NOTEQUAL

    -- blending function
    , gl_FUNC_ADD
    , gl_FUNC_REVERSE_SUBTRACT
    , gl_FUNC_SUBTRACT
    , gl_MAX
    , gl_MIN

    -- blending
    , gl_CONSTANT_ALPHA
    , gl_CONSTANT_COLOR
    , gl_DST_ALPHA
    , gl_DST_COLOR
    , gl_ONE
    , gl_ONE_MINUS_CONSTANT_ALPHA
    , gl_ONE_MINUS_CONSTANT_COLOR
    , gl_ONE_MINUS_DST_ALPHA
    , gl_ONE_MINUS_DST_COLOR
    , gl_ONE_MINUS_SRC_ALPHA
    , gl_ONE_MINUS_SRC_COLOR
    , gl_SRC_ALPHA
    , gl_SRC_ALPHA_SATURATE
    , gl_SRC_COLOR
    , gl_ZERO

    -- logic operation
    , gl_AND
    , gl_AND_INVERTED
    , gl_AND_REVERSE
    , gl_CLEAR
    , gl_COPY
    , gl_COPY_INVERTED
    , gl_EQUIV
    , gl_INVERT
    , gl_NAND
    , gl_NOOP
    , gl_NOR
    , gl_OR
    , gl_OR_INVERTED
    , gl_OR_REVERSE
    , gl_SET
    , gl_XOR
    )

import LambdaCube.Core.Type
import LambdaCube.Core.DeBruijn
import LambdaCube.GL.Type

setSampler :: GLint -> Int32 -> IO ()
setSampler i v = glUniform1i i $ fromIntegral v

z2 = V2 0 0 :: V2F
z3 = V3 0 0 0 :: V3F
z4 = V4 0 0 0 0 :: V4F

-- uniform functions
queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType)
queryUniforms po = do
    ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation gl_ACTIVE_UNIFORMS gl_ACTIVE_UNIFORM_MAX_LENGTH
    let uNames = [n | (n,_,_,_) <- ul]
        uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul]
        uLocation = [i | (_,i,_,_) <- ul]
    return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes)

mkUniformSetter :: RenderState -> InputType -> IO (GLint -> IO (), InputSetter, InputGetter)
mkUniformSetter _ Bool    = do {t <- newIORef False;                        return $! (\i -> readIORef t >>= setUBool i,  SBool $!  Setter $ writeIORef t, SBool $  Getter $ readIORef t)}
mkUniformSetter _ V2B     = do {t <- newIORef (V2 False False);             return $! (\i -> readIORef t >>= setUV2B i,   SV2B $!   Setter $ writeIORef t, SV2B $   Getter $ readIORef t)}
mkUniformSetter _ V3B     = do {t <- newIORef (V3 False False False);       return $! (\i -> readIORef t >>= setUV3B i,   SV3B $!   Setter $ writeIORef t, SV3B $   Getter $ readIORef t)}
mkUniformSetter _ V4B     = do {t <- newIORef (V4 False False False False); return $! (\i -> readIORef t >>= setUV4B i,   SV4B $!   Setter $ writeIORef t, SV4B $   Getter $ readIORef t)}
mkUniformSetter _ Word    = do {t <- newIORef 0;                            return $! (\i -> readIORef t >>= setUWord i,  SWord $!  Setter $ writeIORef t, SWord $  Getter $ readIORef t)}
mkUniformSetter _ V2U     = do {t <- newIORef (V2 0 0);                     return $! (\i -> readIORef t >>= setUV2U i,   SV2U $!   Setter $ writeIORef t, SV2U $   Getter $ readIORef t)}
mkUniformSetter _ V3U     = do {t <- newIORef (V3 0 0 0);                   return $! (\i -> readIORef t >>= setUV3U i,   SV3U $!   Setter $ writeIORef t, SV3U $   Getter $ readIORef t)}
mkUniformSetter _ V4U     = do {t <- newIORef (V4 0 0 0 0);                 return $! (\i -> readIORef t >>= setUV4U i,   SV4U $!   Setter $ writeIORef t, SV4U $   Getter $ readIORef t)}
mkUniformSetter _ Int     = do {t <- newIORef 0;                            return $! (\i -> readIORef t >>= setUInt i,   SInt $!   Setter $ writeIORef t, SInt $   Getter $ readIORef t)}
mkUniformSetter _ V2I     = do {t <- newIORef (V2 0 0);                     return $! (\i -> readIORef t >>= setUV2I i,   SV2I $!   Setter $ writeIORef t, SV2I $   Getter $ readIORef t)}
mkUniformSetter _ V3I     = do {t <- newIORef (V3 0 0 0);                   return $! (\i -> readIORef t >>= setUV3I i,   SV3I $!   Setter $ writeIORef t, SV3I $   Getter $ readIORef t)}
mkUniformSetter _ V4I     = do {t <- newIORef (V4 0 0 0 0);                 return $! (\i -> readIORef t >>= setUV4I i,   SV4I $!   Setter $ writeIORef t, SV4I $   Getter $ readIORef t)}
mkUniformSetter _ Float   = do {t <- newIORef 0;                            return $! (\i -> readIORef t >>= setUFloat i, SFloat $! Setter $ writeIORef t, SFloat $ Getter $ readIORef t)}
mkUniformSetter _ V2F     = do {t <- newIORef (V2 0 0);                     return $! (\i -> readIORef t >>= setUV2F i,   SV2F $!   Setter $ writeIORef t, SV2F $   Getter $ readIORef t)}
mkUniformSetter _ V3F     = do {t <- newIORef (V3 0 0 0);                   return $! (\i -> readIORef t >>= setUV3F i,   SV3F $!   Setter $ writeIORef t, SV3F $   Getter $ readIORef t)}
mkUniformSetter _ V4F     = do {t <- newIORef (V4 0 0 0 0);                 return $! (\i -> readIORef t >>= setUV4F i,   SV4F $!   Setter $ writeIORef t, SV4F $   Getter $ readIORef t)}
mkUniformSetter _ M22F    = do {t <- newIORef (V2 z2 z2);                   return $! (\i -> readIORef t >>= setUM22F i,  SM22F $!  Setter $ writeIORef t, SM22F $  Getter $ readIORef t)}
mkUniformSetter _ M23F    = do {t <- newIORef (V3 z2 z2 z2);                return $! (\i -> readIORef t >>= setUM23F i,  SM23F $!  Setter $ writeIORef t, SM23F $  Getter $ readIORef t)}
mkUniformSetter _ M24F    = do {t <- newIORef (V4 z2 z2 z2 z2);             return $! (\i -> readIORef t >>= setUM24F i,  SM24F $!  Setter $ writeIORef t, SM24F $  Getter $ readIORef t)}
mkUniformSetter _ M32F    = do {t <- newIORef (V2 z3 z3);                   return $! (\i -> readIORef t >>= setUM32F i,  SM32F $!  Setter $ writeIORef t, SM32F $  Getter $ readIORef t)}
mkUniformSetter _ M33F    = do {t <- newIORef (V3 z3 z3 z3);                return $! (\i -> readIORef t >>= setUM33F i,  SM33F $!  Setter $ writeIORef t, SM33F $  Getter $ readIORef t)}
mkUniformSetter _ M34F    = do {t <- newIORef (V4 z3 z3 z3 z3);             return $! (\i -> readIORef t >>= setUM34F i,  SM34F $!  Setter $ writeIORef t, SM34F $  Getter $ readIORef t)}
mkUniformSetter _ M42F    = do {t <- newIORef (V2 z4 z4);                   return $! (\i -> readIORef t >>= setUM42F i,  SM42F $!  Setter $ writeIORef t, SM42F $  Getter $ readIORef t)}
mkUniformSetter _ M43F    = do {t <- newIORef (V3 z4 z4 z4);                return $! (\i -> readIORef t >>= setUM43F i,  SM43F $!  Setter $ writeIORef t, SM43F $  Getter $ readIORef t)}
mkUniformSetter _ M44F    = do {t <- newIORef (V4 z4 z4 z4 z4);             return $! (\i -> readIORef t >>= setUM44F i,  SM44F $!  Setter $ writeIORef t, SM44F $  Getter $ readIORef t)}
mkUniformSetter rendState FTexture2D = do
    let texUnitState = textureUnitState rendState
    t <- newIORef (TextureData 0)
    return $! (\i -> readIORef t >>= setTextureData texUnitState i,  SFTexture2D $!  Setter $ writeIORef t, SFTexture2D $ Getter $ readIORef t)

-- FIXME: implement properly
setTextureData :: IOVector Int -> GLint -> TextureData -> IO ()
setTextureData texUnitState texUnitIdx (TextureData texObj) = do
    let texUnitIdx' = fromIntegral texUnitIdx
        texObj'     = fromIntegral texObj
    curTexObj <- MV.read texUnitState texUnitIdx'
    when (curTexObj /= texObj') $ do
        MV.write texUnitState texUnitIdx' texObj'
        glActiveTexture $ gl_TEXTURE0 + fromIntegral texUnitIdx
        glBindTexture gl_TEXTURE_2D texObj
        --putStrLn (" -- uniform setup - Texture bind (TexUnit " ++ show (texUnitIdx,texObj) ++ " TexObj)")

b2w :: Bool -> GLuint
b2w True = 1
b2w False = 0

setUBool :: GLint -> Bool -> IO ()
setUV2B  :: GLint -> V2B -> IO ()
setUV3B  :: GLint -> V3B -> IO ()
setUV4B  :: GLint -> V4B -> IO ()
setUBool i v           = with (b2w v) $! \p -> glUniform1uiv i 1 p
setUV2B i (V2 x y)     = with (V2 (b2w x) (b2w y)) $! \p -> glUniform2uiv i 1 $! castPtr p
setUV3B i (V3 x y z)   = with (V3 (b2w x) (b2w y) (b2w z)) $! \p -> glUniform3uiv i 1 $! castPtr p
setUV4B i (V4 x y z w) = with (V4 (b2w x) (b2w y) (b2w z) (b2w w)) $! \p -> glUniform4uiv i 1 $! castPtr p

setUWord :: GLint -> Word32 -> IO ()
setUV2U  :: GLint -> V2U -> IO ()
setUV3U  :: GLint -> V3U -> IO ()
setUV4U  :: GLint -> V4U -> IO ()
setUWord i v = with v $! \p -> glUniform1uiv i 1 $! castPtr p
setUV2U i v  = with v $! \p -> glUniform2uiv i 1 $! castPtr p
setUV3U i v  = with v $! \p -> glUniform3uiv i 1 $! castPtr p
setUV4U i v  = with v $! \p -> glUniform4uiv i 1 $! castPtr p

setUInt :: GLint -> Int32 -> IO ()
setUV2I :: GLint -> V2I -> IO ()
setUV3I :: GLint -> V3I -> IO ()
setUV4I :: GLint -> V4I -> IO ()
setUInt i v = with v $! \p -> glUniform1iv i 1 $! castPtr p
setUV2I i v = with v $! \p -> glUniform2iv i 1 $! castPtr p
setUV3I i v = with v $! \p -> glUniform3iv i 1 $! castPtr p
setUV4I i v = with v $! \p -> glUniform4iv i 1 $! castPtr p

setUFloat :: GLint -> Float -> IO ()
setUV2F   :: GLint -> V2F -> IO ()
setUV3F   :: GLint -> V3F -> IO ()
setUV4F   :: GLint -> V4F -> IO ()
setUFloat i v = with v $! \p -> glUniform1fv i 1 $! castPtr p
setUV2F i v   = with v $! \p -> glUniform2fv i 1 $! castPtr p
setUV3F i v   = with v $! \p -> glUniform3fv i 1 $! castPtr p
setUV4F i v   = with v $! \p -> glUniform4fv i 1 $! castPtr p

setUM22F :: GLint -> M22F -> IO ()
setUM23F :: GLint -> M23F -> IO ()
setUM24F :: GLint -> M24F -> IO ()
setUM22F i v = with v $! \p -> glUniformMatrix2fv i 1 (fromIntegral gl_FALSE) $! castPtr p
setUM23F i v = with v $! \p -> glUniformMatrix2x3fv i 1 (fromIntegral gl_FALSE) $! castPtr p
setUM24F i v = with v $! \p -> glUniformMatrix2x4fv i 1 (fromIntegral gl_FALSE) $! castPtr p

setUM32F :: GLint -> M32F -> IO ()
setUM33F :: GLint -> M33F -> IO ()
setUM34F :: GLint -> M34F -> IO ()
setUM32F i v = with v $! \p -> glUniformMatrix3x2fv i 1 (fromIntegral gl_FALSE) $! castPtr p
setUM33F i v = with v $! \p -> glUniformMatrix3fv i 1 (fromIntegral gl_FALSE) $! castPtr p
setUM34F i v = with v $! \p -> glUniformMatrix3x4fv i 1 (fromIntegral gl_FALSE) $! castPtr p

setUM42F :: GLint -> M42F -> IO ()
setUM43F :: GLint -> M43F -> IO ()
setUM44F :: GLint -> M44F -> IO ()
setUM42F i v = with v $! \p -> glUniformMatrix4x2fv i 1 (fromIntegral gl_FALSE) $! castPtr p
setUM43F i v = with v $! \p -> glUniformMatrix4x3fv i 1 (fromIntegral gl_FALSE) $! castPtr p
setUM44F i v = with v $! \p -> glUniformMatrix4fv i 1 (fromIntegral gl_FALSE) $! castPtr p

-- attribute functions
queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType)
queryStreams po = do
    al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation gl_ACTIVE_ATTRIBUTES gl_ACTIVE_ATTRIBUTE_MAX_LENGTH
    let aNames = [n | (n,_,_,_) <- al]
        aTypes = [fromGLType (e,s) | (_,_,e,s) <- al]
        aLocation = [fromIntegral i | (_,i,_,_) <- al]
    return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes)

-- should handle constant value and buffer value as well
mkSSetter :: InputType -> GLuint -> StreamSetter
mkSSetter Word  i (ConstWord v)             = setAWord i v
mkSSetter V2U   i (ConstV2U v)              = setAV2U i v
mkSSetter V3U   i (ConstV3U v)              = setAV3U i v
mkSSetter V4U   i (ConstV4U v)              = setAV4U i v
mkSSetter Word  i (Stream TWord b a s l)    = setBufInteger 1 i b a s
mkSSetter V2U   i (Stream TV2U b a s l)     = setBufInteger 2 i b a s
mkSSetter V3U   i (Stream TV3U b a s l)     = setBufInteger 3 i b a s
mkSSetter V4U   i (Stream TV4U b a s l)     = setBufInteger 4 i b a s
                
mkSSetter Int   i (ConstInt v)              = setAInt i v
mkSSetter V2I   i (ConstV2I v)              = setAV2I i v
mkSSetter V3I   i (ConstV3I v)              = setAV3I i v
mkSSetter V4I   i (ConstV4I v)              = setAV4I i v
mkSSetter Int   i (Stream TInt b a s l)     = setBufInteger 1 i b a s
mkSSetter V2I   i (Stream TV2I b a s l)     = setBufInteger 2 i b a s
mkSSetter V3I   i (Stream TV3I b a s l)     = setBufInteger 3 i b a s
mkSSetter V4I   i (Stream TV4I b a s l)     = setBufInteger 4 i b a s
                
mkSSetter Float i (ConstFloat v)            = setAFloat i v
mkSSetter V2F   i (ConstV2F v)              = setAV2F i v
mkSSetter V3F   i (ConstV3F v)              = setAV3F i v
mkSSetter V4F   i (ConstV4F v)              = setAV4F i v
mkSSetter Float i (Stream TFloat b a s l)   = setBufFloat 1 i b a s
mkSSetter V2F   i (Stream TV2F b a s l)     = setBufFloat 2 i b a s
mkSSetter V3F   i (Stream TV3F b a s l)     = setBufFloat 3 i b a s
mkSSetter V4F   i (Stream TV4F b a s l)     = setBufFloat 4 i b a s
                
mkSSetter M22F  i (ConstM22F v)             = setAM22F i v
mkSSetter M23F  i (ConstM23F v)             = setAM23F i v
mkSSetter M24F  i (ConstM24F v)             = setAM24F i v
mkSSetter M22F  i (Stream TM22F b a s l)    = setBufFloat 4 i b a s
mkSSetter M23F  i (Stream TM23F b a s l)    = setBufFloat 6 i b a s
mkSSetter M24F  i (Stream TM24F b a s l)    = setBufFloat 8 i b a s
                
mkSSetter M32F  i (ConstM32F v)             = setAM32F i v
mkSSetter M33F  i (ConstM33F v)             = setAM33F i v
mkSSetter M34F  i (ConstM34F v)             = setAM34F i v
mkSSetter M32F  i (Stream TM32F b a s l)    = setBufFloat 6 i b a s
mkSSetter M33F  i (Stream TM33F b a s l)    = setBufFloat 9 i b a s
mkSSetter M34F  i (Stream TM34F b a s l)    = setBufFloat 12 i b a s
                
mkSSetter M42F  i (ConstM42F v)             = setAM42F i v
mkSSetter M43F  i (ConstM43F v)             = setAM43F i v
mkSSetter M44F  i (ConstM44F v)             = setAM44F i v
mkSSetter M42F  i (Stream TM42F b a s l)    = setBufFloat 8 i b a s
mkSSetter M43F  i (Stream TM43F b a s l)    = setBufFloat 12 i b a s
mkSSetter M44F  i (Stream TM44F b a s l)    = setBufFloat 16 i b a s
mkSSetter _ _ _                               = fail "mkSSetter type mismatch!"

arrayTypeToGLType :: ArrayType -> GLenum
arrayTypeToGLType ArrWord8  = gl_UNSIGNED_BYTE
arrayTypeToGLType ArrWord16 = gl_UNSIGNED_SHORT
arrayTypeToGLType ArrWord32 = gl_UNSIGNED_INT
arrayTypeToGLType ArrInt8   = gl_BYTE
arrayTypeToGLType ArrInt16  = gl_SHORT
arrayTypeToGLType ArrInt32  = gl_INT
arrayTypeToGLType ArrFloat  = gl_FLOAT
arrayTypeToGLType ArrHalf   = gl_HALF_FLOAT

setBufFloat :: GLint -> GLuint -> Buffer -> Int -> Int -> IO ()
setBufFloat compCnt i (Buffer arrs bo) arrIdx start = do
    let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx
        glType = arrayTypeToGLType arrType
        ptr    = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
    glBindBuffer gl_ARRAY_BUFFER bo
    glEnableVertexAttribArray i
    glVertexAttribPointer i compCnt glType (fromIntegral gl_FALSE) 0 ptr

setBufInteger :: GLint -> GLuint -> Buffer -> Int -> Int -> IO ()
--setBufInteger = setBufFloat -- FIXME: GL 2.1 does not have glVertexAttribIPointer
setBufInteger compCnt i (Buffer arrs bo) arrIdx start = do
    let ArrayDesc arrType arrLen arrOffs arrSize = arrs V.! arrIdx
        glType = arrayTypeToGLType arrType
        ptr    = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
    glBindBuffer gl_ARRAY_BUFFER bo
    glEnableVertexAttribArray i
    -- GL 3.X version
    glVertexAttribIPointer i compCnt glType 0 ptr

setAWord :: GLuint -> Word32 -> IO ()
setAV2U  :: GLuint -> V2U -> IO ()
setAV3U  :: GLuint -> V3U -> IO ()
setAV4U  :: GLuint -> V4U -> IO ()
setAWord i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI1uiv i $! castPtr p)
setAV2U i v  = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI2uiv i $! castPtr p)
setAV3U i v  = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI3uiv i $! castPtr p)
setAV4U i v  = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI4uiv i $! castPtr p)

setAInt :: GLuint -> Int32 -> IO ()
setAV2I :: GLuint -> V2I -> IO ()
setAV3I :: GLuint -> V3I -> IO ()
setAV4I :: GLuint -> V4I -> IO ()
setAInt i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI1iv i $! castPtr p)
setAV2I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI2iv i $! castPtr p)
setAV3I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI3iv i $! castPtr p)
setAV4I i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttribI4iv i $! castPtr p)

setAFloat :: GLuint -> Float -> IO ()
setAV2F   :: GLuint -> V2F -> IO ()
setAV3F   :: GLuint -> V3F -> IO ()
setAV4F   :: GLuint -> V4F -> IO ()
setAFloat i v = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib1fv i $! castPtr p)
setAV2F i v   = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib2fv i $! castPtr p)
setAV3F i v   = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib3fv i $! castPtr p)
setAV4F i v   = glDisableVertexAttribArray i >> (with v $! \p -> glVertexAttrib4fv i $! castPtr p)

setAM22F :: GLuint -> M22F -> IO ()
setAM23F :: GLuint -> M23F -> IO ()
setAM24F :: GLuint -> M24F -> IO ()
setAM22F i (V2 x y)     = setAV2F i x >> setAV2F (i+1) y
setAM23F i (V3 x y z)   = setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z
setAM24F i (V4 x y z w) = setAV2F i x >> setAV2F (i+1) y >> setAV2F (i+2) z >> setAV2F (i+3) w

setAM32F :: GLuint -> M32F -> IO ()
setAM33F :: GLuint -> M33F -> IO ()
setAM34F :: GLuint -> M34F -> IO ()
setAM32F i (V2 x y)     = setAV3F i x >> setAV3F (i+1) y
setAM33F i (V3 x y z)   = setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z
setAM34F i (V4 x y z w) = setAV3F i x >> setAV3F (i+1) y >> setAV3F (i+2) z >> setAV3F (i+3) w

setAM42F :: GLuint -> M42F -> IO ()
setAM43F :: GLuint -> M43F -> IO ()
setAM44F :: GLuint -> M44F -> IO ()
setAM42F i (V2 x y)     = setAV4F i x >> setAV4F (i+1) y
setAM43F i (V3 x y z)   = setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z
setAM44F i (V4 x y z w) = setAV4F i x >> setAV4F (i+1) y >> setAV4F (i+2) z >> setAV4F (i+3) w

-- result list: [(name string,location,gl type,component count)]
getNameTypeSize :: GLuint -> (GLuint -> GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLint -> Ptr GLenum -> Ptr GLchar -> IO ())
                   -> (GLuint -> Ptr GLchar -> IO GLint) -> GLenum -> GLenum -> IO [(ByteString,GLint,GLenum,GLint)]
getNameTypeSize o f g enum enumLen = do
    nameLen <- glGetProgramiv1 enumLen o
    allocaArray (fromIntegral nameLen) $! \namep -> alloca $! \sizep -> alloca $! \typep -> do
        n <- glGetProgramiv1 enum o
        forM [0..n-1] $! \i -> f o (fromIntegral i) (fromIntegral nameLen) nullPtr sizep typep namep >>
            (,,,) <$> SB.packCString (castPtr namep) <*> g o namep <*> peek typep <*> peek sizep
{-
filterSamplers :: [(ByteString,GLint,GLenum,GLint)] -> ([(ByteString,GLint,GLenum,GLint)],[(ByteString,GLint,GLenum,GLint)])
filterSamplers l = partition (\(_,_,e,_) -> elem e samplerTypes) l
  where
    samplerTypes = [gl_SAMPLER_2D]
-}
fromGLType :: (GLenum,GLint) -> InputType
fromGLType (t,1)
    | t == gl_BOOL              = Bool
    | t == gl_BOOL_VEC2         = V2B
    | t == gl_BOOL_VEC3         = V3B
    | t == gl_BOOL_VEC4         = V4B
    | t == gl_UNSIGNED_INT      = Word
    | t == gl_UNSIGNED_INT_VEC2 = V2U
    | t == gl_UNSIGNED_INT_VEC3 = V3U
    | t == gl_UNSIGNED_INT_VEC4 = V4U
    | t == gl_INT               = Int
    | t == gl_INT_VEC2          = V2I
    | t == gl_INT_VEC3          = V3I
    | t == gl_INT_VEC4          = V4I
    | t == gl_FLOAT             = Float
    | t == gl_FLOAT_VEC2        = V2F
    | t == gl_FLOAT_VEC3        = V3F
    | t == gl_FLOAT_VEC4        = V4F
    | t == gl_FLOAT_MAT2        = M22F
    | t == gl_FLOAT_MAT2x3      = M23F
    | t == gl_FLOAT_MAT2x4      = M24F
    | t == gl_FLOAT_MAT3x2      = M32F
    | t == gl_FLOAT_MAT3        = M33F
    | t == gl_FLOAT_MAT3x4      = M34F
    | t == gl_FLOAT_MAT4x2      = M42F
    | t == gl_FLOAT_MAT4x3      = M43F
    | t == gl_FLOAT_MAT4        = M44F
    | t == gl_SAMPLER_1D_ARRAY_SHADOW                   = STexture1DArray
    | t == gl_SAMPLER_1D_SHADOW                         = STexture1D
    | t == gl_SAMPLER_2D_ARRAY_SHADOW                   = STexture2DArray
    | t == gl_SAMPLER_2D_RECT_SHADOW                    = STexture2DRect
    | t == gl_SAMPLER_2D_SHADOW                         = STexture2D
    | t == gl_SAMPLER_CUBE_SHADOW                       = STextureCube
    | t == gl_INT_SAMPLER_1D                            = ITexture1D
    | t == gl_INT_SAMPLER_1D_ARRAY                      = ITexture1DArray
    | t == gl_INT_SAMPLER_2D                            = ITexture2D
    | t == gl_INT_SAMPLER_2D_ARRAY                      = ITexture2DArray
    | t == gl_INT_SAMPLER_2D_MULTISAMPLE                = ITexture2DMS
    | t == gl_INT_SAMPLER_2D_MULTISAMPLE_ARRAY          = ITexture2DMSArray
    | t == gl_INT_SAMPLER_2D_RECT                       = ITexture2DRect
    | t == gl_INT_SAMPLER_3D                            = ITexture3D
    | t == gl_INT_SAMPLER_BUFFER                        = ITextureBuffer
    | t == gl_INT_SAMPLER_CUBE                          = ITextureCube
    | t == gl_SAMPLER_1D                                = FTexture1D
    | t == gl_SAMPLER_1D_ARRAY                          = FTexture1DArray
    | t == gl_SAMPLER_2D                                = FTexture2D
    | t == gl_SAMPLER_2D_ARRAY                          = FTexture2DArray
    | t == gl_SAMPLER_2D_MULTISAMPLE                    = FTexture2DMS
    | t == gl_SAMPLER_2D_MULTISAMPLE_ARRAY              = FTexture2DMSArray
    | t == gl_SAMPLER_2D_RECT                           = FTexture2DRect
    | t == gl_SAMPLER_3D                                = FTexture3D
    | t == gl_SAMPLER_BUFFER                            = FTextureBuffer
    | t == gl_SAMPLER_CUBE                              = FTextureCube
    | t == gl_UNSIGNED_INT_SAMPLER_1D                   = UTexture1D
    | t == gl_UNSIGNED_INT_SAMPLER_1D_ARRAY             = UTexture1DArray
    | t == gl_UNSIGNED_INT_SAMPLER_2D                   = UTexture2D
    | t == gl_UNSIGNED_INT_SAMPLER_2D_ARRAY             = UTexture2DArray
    | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE       = UTexture2DMS
    | t == gl_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY = UTexture2DMSArray
    | t == gl_UNSIGNED_INT_SAMPLER_2D_RECT              = UTexture2DRect
    | t == gl_UNSIGNED_INT_SAMPLER_3D                   = UTexture3D
    | t == gl_UNSIGNED_INT_SAMPLER_BUFFER               = UTextureBuffer
    | t == gl_UNSIGNED_INT_SAMPLER_CUBE                 = UTextureCube
    | otherwise = error "Failed fromGLType"
fromGLUniformType _ = error "Failed fromGLType"

printShaderLog :: GLuint -> IO ()
printShaderLog o = do
    i <- glGetShaderiv1 gl_INFO_LOG_LENGTH o
    when (i > 0) $
      alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
        glGetShaderInfoLog o (fromIntegral i) sizePtr ps
        size <- peek sizePtr
        log <- SB.packCStringLen (castPtr ps, fromIntegral size)
        SB.putStrLn log

glGetShaderiv1 :: GLenum -> GLuint -> IO GLint
glGetShaderiv1 pname o = alloca $! \pi -> glGetShaderiv o pname pi >> peek pi

glGetProgramiv1 :: GLenum -> GLuint -> IO GLint
glGetProgramiv1 pname o = alloca $! \pi -> glGetProgramiv o pname pi >> peek pi

printProgramLog :: GLuint -> IO ()
printProgramLog o = do
    i <- glGetProgramiv1 gl_INFO_LOG_LENGTH o
    when (i > 0) $
      alloca $ \sizePtr -> allocaArray (fromIntegral i) $! \ps -> do
        glGetProgramInfoLog o (fromIntegral i) sizePtr ps
        size <- peek sizePtr
        log <- SB.packCStringLen (castPtr ps, fromIntegral size)
        SB.putStrLn log

compileShader :: GLuint -> [ByteString] -> IO ()
compileShader o srcl = withMany SB.useAsCString srcl $! \l -> withArray l $! \p -> do
    glShaderSource o (fromIntegral $! length srcl) (castPtr p) nullPtr
    glCompileShader o
    printShaderLog o
    status <- glGetShaderiv1 gl_COMPILE_STATUS o
    when (status /= fromIntegral gl_TRUE) $ fail "compileShader failed!"

checkGL :: IO ByteString
checkGL = do
    let f e | e == gl_INVALID_ENUM                  = "INVALID_ENUM"
            | e == gl_INVALID_VALUE                 = "INVALID_VALUE"
            | e == gl_INVALID_OPERATION             = "INVALID_OPERATION"
            | e == gl_INVALID_FRAMEBUFFER_OPERATION = "INVALID_FRAMEBUFFER_OPERATION"
            | e == gl_OUT_OF_MEMORY                 = "OUT_OF_MEMORY"
            | e == gl_NO_ERROR                      = "OK"
            | otherwise                             = "Unknown error"
    e <- glGetError
    return $ f e

streamToInputType :: Stream Buffer -> InputType
streamToInputType (ConstWord  _) = Word
streamToInputType (ConstV2U   _) = V2U
streamToInputType (ConstV3U   _) = V3U
streamToInputType (ConstV4U   _) = V4U
streamToInputType (ConstInt   _) = Int
streamToInputType (ConstV2I   _) = V2I
streamToInputType (ConstV3I   _) = V3I
streamToInputType (ConstV4I   _) = V4I
streamToInputType (ConstFloat _) = Float
streamToInputType (ConstV2F   _) = V2F
streamToInputType (ConstV3F   _) = V3F
streamToInputType (ConstV4F   _) = V4F
streamToInputType (ConstM22F  _) = M22F
streamToInputType (ConstM23F  _) = M23F
streamToInputType (ConstM24F  _) = M24F
streamToInputType (ConstM32F  _) = M32F
streamToInputType (ConstM33F  _) = M33F
streamToInputType (ConstM34F  _) = M34F
streamToInputType (ConstM42F  _) = M42F
streamToInputType (ConstM43F  _) = M43F
streamToInputType (ConstM44F  _) = M44F
streamToInputType (Stream t (Buffer a _) i _ _)
    | 0 <= i && i < V.length a &&
      if elem t integralTypes then elem at integralArrTypes else True
    = fromStreamType t
    | otherwise = throw $ userError "streamToInputType failed"
  where
    at = arrType $! (a V.! i)
    integralTypes    = [TWord, TV2U, TV3U, TV4U, TInt, TV2I, TV3I, TV4I]
    integralArrTypes = [ArrWord8, ArrWord16, ArrWord32, ArrInt8, ArrInt16, ArrInt32]

comparisonFunctionToGLType :: ComparisonFunction -> GLenum
comparisonFunctionToGLType Always   = gl_ALWAYS
comparisonFunctionToGLType Equal    = gl_EQUAL
comparisonFunctionToGLType Gequal   = gl_GEQUAL
comparisonFunctionToGLType Greater  = gl_GREATER
comparisonFunctionToGLType Lequal   = gl_LEQUAL
comparisonFunctionToGLType Less     = gl_LESS
comparisonFunctionToGLType Never    = gl_NEVER
comparisonFunctionToGLType Notequal = gl_NOTEQUAL

logicOperationToGLType :: LogicOperation -> GLenum
logicOperationToGLType And          = gl_AND
logicOperationToGLType AndInverted  = gl_AND_INVERTED
logicOperationToGLType AndReverse   = gl_AND_REVERSE
logicOperationToGLType Clear        = gl_CLEAR
logicOperationToGLType Copy         = gl_COPY
logicOperationToGLType CopyInverted = gl_COPY_INVERTED
logicOperationToGLType Equiv        = gl_EQUIV
logicOperationToGLType Invert       = gl_INVERT
logicOperationToGLType Nand         = gl_NAND
logicOperationToGLType Noop         = gl_NOOP
logicOperationToGLType Nor          = gl_NOR
logicOperationToGLType Or           = gl_OR
logicOperationToGLType OrInverted   = gl_OR_INVERTED
logicOperationToGLType OrReverse    = gl_OR_REVERSE
logicOperationToGLType Set          = gl_SET
logicOperationToGLType Xor          = gl_XOR

blendEquationToGLType :: BlendEquation -> GLenum
blendEquationToGLType FuncAdd               = gl_FUNC_ADD
blendEquationToGLType FuncReverseSubtract   = gl_FUNC_REVERSE_SUBTRACT
blendEquationToGLType FuncSubtract          = gl_FUNC_SUBTRACT
blendEquationToGLType Max                   = gl_MAX
blendEquationToGLType Min                   = gl_MIN

blendingFactorToGLType :: BlendingFactor -> GLenum
blendingFactorToGLType ConstantAlpha         = gl_CONSTANT_ALPHA
blendingFactorToGLType ConstantColor         = gl_CONSTANT_COLOR
blendingFactorToGLType DstAlpha              = gl_DST_ALPHA
blendingFactorToGLType DstColor              = gl_DST_COLOR
blendingFactorToGLType One                   = gl_ONE
blendingFactorToGLType OneMinusConstantAlpha = gl_ONE_MINUS_CONSTANT_ALPHA
blendingFactorToGLType OneMinusConstantColor = gl_ONE_MINUS_CONSTANT_COLOR
blendingFactorToGLType OneMinusDstAlpha      = gl_ONE_MINUS_DST_ALPHA
blendingFactorToGLType OneMinusDstColor      = gl_ONE_MINUS_DST_COLOR
blendingFactorToGLType OneMinusSrcAlpha      = gl_ONE_MINUS_SRC_ALPHA
blendingFactorToGLType OneMinusSrcColor      = gl_ONE_MINUS_SRC_COLOR
blendingFactorToGLType SrcAlpha              = gl_SRC_ALPHA
blendingFactorToGLType SrcAlphaSaturate      = gl_SRC_ALPHA_SATURATE
blendingFactorToGLType SrcColor              = gl_SRC_COLOR
blendingFactorToGLType Zero                  = gl_ZERO

{-
data ColorArity = Red | RG | RGB | RGBA deriving (Show,Eq,Ord)
data TextureDataType
    = FloatT        ColorArity
    | IntT          ColorArity
    | WordT         ColorArity
    | ShadowT
    deriving (Show, Eq, Ord)
-}
textureDataTypeToGLType :: TextureDataType -> GLenum
textureDataTypeToGLType (FloatT Red)    = gl_R32F
textureDataTypeToGLType (IntT   Red)    = gl_R32I
textureDataTypeToGLType (WordT  Red)    = gl_R32UI
textureDataTypeToGLType (FloatT RG)     = gl_RG32F
textureDataTypeToGLType (IntT   RG)     = gl_RG32I
textureDataTypeToGLType (WordT  RG)     = gl_RG32UI
textureDataTypeToGLType (FloatT RGB)    = gl_RGB32F
textureDataTypeToGLType (IntT   RGB)    = gl_RGB32I
textureDataTypeToGLType (WordT  RGB)    = gl_RGB32UI
textureDataTypeToGLType (FloatT RGBA)   = gl_RGBA32F
textureDataTypeToGLType (IntT   RGBA)   = gl_RGBA32I
textureDataTypeToGLType (WordT  RGBA)   = gl_RGBA32UI
textureDataTypeToGLType a = error $ "FIXME: This texture format is not yet supported " ++ show a

textureDataTypeToGLArityType :: TextureDataType -> GLenum
textureDataTypeToGLArityType (FloatT Red)    = gl_RED
textureDataTypeToGLArityType (IntT   Red)    = gl_RED
textureDataTypeToGLArityType (WordT  Red)    = gl_RED
textureDataTypeToGLArityType (FloatT RG)     = gl_RG
textureDataTypeToGLArityType (IntT   RG)     = gl_RG
textureDataTypeToGLArityType (WordT  RG)     = gl_RG
textureDataTypeToGLArityType (FloatT RGB)    = gl_RGB
textureDataTypeToGLArityType (IntT   RGB)    = gl_RGB
textureDataTypeToGLArityType (WordT  RGB)    = gl_RGB
textureDataTypeToGLArityType (FloatT RGBA)   = gl_RGBA
textureDataTypeToGLArityType (IntT   RGBA)   = gl_RGBA
textureDataTypeToGLArityType (WordT  RGBA)   = gl_RGBA
textureDataTypeToGLArityType a = error $ "FIXME: This texture format is not yet supported " ++ show a
{-
Texture and renderbuffer color formats (R):
    R11F_G11F_B10F
    R16
    R16F
    R16I
    R16UI
    R32F
    R32I
    R32UI
    R8
    R8I
    R8UI
    RG16
    RG16F
    RG16I
    RG16UI
    RG32F
    RG32I
    RG32UI
    RG8
    RG8I
    RG8UI
    RGB10_A2
    RGB10_A2UI
    RGBA16
    RGBA16F
    RGBA16I
    RGBA16UI
    RGBA32F
    RGBA32I
    RGBA32UI
    RGBA8
    RGBA8I
    RGBA8UI
    SRGB8_ALPHA8
-}

glGetIntegerv1 :: GLenum -> IO GLint
glGetIntegerv1 e = alloca $ \pi -> glGetIntegerv e pi >> peek pi

checkFBO :: IO ByteString
checkFBO = do
    let f e | e == gl_FRAMEBUFFER_UNDEFINED                 = "FRAMEBUFFER_UNDEFINED"
            | e == gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT     = "FRAMEBUFFER_INCOMPLETE_ATTACHMENT"
            | e == gl_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER    = "FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER"
            | e == gl_FRAMEBUFFER_INCOMPLETE_READ_BUFFER    = "FRAMEBUFFER_INCOMPLETE_READ_BUFFER"
            | e == gl_FRAMEBUFFER_UNSUPPORTED               = "FRAMEBUFFER_UNSUPPORTED"
            | e == gl_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE    = "FRAMEBUFFER_INCOMPLETE_MULTISAMPLE"
            | e == gl_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS  = "FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS"
            | e == gl_FRAMEBUFFER_COMPLETE                  = "FRAMEBUFFER_COMPLETE"
            | otherwise                                     = "Unknown error"
    e <- glCheckFramebufferStatus gl_DRAW_FRAMEBUFFER
    return $ f e

{-
data TextureDataType - gl internal representation
    = FloatT        ColorArity
    | IntT          ColorArity
    | WordT         ColorArity
    | ShadowT
    deriving (Show, Eq, Ord)

data TextureType - gl texture target
    = Texture1D     TextureDataType Int
    | Texture2D     TextureDataType Int
    | Texture3D     TextureDataType
    | TextureCube   TextureDataType
    | TextureRect   TextureDataType
    | Texture2DMS   TextureDataType Int
    | TextureBuffer TextureDataType
    deriving (Show, Eq, Ord)
-}
createGLTextureObject :: DAG -> Exp -> IO GLuint
createGLTextureObject dag (Sampler txFilter txEdgeMode tx) = do
    let Texture txType txSize txMipMap txGPList = toExp dag tx
        wrapMode = case txEdgeMode of
            Repeat          -> gl_REPEAT
            MirroredRepeat  -> gl_MIRRORED_REPEAT
            ClampToEdge     -> gl_CLAMP_TO_EDGE
            ClampToBorder   -> gl_CLAMP_TO_BORDER
        filterMode = case txFilter of
            PointFilter     -> gl_NEAREST
            LinearFilter    -> gl_LINEAR
    to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
    {-
        void glTexImage1D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLint border, GLenum format, GLenum type, void *data );
        void glTexImage2D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLint border, GLenum format, GLenum type, void *data );
        void glTexImage3D( GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, void *data );
        void glTexImage2DMultisample( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLboolean ﬁxedsamplelocations );
        void glTexImage3DMultisample( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLsizei depth, GLboolean ﬁxedsamplelocations );
    -}
    -- FIXME: for now we support only single 2D texture
    case txType of
        {-
        Texture1D dTy n     -> return ()
        Texture2D dTy n     -> return ()
        Texture3D dTy       -> return ()
        TextureCube dTy     -> return ()
        TextureRect dTy     -> return ()
        Texture2DMS dTy n   -> return ()
        TextureBuffer dTy   -> return ()
        -}
{-
    let (width,height) = bitmapSize bitmap
        wrapMode = case isClamped of
            True    -> gl_CLAMP_TO_EDGE
            False   -> gl_REPEAT
        (minFilter,maxLevel) = case isMip of
            False   -> (gl_LINEAR,0)
            True    -> (gl_LINEAR_MIPMAP_LINEAR, floor $ log (fromIntegral $ max width height) / log 2)
    glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S $ fromIntegral wrapMode
    glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T $ fromIntegral wrapMode
    glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $ fromIntegral minFilter
    glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $ fromIntegral gl_LINEAR
    glTexParameteri gl_TEXTURE_2D gl_TEXTURE_BASE_LEVEL 0
    glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAX_LEVEL $ fromIntegral maxLevel
    withBitmap bitmap $ \(w,h) nchn 0 ptr -> do
        let internalFormat  = fromIntegral gl_RGBA8
            dataFormat      = fromIntegral $ case nchn of
                3   -> gl_RGB
                4   -> gl_RGBA
                _   -> error "unsupported texture format!"
        glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE $ castPtr ptr
    when isMip $ glGenerateMipmap gl_TEXTURE_2D
-}
        TextureCube dTy -> if txMipMap /= NoMip then error "FIXME: Only NoMip textures are supported yet!" else 
                               if length txGPList /= 1 then error "Invalid texture source specification!" else do
            let internalFormat  = fromIntegral $ textureDataTypeToGLType dTy
                dataFormat      = fromIntegral $ textureDataTypeToGLArityType dTy
                VV2U (V2 w h)   = txSize
            glBindTexture gl_TEXTURE_CUBE_MAP to
            glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_WRAP_S $ fromIntegral wrapMode
            glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_WRAP_T $ fromIntegral wrapMode
            glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MAG_FILTER $ fromIntegral filterMode
            glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MIN_FILTER $ fromIntegral filterMode
            glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_BASE_LEVEL 0
            glTexParameteri gl_TEXTURE_CUBE_MAP gl_TEXTURE_MAX_LEVEL 0
            let l = [ gl_TEXTURE_CUBE_MAP_POSITIVE_X 
                    , gl_TEXTURE_CUBE_MAP_NEGATIVE_X
                    , gl_TEXTURE_CUBE_MAP_POSITIVE_Y
                    , gl_TEXTURE_CUBE_MAP_NEGATIVE_Y
                    , gl_TEXTURE_CUBE_MAP_POSITIVE_Z
                    , gl_TEXTURE_CUBE_MAP_NEGATIVE_Z
                    ]
            forM_ l $ \t -> glTexImage2D t 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr

        -- temporary texture support: 2D NoMip Float/Int/Word Red/RG/RGBA
        Texture2D dTy layerCnt -> if txMipMap /= NoMip then error "FIXME: Only NoMip textures are supported yet!" else 
                               if length txGPList /= 1 then error "Invalid texture source specification!" else do
            let internalFormat  = fromIntegral $ textureDataTypeToGLType dTy
                dataFormat      = fromIntegral $ textureDataTypeToGLArityType dTy
                VV2U (V2 w h)   = txSize
                txTarget        = if layerCnt > 1 then gl_TEXTURE_2D_ARRAY else gl_TEXTURE_2D
            glBindTexture txTarget to
            -- temp
            glTexParameteri txTarget gl_TEXTURE_WRAP_S $ fromIntegral wrapMode
            glTexParameteri txTarget gl_TEXTURE_WRAP_T $ fromIntegral wrapMode
            glTexParameteri txTarget gl_TEXTURE_MAG_FILTER $ fromIntegral filterMode
            glTexParameteri txTarget gl_TEXTURE_MIN_FILTER $ fromIntegral filterMode
            glTexParameteri txTarget gl_TEXTURE_BASE_LEVEL 0
            glTexParameteri txTarget gl_TEXTURE_MAX_LEVEL 0
            -- temp end
            case layerCnt > 1 of
                True    -> glTexImage3D gl_TEXTURE_2D_ARRAY 0 internalFormat (fromIntegral w) (fromIntegral h) (fromIntegral layerCnt) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
                False   -> glTexImage2D gl_TEXTURE_2D 0 internalFormat (fromIntegral w) (fromIntegral h) 0 dataFormat gl_UNSIGNED_BYTE nullPtr
            return ()
        _ -> error $ "FIXME: This texture format is not yet supported: " ++ show txType
    return to
