{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, ScopedTypeVariables, AllowAmbiguousTypes, EmptyDataDecls #-}
module Graphics.GPipe.Internal.Texture where

import Graphics.GPipe.Internal.Format
import Graphics.GPipe.Internal.Expr
import Graphics.GPipe.Internal.Context
import Graphics.GPipe.Internal.Shader
import Graphics.GPipe.Internal.Compiler
import Graphics.GPipe.Internal.Buffer
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IntMap.Lazy (insert)

import Graphics.GL.Core33
import Graphics.GL.Types
import Graphics.GL.Ext.EXT.TextureFilterAnisotropic

import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Control.Monad
import Data.IORef
import Control.Applicative
import Control.Monad.Exception (bracket, MonadAsyncException)
import Linear.V4
import Linear.V3
import Linear.V2
import Control.Exception (throwIO)
import Control.Monad.Trans.Class (lift)

data Texture1D os a = Texture1D TexName Size1 MaxLevels
data Texture1DArray os a = Texture1DArray TexName Size2 MaxLevels
data Texture2D os a = Texture2D TexName Size2 MaxLevels
                    | RenderBuffer2D TexName Size2
data Texture2DArray os a = Texture2DArray TexName Size3 MaxLevels
data Texture3D os a = Texture3D TexName Size3 MaxLevels
data TextureCube os a = TextureCube TexName Size1 MaxLevels

type MaxLevels = Int

type Size1 = Int
type Size2 = V2 Int
type Size3 = V3 Int

newTexture1D :: forall ctx w os f c m. (ContextHandler ctx, ColorSampleable c, MonadIO m) => Format c -> Size1 -> MaxLevels -> ContextT ctx os m (Texture1D os (Format c))
newTexture1DArray :: forall ctx w os f c m. (ContextHandler ctx, ColorSampleable c, MonadIO m) => Format c -> Size2 -> MaxLevels -> ContextT ctx os m (Texture1DArray os (Format c))
newTexture2D :: forall ctx w os f c m. (ContextHandler ctx, TextureFormat c, MonadIO m) => Format c -> Size2 -> MaxLevels -> ContextT ctx os m (Texture2D os (Format c))
newTexture2DArray :: forall ctx w os f c m. (ContextHandler ctx, ColorSampleable c, MonadIO m) => Format c -> Size3 -> MaxLevels -> ContextT ctx os m (Texture2DArray os (Format c))
newTexture3D :: forall ctx w os f c m. (ContextHandler ctx, ColorRenderable c, MonadIO m) => Format c -> Size3 -> MaxLevels -> ContextT ctx os m (Texture3D os (Format c))
newTextureCube :: forall ctx w os f c m. (ContextHandler ctx, ColorSampleable c, MonadIO m) => Format c -> Size1 -> MaxLevels -> ContextT ctx os m (TextureCube os (Format c))

newTexture1D f s mx | s < 0 = error "newTexture1D, negative size"
                    | mx <= 0 = error "newTexture1D, non-positive MaxLevels"
                    | otherwise = do
                        mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
                        if s > mxSize
                          then liftIO $ throwIO $ GPipeException "newTexture1D, size larger then maximum supported by graphics driver"
                          else do
                            t <- makeTex
                            let glintf = fromIntegral $ getGlInternalFormat f
                                glf = getGlFormat (undefined :: c)
                                ls = min mx (calcMaxLevels s)
                                tex = Texture1D t s ls
                            liftNonWinContextAsyncIO $ do
                                useTexSync t GL_TEXTURE_1D
                                forM_ (zip (texture1DSizes tex) [0..]) $ \(lw, l) ->
                                    glTexImage1D GL_TEXTURE_1D l glintf (fromIntegral lw) 0 glf GL_BYTE nullPtr
                                setDefaultTexParams GL_TEXTURE_1D (ls-1)
                            return tex
newTexture1DArray f s@(V2 w sl) mx
                    | w < 0 || sl < 0 = error "newTexture1DArray, negative size"
                    | mx <= 0 = error "newTexture1DArray, non-positive MaxLevels"
                    | otherwise = do
                            mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
                            if w > mxSize || sl > mxSize
                              then liftIO $ throwIO $ GPipeException "newTexture1DArray, size larger then maximum supported by graphics driver"
                              else do
                                t <- makeTex
                                let glintf = fromIntegral $ getGlInternalFormat f
                                    glf = getGlFormat (undefined :: c)
                                    ls = min mx (calcMaxLevels w)
                                    tex = Texture1DArray t s ls
                                liftNonWinContextAsyncIO $ do
                                    useTexSync t GL_TEXTURE_1D_ARRAY
                                    forM_ (zip (texture1DArraySizes tex) [0..]) $ \(V2 lw _, l) ->
                                        glTexImage2D GL_TEXTURE_1D_ARRAY l glintf (fromIntegral lw) (fromIntegral sl) 0 glf GL_BYTE nullPtr
                                    setDefaultTexParams GL_TEXTURE_1D_ARRAY (ls-1)
                                return tex
newTexture2D f s@(V2 w h) mx | w < 0 || h < 0 = error "newTexture2D, negative size"
                             | mx <= 0 = error "newTexture2D, non-positive MaxLevels"
                             | getGlFormat (undefined :: c) == GL_STENCIL_INDEX = do
                                mxSize <- getGlValue GL_MAX_RENDERBUFFER_SIZE
                                if w > mxSize || h > mxSize
                                  then liftIO $ throwIO $ GPipeException "newTexture2D, size larger then maximum supported by graphics driver"
                                  else do
                                    t <- makeRenderBuff
                                    liftNonWinContextAsyncIO $
                                       glRenderbufferStorage GL_RENDERBUFFER (getGlInternalFormat f) (fromIntegral w) (fromIntegral h)
                                    return $ RenderBuffer2D t s
                             | otherwise = do
                                mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
                                if w > mxSize || h > mxSize
                                  then liftIO $ throwIO $ GPipeException "newTexture2D, size larger then maximum supported by graphics driver"
                                  else do
                                    t <- makeTex
                                    let glintf = fromIntegral $ getGlInternalFormat f
                                        glf = getGlFormat (undefined :: c)
                                        ls = min mx (calcMaxLevels (max w h))
                                        tex = Texture2D t s ls
                                    liftNonWinContextAsyncIO $ do
                                        useTexSync t GL_TEXTURE_2D
                                        forM_ (zip (texture2DSizes tex) [0..]) $ \(V2 lw lh, l) ->
                                            glTexImage2D GL_TEXTURE_2D l glintf (fromIntegral lw) (fromIntegral lh) 0 glf GL_BYTE nullPtr
                                        setDefaultTexParams GL_TEXTURE_2D (ls-1)
                                    return tex

newTexture2DArray f s@(V3 w h sl) mx
                                | w < 0 || h < 0 || sl < 0 = error "newTexture2DArray, negative size"
                                | mx <= 0 = error "newTexture2DArray, non-positive MaxLevels"
                                | otherwise = do
                    mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
                    if w > mxSize || h > mxSize || sl > mxSize
                      then liftIO $ throwIO $ GPipeException "newTexture2DArray, size larger then maximum supported by graphics driver"
                      else do
                        t <- makeTex
                        let glintf = fromIntegral $ getGlInternalFormat f
                            glf = getGlFormat (undefined :: c)
                            ls = min mx (calcMaxLevels (max w h))
                            tex = Texture2DArray t s ls
                        liftNonWinContextAsyncIO $ do
                            useTexSync t GL_TEXTURE_2D_ARRAY
                            forM_ (zip (texture2DArraySizes tex) [0..]) $ \(V3 lw lh _, l) ->
                                glTexImage3D GL_TEXTURE_2D_ARRAY l glintf (fromIntegral lw) (fromIntegral lh) (fromIntegral sl) 0 glf GL_BYTE nullPtr
                            setDefaultTexParams GL_TEXTURE_2D_ARRAY (ls-1)
                        return tex

newTexture3D f s@(V3 w h d) mx | w < 0 || h < 0 || d < 0 = error "newTexture3D, negative size"
                               | mx <= 0 = error "newTexture3D, non-positive MaxLevels"
                               | otherwise = do
                    mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
                    if w > mxSize || h > mxSize || d > mxSize
                      then liftIO $ throwIO $ GPipeException "newTexture3D, size larger then maximum supported by graphics driver"
                      else do
                        t <- makeTex
                        let glintf = fromIntegral $ getGlInternalFormat f
                            glf = getGlFormat (undefined :: c)
                            ls = min mx (calcMaxLevels (max w (max h d)))
                            tex = Texture3D t s ls
                        liftNonWinContextAsyncIO $ do
                            useTexSync t GL_TEXTURE_3D
                            forM_ (zip (texture3DSizes tex) [0..]) $ \(V3 lw lh ld, l) ->
                                glTexImage3D GL_TEXTURE_3D l glintf (fromIntegral lw) (fromIntegral lh) (fromIntegral ld) 0 glf GL_BYTE nullPtr
                            setDefaultTexParams GL_TEXTURE_3D (ls-1)
                        return tex
newTextureCube f s mx | s < 0 = error "newTextureCube, negative size"
                      | mx <= 0 = error "newTextureCube, non-positive MaxLevels"
                      | otherwise = do
                    mxSize <- getGlValue GL_MAX_CUBE_MAP_TEXTURE_SIZE
                    if s > mxSize
                      then liftIO $ throwIO $ GPipeException "newTextureCube, size larger then maximum supported by graphics driver"
                      else do
                            t <- makeTex
                            let glintf = fromIntegral $ getGlInternalFormat f
                                glf = getGlFormat (undefined :: c)
                                ls = min mx (calcMaxLevels s)
                                tex = TextureCube t s ls
                            liftNonWinContextAsyncIO $ do
                                useTexSync t GL_TEXTURE_CUBE_MAP
                                forM_ [(size, getGlCubeSide side) | size <- zip (textureCubeSizes tex) [0..], side <- [minBound..maxBound]] $ \((lx, l), side) ->
                                    glTexImage2D side l glintf (fromIntegral lx) (fromIntegral lx) 0 glf GL_BYTE nullPtr
                                setDefaultTexParams GL_TEXTURE_CUBE_MAP (ls-1)
                                glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE
                                glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE
                                glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP_TO_EDGE
                            return tex

getGlValue :: (ContextHandler ctx, MonadIO m) =>  GLenum -> ContextT ctx os m Int
getGlValue enum = liftNonWinContextIO $ alloca (\ptr -> fmap fromIntegral (glGetIntegerv enum ptr >> peek ptr))

setDefaultTexParams :: GLenum -> Int -> IO ()
setDefaultTexParams t ml = do
                            glTexParameteri t GL_TEXTURE_BASE_LEVEL 0
                            glTexParameteri t GL_TEXTURE_MAX_LEVEL (fromIntegral ml)
                            glTexParameteri t GL_TEXTURE_MIN_FILTER GL_NEAREST_MIPMAP_NEAREST
                            glTexParameteri t GL_TEXTURE_MAG_FILTER GL_NEAREST


texture1DLevels :: Texture1D os f -> Int
texture1DArrayLevels :: Texture1DArray os f -> Int
texture2DLevels :: Texture2D os f -> Int
texture2DArrayLevels :: Texture2DArray os f -> Int
texture3DLevels :: Texture3D os f -> Int
textureCubeLevels :: TextureCube os f -> Int
texture1DLevels (Texture1D _ _ ls) = ls
texture1DArrayLevels (Texture1DArray _ _ ls) = ls
texture2DLevels (Texture2D _ _ ls) = ls
texture2DLevels (RenderBuffer2D _ _) = 1
texture2DArrayLevels (Texture2DArray _ _ ls) = ls
texture3DLevels (Texture3D _ _ ls) = ls
textureCubeLevels (TextureCube _ _ ls) = ls

texture1DSizes :: Texture1D os f -> [Size1]
texture1DArraySizes :: Texture1DArray os f -> [Size2]
texture2DSizes :: Texture2D os f -> [Size2]
texture2DArraySizes :: Texture2DArray os f -> [Size3]
texture3DSizes :: Texture3D os f -> [Size3]
textureCubeSizes :: TextureCube os f -> [Size1]
texture1DSizes (Texture1D _ w ls) = map (calcLevelSize w) [0..(ls-1)]
texture1DArraySizes (Texture1DArray _ (V2 w s) ls) = map (\l -> V2 (calcLevelSize w l) s) [0..(ls-1)]
texture2DSizes (Texture2D _ (V2 w h) ls) = map (\l -> V2 (calcLevelSize w l) (calcLevelSize h l)) [0..(ls-1)]
texture2DSizes (RenderBuffer2D _ s) = [s]
texture2DArraySizes (Texture2DArray _ (V3 w h s) ls) = map (\l -> V3 (calcLevelSize w l) (calcLevelSize h l) s) [0..(ls-1)]
texture3DSizes (Texture3D _ (V3 w h d) ls) = map (\l -> V3 (calcLevelSize w l) (calcLevelSize h l) (calcLevelSize d l)) [0..(ls-1)]
textureCubeSizes (TextureCube _ x ls) = map (calcLevelSize x) [0..(ls-1)]

calcLevelSize :: Int -> Int -> Int
calcLevelSize size0 level = max 1 (size0 `div` (2 ^ level))

calcMaxLevels :: Int -> Int
calcMaxLevels s = 1 + truncate (logBase 2.0 (fromIntegral s :: Double))

type TexName = IORef GLuint

makeTex :: (ContextHandler ctx, MonadIO m) => ContextT ctx os m TexName
makeTex = do
    name <- liftNonWinContextIO $ alloca (\ptr -> glGenTextures 1 ptr >> peek ptr)
    tex <- liftIO $ newIORef name
    addContextFinalizer tex $ with name (glDeleteTextures 1)
    addFBOTextureFinalizer False tex
    return tex

makeRenderBuff :: (ContextHandler ctx, MonadIO m) => ContextT ctx os m TexName
makeRenderBuff = do
    name <- liftNonWinContextIO $ alloca (\ptr -> glGenRenderbuffers 1 ptr >> peek ptr)
    tex <- liftIO $ newIORef name
    addContextFinalizer tex $ with name (glDeleteRenderbuffers 1)
    addFBOTextureFinalizer True tex
    return tex

useTex :: Integral a => TexName -> GLenum -> a -> IO Int
useTex texNameRef t bind = do glActiveTexture (GL_TEXTURE0 + fromIntegral bind)
                              n <- readIORef texNameRef
                              glBindTexture t n
                              return (fromIntegral n)

useTexSync :: TexName -> GLenum -> IO ()
useTexSync tn t = do maxUnits <- alloca (\ptr -> glGetIntegerv GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS ptr >> peek ptr)  -- Use last for all sync actions, keeping 0.. for async drawcalls
                     void $ useTex tn t (maxUnits-1)


type Level = Int
data CubeSide = CubePosX | CubeNegX | CubePosY | CubeNegY | CubePosZ | CubeNegZ deriving (Eq, Enum, Bounded)

type StartPos1 = Int
type StartPos2 = V2 Int
type StartPos3 = V3 Int


writeTexture1D      :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture1D os (Format c) -> Level -> StartPos1 -> Size1 -> [h] -> ContextT ctx os m ()
writeTexture1DArray :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture1DArray os (Format c) -> Level -> StartPos2 -> Size2 -> [h] -> ContextT ctx os m ()
writeTexture2D      :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture2D os (Format c) -> Level -> StartPos2 -> Size2 -> [h] -> ContextT ctx os m ()
writeTexture2DArray :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture2DArray os (Format c) -> Level -> StartPos3 -> Size3 -> [h] -> ContextT ctx os m ()
writeTexture3D      :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture3D os (Format c) -> Level -> StartPos3 -> Size3 -> [h] -> ContextT ctx os m ()
writeTextureCube    :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => TextureCube os (Format c) -> Level -> CubeSide -> StartPos2 -> Size2 -> [h] -> ContextT ctx os m ()

writeTexture1DFromBuffer     :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture1D os (Format c) -> Level -> StartPos1 -> Size1 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
writeTexture1DArrayFromBuffer:: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture1DArray os (Format c) -> Level -> StartPos2 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
writeTexture2DFromBuffer     :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture2D os (Format c) -> Level -> StartPos2 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
writeTexture2DArrayFromBuffer:: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture2DArray os (Format c) -> Level -> StartPos3 -> Size3 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
writeTexture3DFromBuffer     :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture3D os (Format c) -> Level -> StartPos3 -> Size3 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
writeTextureCubeFromBuffer   :: forall ctx b c h w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => TextureCube os (Format c) -> Level -> CubeSide -> StartPos2 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()


readTexture1D      :: forall ctx a b c h w os f m. (ContextHandler ctx, MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture1D os (Format c) -> Level -> StartPos1 -> Size1 -> (a -> h -> ContextT ctx os m a) -> a -> ContextT ctx os m a
readTexture1DArray :: forall ctx a b c h w os f m. (ContextHandler ctx, MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture1DArray os (Format c) -> Level -> StartPos2 -> Size1 -> (a -> h -> ContextT ctx os m a) -> a -> ContextT ctx os m a
readTexture2D      :: forall ctx a b c h w os f m. (ContextHandler ctx, MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture2D os (Format c) -> Level -> StartPos2 -> Size2 -> (a -> h -> ContextT ctx os m a) -> a -> ContextT ctx os m a
readTexture2DArray :: forall ctx a b c h w os f m. (ContextHandler ctx, MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture2DArray os (Format c) -> Level -> StartPos3 -> Size2 -> (a -> h -> ContextT ctx os m a) -> a -> ContextT ctx os m a
readTexture3D      :: forall ctx a b c h w os f m. (ContextHandler ctx, MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture3D os (Format c) -> Level -> StartPos3 -> Size2 -> (a -> h -> ContextT ctx os m a) -> a -> ContextT ctx os m a
readTextureCube    :: forall ctx a b c h w os f m. (ContextHandler ctx, MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => TextureCube os (Format c) -> Level -> CubeSide -> StartPos2 -> Size2 -> (a -> h -> ContextT ctx os m a) -> a -> ContextT ctx os m a

readTexture1DToBuffer     :: forall ctx b c w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture1D os (Format c) -> Level -> StartPos1 -> Size1 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
readTexture1DArrayToBuffer:: forall ctx b c w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture1DArray os (Format c) -> Level -> StartPos2 -> Size1 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
readTexture2DToBuffer     :: forall ctx b c w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture2D os (Format c) -> Level -> StartPos2 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
readTexture2DArrayToBuffer:: forall ctx b c w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture2DArray os (Format c) -> Level -> StartPos3 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
readTexture3DToBuffer     :: forall ctx b c w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture3D os (Format c) -> Level -> StartPos3 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT ctx os m ()
readTextureCubeToBuffer   :: forall ctx b c w os f m. (ContextHandler ctx, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => TextureCube os (Format c) -> Level -> CubeSide -> StartPos2 -> Size2 -> Buffer os b-> BufferStartPos -> ContextT ctx os m ()

getGlColorFormat :: (TextureFormat f, BufferFormat b) => f -> b -> GLenum
getGlColorFormat f b = let x = getGlFormat f in if x == GL_DEPTH_STENCIL || x == GL_DEPTH_COMPONENT then GL_DEPTH_COMPONENT else getGlPaddedFormat b

writeTexture1D t@(Texture1D texn _ ml) l x w d
    | l < 0 || l >= ml = error "writeTexture1D, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture1D, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture1D, w out of bounds"
    | otherwise = liftNonWinContextAsyncIO $ do
                     let b = makeBuffer undefined undefined 0 :: Buffer os b
                         size = w*bufElementSize b
                     allocaBytes size $ \ ptr -> do
                         end <- bufferWriteInternal b ptr (take w d)
                         if end `minusPtr` ptr /= size
                            then error "writeTexture1D, data list too short"
                            else do
                                useTexSync texn GL_TEXTURE_1D
                                glTexSubImage1D GL_TEXTURE_1D (fromIntegral l) (fromIntegral x) (fromIntegral w) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
    where mx = texture1DSizes t !! l

writeTexture1DArray t@(Texture1DArray texn _ ml) l (V2 x y) (V2 w h) d
    | l < 0 || l >= ml = error "writeTexture1DArray, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture1DArray, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture1DArray, w out of bounds"
    | y < 0 || y >= my = error "writeTexture1DArray, y out of bounds"
    | h < 0 || y+h > my = error "writeTexture2D, h out of bounds"
    | otherwise = liftNonWinContextAsyncIO $ do
                     let b = makeBuffer undefined undefined 0 :: Buffer os b
                         size = w*h*bufElementSize b
                     allocaBytes size $ \ ptr -> do
                         end <- bufferWriteInternal b ptr (take (w*h) d)
                         if end `minusPtr` ptr /= size
                            then error "writeTexture1DArray, data list too short"
                            else do
                                useTexSync texn GL_TEXTURE_1D_ARRAY
                                glTexSubImage2D GL_TEXTURE_1D_ARRAY (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
    where V2 mx my = texture1DArraySizes t !! l
writeTexture2D t@(Texture2D texn _ ml) l (V2 x y) (V2 w h) d
    | l < 0 || l >= ml = error "writeTexture2D, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture2D, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture2D, w out of bounds"
    | y < 0 || y >= my = error "writeTexture2D, y out of bounds"
    | h < 0 || y+h > my = error "writeTexture2D, h out of bounds"
    | otherwise = liftNonWinContextAsyncIO $ do
                     let b = makeBuffer undefined undefined 0 :: Buffer os b
                         size = w*h*bufElementSize b
                     allocaBytes size $ \ ptr -> do
                         end <- bufferWriteInternal b ptr (take (w*h) d)
                         if end `minusPtr` ptr /= size
                            then error "writeTexture2D, data list too short"
                            else do
                                useTexSync texn GL_TEXTURE_2D
                                glTexSubImage2D GL_TEXTURE_2D (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
    where V2 mx my = texture2DSizes t !! l
writeTexture2DArray t@(Texture2DArray texn _ ml) l (V3 x y z) (V3 w h d) dat
    | l < 0 || l >= ml = error "writeTexture2DArray, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture2DArray, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture2DArray, w out of bounds"
    | y < 0 || y >= my = error "writeTexture2DArray, y out of bounds"
    | h < 0 || y+h > my = error "writeTexture2DArray, h out of bounds"
    | z < 0 || z >= mz = error "writeTexture2DArray, z out of bounds"
    | d < 0 || z+d > mz = error "writeTexture2DArray, d out of bounds"
    | otherwise = liftNonWinContextAsyncIO $ do
                     let b = makeBuffer undefined undefined 0 :: Buffer os b
                         size = w*h*d*bufElementSize b
                     allocaBytes size $ \ ptr -> do
                         end <- bufferWriteInternal b ptr (take (w*h*d) dat)
                         if end `minusPtr` ptr /= size
                            then error "writeTexture2DArray, data list too short"
                            else do
                                useTexSync texn GL_TEXTURE_2D_ARRAY
                                glTexSubImage3D GL_TEXTURE_2D_ARRAY (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
    where V3 mx my mz = texture2DArraySizes t !! l
writeTexture3D t@(Texture3D texn _ ml) l (V3 x y z) (V3 w h d) dat
    | l < 0 || l >= ml = error "writeTexture3D, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture3D, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture3D, w out of bounds"
    | y < 0 || y >= my = error "writeTexture3D, y out of bounds"
    | h < 0 || y+h > my = error "writeTexture3D, h out of bounds"
    | z < 0 || z >= mz = error "writeTexture3D, z out of bounds"
    | d < 0 || z+d > mz = error "writeTexture3D, d out of bounds"
    | otherwise = liftNonWinContextAsyncIO $ do
                     let b = makeBuffer undefined undefined 0 :: Buffer os b
                         size = w*h*d*bufElementSize b
                     allocaBytes size $ \ ptr -> do
                         end <- bufferWriteInternal b ptr (take (w*h*d) dat)
                         if end `minusPtr` ptr /= size
                            then error "writeTexture3D, data list too short"
                            else do
                                useTexSync texn GL_TEXTURE_3D
                                glTexSubImage3D GL_TEXTURE_3D (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
    where V3 mx my mz = texture3DSizes t !! l
writeTextureCube t@(TextureCube texn _ ml) l s (V2 x y) (V2 w h) d
    | l < 0 || l >= ml = error "writeTextureCube, level out of bounds"
    | x < 0 || x >= mxy = error "writeTextureCube, x out of bounds"
    | w < 0 || x+w > mxy = error "writeTextureCube, w out of bounds"
    | y < 0 || y >= mxy = error "writeTextureCube, y out of bounds"
    | h < 0 || y+h > mxy = error "writeTextureCube, h out of bounds"
    | otherwise = liftNonWinContextAsyncIO $ do
                     let b = makeBuffer undefined undefined 0 :: Buffer os b
                         size = w*h*bufElementSize b
                     allocaBytes size $ \ ptr -> do
                         end <- bufferWriteInternal b ptr (take (w*h) d)
                         if end `minusPtr` ptr /= size
                            then error "writeTextureCube, data list too short"
                            else do
                                useTexSync texn GL_TEXTURE_CUBE_MAP
                                glTexSubImage2D (getGlCubeSide s) (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
    where mxy = textureCubeSizes t !! l

writeTexture1DFromBuffer t@(Texture1D texn _ ml) l x w b i
    | l < 0 || l >= ml = error "writeTexture1DFromBuffer, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture1DFromBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture1DFromBuffer, w out of bounds"
    | i < 0 || i > bufferLength b = error "writeTexture1DFromBuffer, i out of bounds"
    | bufferLength b - i < w = error "writeTexture1DFromBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                    useTexSync texn GL_TEXTURE_1D
                    bname <- readIORef $ bufName b
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
                    glTexSubImage1D GL_TEXTURE_1D (fromIntegral l) (fromIntegral x) (fromIntegral w) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
    where mx = texture1DSizes t !! l
writeTexture1DArrayFromBuffer t@(Texture1DArray texn _ ml) l (V2 x y) (V2 w h) b i
    | l < 0 || l >= ml = error "writeTexture1DArrayFromBuffer, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture1DArrayFromBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture1DArrayFromBuffer, w out of bounds"
    | y < 0 || y >= my = error "writeTexture1DArrayFromBuffer, y out of bounds"
    | h < 0 || y+h > my = error "writeTexture1DArrayFromBuffer, h out of bounds"
    | i < 0 || i > bufferLength b = error "writeTexture1DArrayFromBuffer, i out of bounds"
    | bufferLength b - i < w*h = error "writeTexture1DArrayFromBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                    useTexSync texn GL_TEXTURE_1D_ARRAY
                    bname <- readIORef $ bufName b
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
                    glTexSubImage2D GL_TEXTURE_1D_ARRAY (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
    where V2 mx my = texture1DArraySizes t !! l
writeTexture2DFromBuffer t@(Texture2D texn _ ml) l (V2 x y) (V2 w h) b i
    | l < 0 || l >= ml = error "writeTexture2DFromBuffer, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture2DFromBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture2DFromBuffer, w out of bounds"
    | y < 0 || y >= my = error "writeTexture2DFromBuffer, y out of bounds"
    | h < 0 || y+h > my = error "writeTexture2DFromBuffer, h out of bounds"
    | i < 0 || i > bufferLength b = error "writeTexture2DFromBuffer, i out of bounds"
    | bufferLength b - i < w*h = error "writeTexture2DFromBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                    useTexSync texn GL_TEXTURE_2D
                    bname <- readIORef $ bufName b
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
                    glTexSubImage2D GL_TEXTURE_2D (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
    where V2 mx my = texture2DSizes t !! l
writeTexture2DArrayFromBuffer t@(Texture2DArray texn _ ml) l (V3 x y z) (V3 w h d) b i
    | l < 0 || l >= ml = error "writeTexture2DArrayFromBuffer, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture2DArrayFromBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture2DArrayFromBuffer, w out of bounds"
    | y < 0 || y >= my = error "writeTexture2DArrayFromBuffer, y out of bounds"
    | h < 0 || y+h > my = error "writeTexture2DArrayFromBuffer, h out of bounds"
    | z < 0 || z >= mz = error "writeTexture2DArrayFromBuffer, z out of bounds"
    | d < 0 || z+d > mz = error "writeTexture2DArrayFromBuffer, d out of bounds"
    | i < 0 || i > bufferLength b = error "writeTexture2DArrayFromBuffer, i out of bounds"
    | bufferLength b - i < w*h = error "writeTexture2DArrayFromBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                    useTexSync texn GL_TEXTURE_2D_ARRAY
                    bname <- readIORef $ bufName b
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
                    glTexSubImage3D GL_TEXTURE_2D_ARRAY (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
    where V3 mx my mz = texture2DArraySizes t !! l
writeTexture3DFromBuffer t@(Texture3D texn _ ml) l (V3 x y z) (V3 w h d) b i
    | l < 0 || l >= ml = error "writeTexture3DFromBuffer, level out of bounds"
    | x < 0 || x >= mx = error "writeTexture3DFromBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "writeTexture3DFromBuffer, w out of bounds"
    | y < 0 || y >= my = error "writeTexture3DFromBuffer, y out of bounds"
    | h < 0 || y+h > my = error "writeTexture3DFromBuffer, h out of bounds"
    | z < 0 || z >= mz = error "writeTexture3DFromBuffer, z out of bounds"
    | d < 0 || z+d > mz = error "writeTexture3DFromBuffer, d out of bounds"
    | i < 0 || i > bufferLength b = error "writeTexture3DFromBuffer, i out of bounds"
    | bufferLength b - i < w*h = error "writeTexture3DFromBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                    useTexSync texn GL_TEXTURE_3D
                    bname <- readIORef $ bufName b
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
                    glTexSubImage3D GL_TEXTURE_3D (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
    where V3 mx my mz = texture3DSizes t !! l
writeTextureCubeFromBuffer t@(TextureCube texn _ ml) l s (V2 x y) (V2 w h) b i
    | l < 0 || l >= ml = error "writeTextureCubeFromBuffer, level out of bounds"
    | x < 0 || x >= mxy = error "writeTextureCubeFromBuffer, x out of bounds"
    | w < 0 || x+w > mxy = error "writeTextureCubeFromBuffer, w out of bounds"
    | y < 0 || y >= mxy = error "writeTextureCubeFromBuffer, y out of bounds"
    | h < 0 || y+h > mxy = error "writeTextureCubeFromBuffer, h out of bounds"
    | i < 0 || i > bufferLength b = error "writeTextureCubeFromBuffer, i out of bounds"
    | bufferLength b - i < w*h = error "writeTextureCubeFromBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                    useTexSync texn GL_TEXTURE_CUBE_MAP
                    bname <- readIORef $ bufName b
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
                    glTexSubImage2D (getGlCubeSide s) (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
    where mxy = textureCubeSizes t !! l


readTexture1D t@(Texture1D texn _ ml) l x w f s
    | l < 0 || l >= ml = error "readTexture1DArray, level out of bounds"
    | x < 0 || x >= mx = error "readTexture1DArray, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture1DArray, w out of bounds"
    | otherwise =
                 let b = makeBuffer undefined undefined 0 :: Buffer os b
                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
                 in bracket
                   (liftNonWinContextIO $ do
                     ptr <- mallocBytes $ w*bufElementSize b
                     setGlPixelStoreRange x 0 0 w 1
                     useTexSync texn GL_TEXTURE_1D_ARRAY
                     glGetTexImage GL_TEXTURE_1D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
                     return ptr)
                   (liftIO . free)
                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*bufElementSize b -1])
    where mx = texture1DSizes t !! l
readTexture1DArray t@(Texture1DArray texn _ ml) l (V2 x y) w f s
    | l < 0 || l >= ml = error "readTexture1DArray, level out of bounds"
    | x < 0 || x >= mx = error "readTexture1DArray, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture1DArray, w out of bounds"
    | y < 0 || y >= my = error "readTexture1DArray, y out of bounds"
    | otherwise =
                 let b = makeBuffer undefined undefined 0 :: Buffer os b
                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
                 in bracket
                   (liftNonWinContextIO $ do
                     ptr <- mallocBytes $ w*bufElementSize b
                     setGlPixelStoreRange x y 0 w 1
                     useTexSync texn GL_TEXTURE_1D_ARRAY
                     glGetTexImage GL_TEXTURE_1D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
                     return ptr)
                   (liftIO . free)
                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*bufElementSize b -1])
    where V2 mx my = texture1DArraySizes t !! l
readTexture2D t@(Texture2D texn _ ml) l (V2 x y) (V2 w h) f s
    | l < 0 || l >= ml = error "readTexture2D, level out of bounds"
    | x < 0 || x >= mx = error "readTexture2D, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture2D, w out of bounds"
    | y < 0 || y >= my = error "readTexture2D, y out of bounds"
    | h < 0 || y+h > my = error "readTexture2D, h out of bounds"
    | otherwise =
                 let b = makeBuffer undefined undefined 0 :: Buffer os b
                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
                 in bracket
                   (liftNonWinContextIO $ do
                     ptr <- mallocBytes $ w*h*bufElementSize b
                     setGlPixelStoreRange x y 0 w h
                     useTexSync texn GL_TEXTURE_2D
                     glGetTexImage GL_TEXTURE_2D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
                     return ptr)
                   (liftIO . free)
                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*h*bufElementSize b -1])
    where V2 mx my = texture2DSizes t !! l
readTexture2DArray t@(Texture2DArray texn _ ml) l (V3 x y z) (V2 w h) f s
    | l < 0 || l >= ml = error "readTexture2DArray, level out of bounds"
    | x < 0 || x >= mx = error "readTexture2DArray, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture2DArray, w out of bounds"
    | y < 0 || y >= my = error "readTexture2DArray, y out of bounds"
    | h < 0 || y+h > my = error "readTexture2DArray, h out of bounds"
    | z < 0 || z >= mz = error "readTexture2DArray, y out of bounds"
    | otherwise =
                 let b = makeBuffer undefined undefined 0 :: Buffer os b
                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
                 in bracket
                   (liftNonWinContextIO $ do
                     ptr <- mallocBytes $ w*h*bufElementSize b
                     setGlPixelStoreRange x y z w h
                     useTexSync texn GL_TEXTURE_2D_ARRAY
                     glGetTexImage GL_TEXTURE_2D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
                     return ptr)
                   (liftIO . free)
                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*h*bufElementSize b -1])
    where V3 mx my mz = texture2DArraySizes t !! l
readTexture3D t@(Texture3D texn _ ml) l (V3 x y z) (V2 w h) f s
    | l < 0 || l >= ml = error "readTexture3D, level out of bounds"
    | x < 0 || x >= mx = error "readTexture3D, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture3D, w out of bounds"
    | y < 0 || y >= my = error "readTexture3D, y out of bounds"
    | h < 0 || y+h > my = error "readTexture3D, h out of bounds"
    | z < 0 || z >= mz = error "readTexture3D, y out of bounds"
    | otherwise =
                 let b = makeBuffer undefined undefined 0 :: Buffer os b
                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
                 in bracket
                   (liftNonWinContextIO $ do
                     ptr <- mallocBytes $ w*h*bufElementSize b
                     setGlPixelStoreRange x y z w h
                     useTexSync texn GL_TEXTURE_3D
                     glGetTexImage GL_TEXTURE_3D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
                     return ptr)
                   (liftIO . free)
                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*h*bufElementSize b -1])
    where V3 mx my mz = texture3DSizes t !! l
readTextureCube t@(TextureCube texn _ ml) l si (V2 x y) (V2 w h) f s
    | l < 0 || l >= ml = error "readTextureCube, level out of bounds"
    | x < 0 || x >= mxy = error "readTextureCube, x out of bounds"
    | w < 0 || x+w > mxy = error "readTextureCube, w out of bounds"
    | y < 0 || y >= mxy = error "readTextureCube, y out of bounds"
    | h < 0 || y+h > mxy = error "readTextureCube, h out of bounds"
    | otherwise =
                 let b = makeBuffer undefined undefined 0 :: Buffer os b
                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
                 in bracket
                   (liftNonWinContextIO $ do
                     ptr <- mallocBytes $ w*h*bufElementSize b
                     setGlPixelStoreRange x y 0 w h
                     useTexSync texn GL_TEXTURE_CUBE_MAP
                     glGetTexImage (getGlCubeSide si) (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
                     return ptr)
                   (liftIO . free)
                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*h*bufElementSize b -1])
    where mxy = textureCubeSizes t !! l

readTexture1DToBuffer t@(Texture1D texn _ ml) l x w b i
    | l < 0 || l >= ml = error "readTexture1DToBuffer, level out of bounds"
    | x < 0 || x >= mx = error "readTexture1DToBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture1DToBuffer, w out of bounds"
    | i < 0 || i > bufferLength b = error "readTexture1DToBuffer, i out of bounds"
    | bufferLength b - i < w = error "readTexture1DToBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                     bname <- readIORef $ bufName b
                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
                     setGlPixelStoreRange x 0 0 w 1
                     useTexSync texn GL_TEXTURE_1D
                     glGetTexImage GL_TEXTURE_1D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
    where mx = texture1DSizes t !! l
readTexture1DArrayToBuffer t@(Texture1DArray texn _ ml) l (V2 x y) w b i
    | l < 0 || l >= ml = error "readTexture1DArrayToBuffer, level out of bounds"
    | x < 0 || x >= mx = error "readTexture1DArrayToBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture1DArrayToBuffer, w out of bounds"
    | y < 0 || y >= my = error "readTexture1DArrayToBuffer, y out of bounds"
    | i < 0 || i > bufferLength b = error "readTexture1DArrayToBuffer, i out of bounds"
    | bufferLength b - i < w = error "readTexture1DArrayToBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                     bname <- readIORef $ bufName b
                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
                     setGlPixelStoreRange x y 0 w 1
                     useTexSync texn GL_TEXTURE_1D_ARRAY
                     glGetTexImage GL_TEXTURE_1D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
    where V2 mx my = texture1DArraySizes t !! l
readTexture2DToBuffer t@(Texture2D texn _ ml) l (V2 x y) (V2 w h) b i
    | l < 0 || l >= ml = error "readTexture2DToBuffer, level out of bounds"
    | x < 0 || x >= mx = error "readTexture2DToBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture2DToBuffer, w out of bounds"
    | y < 0 || y >= my = error "readTexture2DToBuffer, y out of bounds"
    | h < 0 || y+h > my = error "readTexture2DToBuffer, h out of bounds"
    | i < 0 || i > bufferLength b = error "readTexture2DToBuffer, i out of bounds"
    | bufferLength b - i < w*h = error "readTexture2DToBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                     bname <- readIORef $ bufName b
                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
                     setGlPixelStoreRange x y 0 w h
                     useTexSync texn GL_TEXTURE_2D
                     glGetTexImage GL_TEXTURE_2D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
    where V2 mx my = texture2DSizes t !! l
readTexture2DArrayToBuffer t@(Texture2DArray texn _ ml) l (V3 x y z) (V2 w h) b i
    | l < 0 || l >= ml = error "readTexture2DArrayToBuffer, level out of bounds"
    | x < 0 || x >= mx = error "readTexture2DArrayToBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture2DArrayToBuffer, w out of bounds"
    | y < 0 || y >= my = error "readTexture2DArrayToBuffer, y out of bounds"
    | h < 0 || y+h > my = error "readTexture2DArrayToBuffer, h out of bounds"
    | z < 0 || z >= mz = error "readTexture2DArrayToBuffer, z out of bounds"
    | i < 0 || i > bufferLength b = error "readTexture2DArrayToBuffer, i out of bounds"
    | bufferLength b - i < w*h = error "readTexture2DArrayToBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                     bname <- readIORef $ bufName b
                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
                     setGlPixelStoreRange x y z w h
                     useTexSync texn GL_TEXTURE_2D_ARRAY
                     glGetTexImage GL_TEXTURE_2D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
    where V3 mx my mz = texture2DArraySizes t !! l
readTexture3DToBuffer t@(Texture3D texn _ ml) l (V3 x y z) (V2 w h) b i
    | l < 0 || l >= ml = error "readTexture3DToBuffer, level out of bounds"
    | x < 0 || x >= mx = error "readTexture3DToBuffer, x out of bounds"
    | w < 0 || x+w > mx = error "readTexture3DToBuffer, w out of bounds"
    | y < 0 || y >= my = error "readTexture3DToBuffer, y out of bounds"
    | h < 0 || y+h > my = error "readTexture3DToBuffer, h out of bounds"
    | z < 0 || z >= mz = error "readTexture3DToBuffer, z out of bounds"
    | i < 0 || i > bufferLength b = error "readTexture3DToBuffer, i out of bounds"
    | bufferLength b - i < w*h = error "readTexture3DToBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                     bname <- readIORef $ bufName b
                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
                     setGlPixelStoreRange x y z w h
                     useTexSync texn GL_TEXTURE_3D
                     glGetTexImage GL_TEXTURE_3D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
    where V3 mx my mz = texture3DSizes t !! l
readTextureCubeToBuffer t@(TextureCube texn _ ml) l s (V2 x y) (V2 w h) b i
    | l < 0 || l >= ml = error "readTextureCubeToBuffer, level out of bounds"
    | x < 0 || x >= mxy = error "readTextureCubeToBuffer, x out of bounds"
    | w < 0 || x+w > mxy = error "readTextureCubeToBuffer, w out of bounds"
    | y < 0 || y >= mxy = error "readTextureCubeToBuffer, y out of bounds"
    | h < 0 || y+h > mxy = error "readTextureCubeToBuffer, h out of bounds"
    | i < 0 || i > bufferLength b = error "readTextureCubeToBuffer, i out of bounds"
    | bufferLength b - i < w*h = error "readTextureCubeToBuffer, buffer data too small"
    | otherwise = liftNonWinContextAsyncIO $ do
                     setGlPixelStoreRange x y 0 w h
                     bname <- readIORef $ bufName b
                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
                     useTexSync texn GL_TEXTURE_CUBE_MAP
                     glGetTexImage (getGlCubeSide s) (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
    where mxy = textureCubeSizes t !! l

setGlPixelStoreRange :: Int -> Int -> Int -> Int -> Int -> IO ()
setGlPixelStoreRange x y z w h = do
        glPixelStorei GL_PACK_SKIP_PIXELS $ fromIntegral x
        glPixelStorei GL_PACK_SKIP_ROWS $ fromIntegral y
        glPixelStorei GL_PACK_SKIP_IMAGES $ fromIntegral z
        glPixelStorei GL_PACK_ROW_LENGTH $ fromIntegral w
        glPixelStorei GL_PACK_IMAGE_HEIGHT $ fromIntegral h


generateTexture1DMipmap :: (ContextHandler ctx, MonadIO m) => Texture1D os f -> ContextT ctx os m ()
generateTexture1DArrayMipmap :: (ContextHandler ctx, MonadIO m) => Texture1DArray os f -> ContextT ctx os m ()
generateTexture2DMipmap :: (ContextHandler ctx, MonadIO m) => Texture2D os f -> ContextT ctx os m ()
generateTexture2DArrayMipmap :: (ContextHandler ctx, MonadIO m) => Texture2DArray os f -> ContextT ctx os m ()
generateTexture3DMipmap :: (ContextHandler ctx, MonadIO m) => Texture3D os f -> ContextT ctx os m ()
generateTextureCubeMipmap :: (ContextHandler ctx, MonadIO m) => TextureCube os f -> ContextT ctx os m ()

genMips texn target = liftNonWinContextAsyncIO $ do
                     useTexSync texn target
                     glGenerateMipmap target

generateTexture1DMipmap (Texture1D texn _ _) = genMips texn GL_TEXTURE_1D
generateTexture1DArrayMipmap (Texture1DArray texn _ _) = genMips texn GL_TEXTURE_1D_ARRAY
generateTexture2DMipmap (Texture2D texn _ _) = genMips texn GL_TEXTURE_2D
generateTexture2DMipmap _ = return () -- Only one level for renderbuffers
generateTexture2DArrayMipmap (Texture2DArray texn _ _) = genMips texn GL_TEXTURE_2D_ARRAY
generateTexture3DMipmap (Texture3D texn _ _) = genMips texn GL_TEXTURE_3D
generateTextureCubeMipmap (TextureCube texn _ _) = genMips texn GL_TEXTURE_CUBE_MAP

----------------------------------------------------------------------
-- Samplers

data Filter = Nearest | Linear  deriving (Eq, Enum)
data EdgeMode = Repeat | Mirror | ClampToEdge | ClampToBorder deriving (Eq, Enum)
type BorderColor c = Color c (ColorElement c)
type Anisotropy = Maybe Float

type MinFilter = Filter
type MagFilter = Filter
type LodFilter = Filter

-- | A GADT for sample filters, where 'SamplerFilter' cannot be used for integer textures.
data SamplerFilter c where
    SamplerFilter :: (ColorElement c ~ Float) => MagFilter -> MinFilter -> LodFilter -> Anisotropy -> SamplerFilter c
    SamplerNearest :: SamplerFilter c

type EdgeMode2 = V2 EdgeMode
type EdgeMode3 = V3 EdgeMode

data ComparisonFunction =
     Never
   | Less
   | Equal
   | Lequal
   | Greater
   | Notequal
   | Gequal
   | Always
   deriving ( Eq, Ord, Show )

getGlCompFunc :: (Num a, Eq a) => ComparisonFunction -> a
getGlCompFunc Never = GL_NEVER
getGlCompFunc Less = GL_LESS
getGlCompFunc Equal = GL_EQUAL
getGlCompFunc Lequal = GL_LEQUAL
getGlCompFunc Greater = GL_GREATER
getGlCompFunc Notequal = GL_NOTEQUAL
getGlCompFunc Gequal = GL_GEQUAL
getGlCompFunc Always = GL_ALWAYS

newSampler1D :: forall os s c. ColorSampleable c => (s -> (Texture1D os (Format c), SamplerFilter c, (EdgeMode,  BorderColor c))) -> Shader os s (Sampler1D (Format c))
newSampler1DArray :: forall os s c. ColorSampleable c => (s -> (Texture1DArray os (Format c), SamplerFilter c, (EdgeMode, BorderColor c))) -> Shader os s (Sampler1DArray (Format c))
newSampler2D :: forall os s c. ColorSampleable c => (s -> (Texture2D os (Format c), SamplerFilter c, (EdgeMode2, BorderColor c))) -> Shader os s (Sampler2D (Format c))
newSampler2DArray :: forall os s c. ColorSampleable c => (s -> (Texture2DArray os (Format c), SamplerFilter c, (EdgeMode2, BorderColor c))) -> Shader os s (Sampler2DArray (Format c))
newSampler3D :: forall os s c. ColorRenderable c => (s -> (Texture3D os (Format c), SamplerFilter c, (EdgeMode3, BorderColor c))) -> Shader os s (Sampler3D (Format c))
newSamplerCube :: forall os s c. ColorSampleable c => (s -> (TextureCube os (Format c), SamplerFilter c)) -> Shader os s (SamplerCube (Format c))

newSampler1DShadow :: forall os s d. DepthRenderable d => (s -> (Texture1D os (Format d), SamplerFilter d, (EdgeMode, BorderColor d), ComparisonFunction)) -> Shader os s (Sampler1D Shadow)
newSampler1DArrayShadow :: forall os s d. DepthRenderable d => (s -> (Texture1DArray os (Format d), SamplerFilter d, (EdgeMode, BorderColor d), ComparisonFunction)) -> Shader os s (Sampler1DArray Shadow)
newSampler2DShadow :: forall os s d. DepthRenderable d => (s -> (Texture2D os d, SamplerFilter (Format d), (EdgeMode2, BorderColor d), ComparisonFunction)) -> Shader os s (Sampler2D Shadow)
newSampler2DArrayShadow :: forall os s d. DepthRenderable d => (s -> (Texture2DArray os (Format d), SamplerFilter d, (EdgeMode2, BorderColor d), ComparisonFunction)) -> Shader os s (Sampler2DArray Shadow)
newSamplerCubeShadow :: forall os s d. DepthRenderable d => (s -> (TextureCube os (Format d), SamplerFilter d, ComparisonFunction)) -> Shader os s (SamplerCube Shadow)

newSampler1D sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (Texture1D tn _ _, filt, (ex, ec)) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_1D bind
                                                           setNoShadowMode GL_TEXTURE_1D
                                                           setSamplerFilter GL_TEXTURE_1D filt
                                                           setEdgeMode GL_TEXTURE_1D (Just ex, Nothing, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_1D ec)
                                                           return n
                   return $ Sampler1D sampId False (samplerPrefix (undefined :: c))
newSampler1DArray sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (Texture1DArray tn _ _, filt, (ex, ec)) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_1D_ARRAY bind
                                                           setNoShadowMode GL_TEXTURE_1D_ARRAY
                                                           setSamplerFilter GL_TEXTURE_1D_ARRAY filt
                                                           setEdgeMode GL_TEXTURE_1D_ARRAY (Just ex, Nothing, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_1D_ARRAY ec)
                                                           return n
                   return $ Sampler1DArray sampId False (samplerPrefix (undefined :: c))
newSampler2D sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (Texture2D tn _ _, filt, (V2 ex ey, ec)) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_2D bind
                                                           setNoShadowMode GL_TEXTURE_2D
                                                           setSamplerFilter GL_TEXTURE_2D filt
                                                           setEdgeMode GL_TEXTURE_2D (Just ex, Just ey, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_2D ec)
                                                           return n
                   return $ Sampler2D sampId False (samplerPrefix (undefined :: c))
newSampler2DArray sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (Texture2DArray tn _ _, filt, (V2 ex ey, ec)) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_2D_ARRAY bind
                                                           setNoShadowMode GL_TEXTURE_2D_ARRAY
                                                           setSamplerFilter GL_TEXTURE_2D_ARRAY filt
                                                           setEdgeMode GL_TEXTURE_2D_ARRAY (Just ex, Just ey, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_2D_ARRAY ec)
                                                           return n
                   return $ Sampler2DArray sampId False (samplerPrefix (undefined :: c))
newSampler3D sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (Texture3D tn _ _, filt, (V3 ex ey ez, ec)) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_3D bind
                                                           setNoShadowMode GL_TEXTURE_3D
                                                           setSamplerFilter GL_TEXTURE_3D filt
                                                           setEdgeMode GL_TEXTURE_3D (Just ex, Just ey, Just ez) (setBorderColor (undefined :: c) GL_TEXTURE_3D ec)
                                                           return n
                   return $ Sampler3D sampId False (samplerPrefix (undefined :: c))
newSamplerCube sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (TextureCube tn _ _, filt) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_CUBE_MAP bind
                                                           setNoShadowMode GL_TEXTURE_CUBE_MAP
                                                           setSamplerFilter GL_TEXTURE_CUBE_MAP filt
                                                           return n
                   return $ SamplerCube sampId False (samplerPrefix (undefined :: c))


newSampler1DShadow sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (Texture1D tn _ _, filt, (ex, ec), cf) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_1D bind
                                                           setShadowFunc GL_TEXTURE_1D cf
                                                           setSamplerFilter GL_TEXTURE_1D filt
                                                           setEdgeMode GL_TEXTURE_1D (Just ex, Nothing, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_1D ec)
                                                           return n
                   return $ Sampler1D sampId True ""
newSampler1DArrayShadow sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (Texture1DArray tn _ _, filt, (ex, ec), cf) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_1D_ARRAY bind
                                                           setShadowFunc GL_TEXTURE_1D_ARRAY cf
                                                           setSamplerFilter GL_TEXTURE_1D_ARRAY filt
                                                           setEdgeMode GL_TEXTURE_1D_ARRAY (Just ex, Nothing, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_1D_ARRAY ec)
                                                           return n
                   return $ Sampler1DArray sampId True ""
newSampler2DShadow sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (Texture2D tn _ _, filt, (V2 ex ey, ec), cf) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_2D bind
                                                           setShadowFunc GL_TEXTURE_2D cf
                                                           setSamplerFilter GL_TEXTURE_2D filt
                                                           setEdgeMode GL_TEXTURE_2D (Just ex, Just ey, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_2D ec)
                                                           return n
                   return $ Sampler2D sampId True ""
newSampler2DArrayShadow sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (Texture2DArray tn _ _, filt, (V2 ex ey, ec), cf) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_2D_ARRAY bind
                                                           setShadowFunc GL_TEXTURE_2D_ARRAY cf
                                                           setSamplerFilter GL_TEXTURE_2D_ARRAY filt
                                                           setEdgeMode GL_TEXTURE_2D_ARRAY (Just ex, Just ey, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_2D_ARRAY ec)
                                                           return n
                   return $ Sampler2DArray sampId True ""
newSamplerCubeShadow sf = Shader $ do
                   sampId <- getName
                   doForSampler sampId $ \s bind -> let (TextureCube tn _ _, filt, cf) = sf s
                                                    in  do n <- useTex tn GL_TEXTURE_CUBE_MAP bind
                                                           setShadowFunc GL_TEXTURE_CUBE_MAP cf
                                                           setSamplerFilter GL_TEXTURE_CUBE_MAP filt
                                                           return n
                   return $ SamplerCube sampId True ""

setNoShadowMode :: GLenum -> IO ()
setNoShadowMode t = glTexParameteri t GL_TEXTURE_COMPARE_MODE GL_NONE

setShadowFunc :: GLenum -> ComparisonFunction -> IO ()
setShadowFunc t cf = do
    glTexParameteri t GL_TEXTURE_COMPARE_MODE GL_COMPARE_REF_TO_TEXTURE
    glTexParameteri t GL_TEXTURE_COMPARE_FUNC (getGlCompFunc cf)

setEdgeMode :: GLenum -> (Maybe EdgeMode, Maybe EdgeMode, Maybe EdgeMode) -> IO () -> IO ()
setEdgeMode t (se,te,re) bcio = do glwrap GL_TEXTURE_WRAP_S se
                                   glwrap GL_TEXTURE_WRAP_T te
                                   glwrap GL_TEXTURE_WRAP_R re
                                   when (se == Just ClampToBorder || te == Just ClampToBorder || re == Just ClampToBorder)
                                      bcio
    where glwrap _ Nothing = return ()
          glwrap x (Just Repeat) = glTexParameteri t x GL_REPEAT
          glwrap x (Just Mirror) = glTexParameteri t x GL_MIRRORED_REPEAT
          glwrap x (Just ClampToEdge) = glTexParameteri t x GL_CLAMP_TO_EDGE
          glwrap x (Just ClampToBorder) = glTexParameteri t x GL_CLAMP_TO_BORDER

setSamplerFilter :: GLenum -> SamplerFilter a -> IO ()
setSamplerFilter t (SamplerFilter magf minf lodf a) = setSamplerFilter' t magf minf lodf a
setSamplerFilter t SamplerNearest = setSamplerFilter' t Nearest Nearest Nearest Nothing

setSamplerFilter' :: GLenum -> MagFilter -> MinFilter -> LodFilter -> Anisotropy -> IO ()
setSamplerFilter' t magf minf lodf a = do
                                           glTexParameteri t GL_TEXTURE_MIN_FILTER glmin
                                           glTexParameteri t GL_TEXTURE_MAG_FILTER glmag
                                           case a of
                                                Nothing -> return ()
                                                Just a' -> glTexParameterf t GL_TEXTURE_MAX_ANISOTROPY_EXT (realToFrac a')
    where glmin = case (minf, lodf) of
                    (Nearest, Nearest) -> GL_NEAREST_MIPMAP_NEAREST
                    (Linear, Nearest) -> GL_LINEAR_MIPMAP_NEAREST
                    (Nearest, Linear) -> GL_NEAREST_MIPMAP_LINEAR
                    (Linear, Linear) -> GL_LINEAR_MIPMAP_LINEAR
          glmag = case magf of
                    Nearest -> GL_NEAREST
                    Linear -> GL_LINEAR




doForSampler :: Int -> (s -> Binding -> IO Int) -> ShaderM s ()
doForSampler n io = modifyRenderIO (\s -> s { samplerNameToRenderIO = insert n io (samplerNameToRenderIO s) } )

-- | Used instead of 'Format' for shadow samplers. These samplers have specialized sampler values, see 'sample1DShadow' and friends.
data Shadow
data Sampler1D f = Sampler1D Int Bool String
data Sampler1DArray f = Sampler1DArray Int Bool String
data Sampler2D f = Sampler2D Int Bool String
data Sampler2DArray f = Sampler2DArray Int Bool String
data Sampler3D f = Sampler3D Int Bool String
data SamplerCube f = SamplerCube Int Bool String

-- | A GADT to specify where the level of detail and/or partial derivates should be taken from. Some values of this GADT are restricted to
--   only 'FragmentStream's.
data SampleLod vx x where
    SampleAuto :: SampleLod v F
    SampleBias :: FFloat -> SampleLod vx F
    SampleLod :: S x Float -> SampleLod vx x
    SampleGrad :: vx -> vx -> SampleLod vx x

-- | For some reason, OpenGl doesnt allow explicit lod to be specified for some sampler types, hence this extra GADT.
data SampleLod' vx x where
    SampleAuto' :: SampleLod' v F
    SampleBias' :: FFloat -> SampleLod' vx F
    SampleGrad' :: vx -> vx -> SampleLod' vx x

type SampleLod1 x = SampleLod (S x Float) x
type SampleLod2 x = SampleLod (V2 (S x Float)) x
type SampleLod3 x = SampleLod (V3 (S x Float)) x
type SampleLod2' x = SampleLod' (V2 (S x Float)) x
type SampleLod3' x = SampleLod' (V3 (S x Float)) x

fromLod' :: SampleLod' v x -> SampleLod v x
fromLod' SampleAuto' = SampleAuto
fromLod' (SampleBias' x) = SampleBias x
fromLod' (SampleGrad' x y) = SampleGrad x y

type SampleProj x = Maybe (S x Float)
type SampleOffset1 x = Maybe Int
type SampleOffset2 x = Maybe (V2 Int)
type SampleOffset3 x = Maybe (V3 Int)

-- | The type of a color sample made by a texture t
type ColorSample x f = Color f (S x (ColorElement f))
type ReferenceValue x = S x Float

sample1D            :: forall c x. ColorSampleable c =>  Sampler1D (Format c)          -> SampleLod1 x -> SampleProj x -> SampleOffset1 x -> S x Float -> ColorSample x c
sample1DArray       :: forall c x. ColorSampleable c =>  Sampler1DArray (Format c)     -> SampleLod1 x -> SampleOffset1 x -> V2 (S x Float) -> ColorSample x c
sample2D            :: forall c x. ColorSampleable c =>  Sampler2D (Format c)          -> SampleLod2 x -> SampleProj x -> SampleOffset2 x -> V2 (S x Float) -> ColorSample x c
sample2DArray       :: forall c x. ColorSampleable c =>  Sampler2DArray (Format c)     -> SampleLod2 x -> SampleOffset2 x -> V3 (S x Float) -> ColorSample x c
sample3D            :: forall c x. ColorSampleable c =>  Sampler3D (Format c)          -> SampleLod3 x -> SampleProj x -> SampleOffset3 x -> V3 (S x Float) -> ColorSample x c
sampleCube          :: forall c x. ColorSampleable c =>  SamplerCube (Format c)        -> SampleLod3 x -> V3 (S x Float) -> ColorSample x c

sample1DShadow      :: forall x. Sampler1D Shadow     -> SampleLod1 x -> SampleProj x -> SampleOffset1 x -> ReferenceValue x -> S x Float -> S x Float
sample1DArrayShadow :: forall x. Sampler1DArray Shadow-> SampleLod1 x -> SampleOffset1 x -> ReferenceValue x -> V2 (S x Float) -> S x Float
sample2DShadow      :: forall x. Sampler2D Shadow     -> SampleLod2 x -> SampleProj x -> SampleOffset2 x -> ReferenceValue x -> V2 (S x Float) -> S x Float
sample2DArrayShadow :: forall x. Sampler2DArray Shadow-> SampleLod2' x -> SampleOffset2 x -> ReferenceValue x -> V3 (S x Float)-> S x Float
sampleCubeShadow    :: forall x. SamplerCube Shadow   -> SampleLod3' x -> ReferenceValue x -> V3 (S x Float) -> S x Float

sample1D (Sampler1D sampId _ prefix) lod proj off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "1D" sampId lod proj off coord v1toF v1toF civ1toF pv1toF
sample1DArray (Sampler1DArray sampId _ prefix) lod off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "1DArray" sampId lod Nothing off coord v2toF v1toF civ1toF undefined
sample2D (Sampler2D sampId _ prefix) lod proj off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "2D" sampId lod proj off coord v2toF v2toF civ2toF pv2toF
sample2DArray (Sampler2DArray sampId _ prefix) lod off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "2DArray" sampId lod Nothing off coord v3toF v2toF civ2toF undefined
sample3D (Sampler3D sampId _ prefix) lod proj off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "3D" sampId lod proj off coord v3toF v3toF civ3toF pv3toF
sampleCube (SamplerCube sampId _ prefix) lod coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "Cube" sampId lod Nothing Nothing coord v3toF v3toF undefined undefined

sample1DShadow (Sampler1D sampId _ _) lod proj off ref coord = sampleShadow "1D" sampId lod proj off (t1t3 coord ref) v3toF v1toF civ1toF pv3toF
sample1DArrayShadow (Sampler1DArray sampId _ _) lod off ref coord = sampleShadow "1DArray" sampId lod Nothing off (t2t3 coord ref) v3toF v1toF civ1toF undefined
sample2DShadow (Sampler2D sampId _ _) lod proj off ref coord = sampleShadow "2D" sampId lod proj off (t2t3 coord ref) v3toF v2toF civ2toF pv3toF
sample2DArrayShadow (Sampler2DArray sampId _ _) lod off ref coord = sampleShadow "2DArray" sampId (fromLod' lod) Nothing off (t3t4 coord ref) v4toF v2toF civ2toF undefined
sampleCubeShadow (SamplerCube sampId _ _) lod ref coord = sampleShadow "Cube" sampId (fromLod' lod) Nothing Nothing (t3t4 coord ref) v4toF v3toF undefined undefined

t1t3 :: S x Float -> S x Float -> V3 (S x Float)
t2t3 :: V2 t -> t -> V3 t
t3t4 :: V3 t -> t -> V4 t
t1t3 x = V3 x 0
t2t3 (V2 x y) = V3 x y
t3t4 (V3 x y z) = V4 x y z

texelFetch1D        :: forall c x. ColorSampleable c =>  Sampler1D (Format c)          -> SampleOffset1 x -> S x Level -> S x Int -> ColorSample x c
texelFetch1DArray   :: forall c x. ColorSampleable c =>  Sampler1DArray (Format c)     -> SampleOffset1 x -> S x Level -> V2(S x Int) -> ColorSample x c
texelFetch2D        :: forall c x. ColorSampleable c =>  Sampler2D (Format c)          -> SampleOffset2 x -> S x Level -> V2 (S x Int) -> ColorSample x c
texelFetch2DArray   :: forall c x. ColorSampleable c =>  Sampler2DArray (Format c)     -> SampleOffset2 x -> S x Level -> V3 (S x Int) -> ColorSample x c
texelFetch3D        :: forall c x. ColorSampleable c =>  Sampler3D (Format c)          -> SampleOffset3 x -> S x Level -> V3 (S x Int) -> ColorSample x c

texelFetch1D (Sampler1D sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "1D" sampId lod off coord iv1toF civ1toF
texelFetch1DArray (Sampler1DArray sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "1DArray" sampId lod off coord iv2toF civ1toF
texelFetch2D (Sampler2D sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "2D" sampId lod off coord iv2toF civ2toF
texelFetch2DArray (Sampler2DArray sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "2DArray" sampId lod off coord iv3toF civ2toF
texelFetch3D (Sampler3D sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "3D" sampId lod off coord iv3toF civ3toF

sampler1DSize      :: Sampler1D f -> S x Level -> S x Int
sampler1DArraySize :: Sampler1DArray f -> S x Level -> V2 (S x Int)
sampler2DSize      :: Sampler2D f -> S x Level -> V2 (S x Int)
sampler2DArraySize :: Sampler2DArray f -> S x Level -> V3 (S x Int)
sampler3DSize      :: Sampler3D f -> S x Level -> V3 (S x Int)
samplerCubeSize    :: SamplerCube f -> S x Level -> S x Int

sampler1DSize (Sampler1D sampId shadow prefix) = scalarS STypeInt . getTextureSize prefix sampId (addShadowPrefix shadow "1D")
sampler1DArraySize (Sampler1DArray sampId shadow prefix) = vec2S (STypeIVec 2) . getTextureSize prefix sampId (addShadowPrefix shadow "1DArray")
sampler2DSize (Sampler2D sampId shadow prefix) = vec2S (STypeIVec 2) . getTextureSize prefix sampId (addShadowPrefix shadow "2D")
sampler2DArraySize (Sampler2DArray sampId shadow prefix) = vec3S (STypeIVec 3) . getTextureSize prefix sampId (addShadowPrefix shadow "2DArray")
sampler3DSize (Sampler3D sampId shadow prefix) = vec3S (STypeIVec 3) . getTextureSize prefix sampId (addShadowPrefix shadow "3D")
samplerCubeSize (SamplerCube sampId shadow prefix) = (\(V2 x _) -> x) . vec2S (STypeIVec 2) . getTextureSize prefix sampId (addShadowPrefix shadow "Cube")

addShadowPrefix :: Bool -> String -> String
addShadowPrefix shadow = if shadow then (++ "Shadow") else id

getTextureSize :: String -> Int -> String -> S c Int -> ExprM String
getTextureSize prefix sampId sName l = do s <- useSampler prefix sName sampId
                                          l' <- unS l
                                          return $ "textureSize(" ++ s ++ ',' : l' ++ ")"

sample :: e -> String -> String -> String -> Int -> SampleLod lcoord x -> SampleProj x -> Maybe off -> coord -> (coord -> ExprM String) -> (lcoord -> ExprM String) -> (off -> String) -> (coord -> S x Float -> ExprM String) -> V4 (S x e)
sample _ prefix sDynType sName sampId lod proj off coord vToS lvToS ivToS pvToS =
    vec4S (STypeDyn sDynType) $ do s <- useSampler prefix sName sampId
                                   sampleFunc s proj lod off coord vToS lvToS ivToS pvToS

sampleShadow :: String -> Int -> SampleLod lcoord x -> SampleProj x -> Maybe off -> coord -> (coord -> ExprM String) -> (lcoord -> ExprM String) -> (off -> String) -> (coord -> S x Float -> ExprM String) -> S x Float
sampleShadow sName sampId lod proj off coord vToS lvToS civToS pvToS =
    scalarS STypeFloat $ do s <- useSampler "" (sName ++ "Shadow") sampId
                            sampleFunc s proj lod off coord vToS lvToS civToS pvToS

fetch :: e -> String -> String -> String -> Int -> S x Int -> Maybe off -> coord -> (coord -> ExprM String) -> (off -> String) -> V4 (S x e)
fetch _ prefix sDynType sName sampId lod off coord ivToS civToS =
    vec4S (STypeDyn sDynType) $ do s <- useSampler prefix sName sampId
                                   fetchFunc s off coord lod ivToS civToS

v1toF :: S c Float -> ExprM String
v2toF :: V2 (S c Float) -> ExprM String
v3toF :: V3 (S c Float) -> ExprM String
v4toF :: V4 (S c Float) -> ExprM String
v1toF = unS
v2toF (V2 x y) = do x' <- unS x
                    y' <- unS y
                    return $ "vec2(" ++ x' ++ ',':y' ++ ")"
v3toF (V3 x y z) = do x' <- unS x
                      y' <- unS y
                      z' <- unS z
                      return $ "vec3(" ++ x' ++ ',':y' ++ ',':z' ++ ")"
v4toF (V4 x y z w) = do x' <- unS x
                        y' <- unS y
                        z' <- unS z
                        w' <- unS w
                        return $ "vec4(" ++ x' ++ ',':y' ++ ',':z' ++ ',':w' ++ ")"

iv1toF :: S c Int -> ExprM String
iv2toF :: V2 (S c Int) -> ExprM String
iv3toF :: V3 (S c Int) -> ExprM String
iv1toF = unS
iv2toF (V2 x y) = do x' <- unS x
                     y' <- unS y
                     return $ "ivec2(" ++ x' ++ ',':y' ++ ")"
iv3toF (V3 x y z) = do x' <- unS x
                       y' <- unS y
                       z' <- unS z
                       return $ "ivec3(" ++ x' ++ ',':y' ++ ',':z' ++ ")"

civ1toF :: Int -> String
civ2toF :: V2 Int -> String
civ3toF :: V3 Int -> String
civ1toF = show
civ2toF (V2 x y) = "ivec2(" ++ show x ++ ',':show y ++ ")"
civ3toF (V3 x y z) = "ivec3(" ++ show x ++ ',':show y ++ ',':show z ++ ")"
pv1toF :: S c Float -> S c Float -> ExprM String
pv2toF :: V2 (S c Float) -> S c Float -> ExprM String
pv3toF :: V3 (S c Float) -> S c Float -> ExprM String

pv1toF x y = do x' <- unS x
                y' <- unS y
                return $ "vec2(" ++ x' ++ ',':y' ++ ")"
pv2toF (V2 x y) z = do x' <- unS x
                       y' <- unS y
                       z' <- unS z
                       return $ "vec3(" ++ x' ++ ',':y' ++ ',':z' ++ ")"
pv3toF (V3 x y z) w = do x' <- unS x
                         y' <- unS y
                         z' <- unS z
                         w' <- unS w
                         return $ "vec4(" ++ x' ++ ',':y' ++ ',':z' ++  ',':w' ++ ")"

sampleFunc s proj lod off coord vToS lvToS civToS pvToS = do
    pc <- projCoordParam proj
    l <- lodParam lod
    b <- biasParam lod
    return $ "texture" ++ projName proj ++ lodName lod ++ offName off ++ '(' : s ++ ',' : pc ++ l ++ o ++ b ++ ")"
  where
    o = offParam off civToS

    projName Nothing = ""
    projName _ = "Proj"

    projCoordParam Nothing = vToS coord
    projCoordParam (Just p) = pvToS coord p

    lodParam (SampleLod x) = fmap (',':) (unS x)
    lodParam (SampleGrad x y) = (++) <$> fmap (',':) (lvToS x) <*> fmap (',':) (lvToS y)
    lodParam _ = return ""

    biasParam :: SampleLod v x -> ExprM String
    biasParam (SampleBias (S x)) = do x' <- x
                                      return $ ',':x'
    biasParam _ = return ""

    lodName (SampleLod _) = "Lod"
    lodName (SampleGrad _ _) = "Grad"
    lodName _ = ""

fetchFunc s off coord lod vToS civToS = do
    c <- vToS coord
    l <- unS lod
    return $ "texelFetch" ++ offName off ++ '(' : s ++ ',' : c ++ ',': l ++ o ++ ")"
  where
    o = offParam off civToS

offParam :: Maybe t -> (t -> String) -> String
offParam Nothing _ = ""
offParam (Just x) civToS = ',' : civToS x

offName :: Maybe t -> String
offName Nothing = ""
offName _ = "Offset"

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

-- | A texture image is a reference to a 2D array of pixels in a texture. Some textures contain one 'Image' per level of detail while some contain several.
data Image f = Image TexName Int Int (V2 Int) (GLuint -> IO ()) -- the two Ints is last two in FBOKey

instance Eq (Image f) where
    (==) = imageEquals

-- | Compare two images that doesn't necessarily has same type
imageEquals :: Image a -> Image b -> Bool
imageEquals (Image tn' k1' k2' _ _) (Image tn k1 k2 _ _) = tn' == tn && k1' == k1 && k2' == k2

getImageBinding :: Image t -> GLuint -> IO ()
getImageBinding (Image _ _ _ _ io) = io

getImageFBOKey :: Image t -> IO FBOKey
getImageFBOKey (Image tn k1 k2 _ _) = do tn' <- readIORef tn
                                         return $ FBOKey tn' k1 k2
-- | Retrieve the 2D size an image
imageSize :: Image f -> V2 Int
imageSize (Image _ _ _ s _) = s

getTexture1DImage :: Texture1D os f -> Level -> Render os (Image f)
getTexture1DArrayImage :: Texture1DArray os f -> Level -> Int -> Render os (Image f)
getTexture2DImage :: Texture2D os f -> Level -> Render os (Image f)
getTexture2DArrayImage :: Texture2DArray os f -> Level -> Int -> Render os (Image f)
getTexture3DImage :: Texture3D os f -> Level -> Int -> Render os (Image f)
getTextureCubeImage :: TextureCube os f -> Level -> CubeSide -> Render os (Image f)

registerRenderWriteTextureName tn = Render (lift $ lift $ lift $ readIORef tn) >>= registerRenderWriteTexture . fromIntegral

getTexture1DImage t@(Texture1D tn _ ls) l' = let l = min ls l' in do registerRenderWriteTextureName tn
                                                                     return $ Image tn 0 l (V2 (texture1DSizes t !! l) 1) $ \attP -> do { n <- readIORef tn; glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attP GL_TEXTURE_1D n (fromIntegral l) }
getTexture1DArrayImage t@(Texture1DArray tn _ ls) l' y' = let l = min ls l'
                                                              V2 x y = texture1DArraySizes t !! l
                                                          in do registerRenderWriteTextureName tn
                                                                return $ Image tn y' l (V2 x 1) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min y' (y-1)) }
getTexture2DImage t@(Texture2D tn _ ls) l' = let l = min ls l' in do registerRenderWriteTextureName tn
                                                                     return $ Image tn 0 l (texture2DSizes t !! l) $ \attP -> do { n <- readIORef tn; glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attP GL_TEXTURE_2D n (fromIntegral l) }
getTexture2DImage t@(RenderBuffer2D tn _) _ = return $ Image tn (-1) 0 (head $ texture2DSizes t) $ \attP -> do { n <- readIORef tn; glFramebufferRenderbuffer GL_DRAW_FRAMEBUFFER attP GL_RENDERBUFFER n }
getTexture2DArrayImage t@(Texture2DArray tn _ ls) l' z' = let l = min ls l'
                                                              V3 x y z = texture2DArraySizes t !! l
                                                          in do registerRenderWriteTextureName tn
                                                                return $ Image tn z' l (V2 x y) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min z' (z-1)) }
getTexture3DImage t@(Texture3D tn _ ls) l' z' = let l = min ls l'
                                                    V3 x y z = texture3DSizes t !! l
                                                in do registerRenderWriteTextureName tn
                                                      return $ Image tn z' l (V2 x y) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min z' (z-1)) }
getTextureCubeImage t@(TextureCube tn _ ls) l' s = let l = min ls l'
                                                       x = textureCubeSizes t !! l
                                                       s' = getGlCubeSide s
                                                   in do registerRenderWriteTextureName tn
                                                         return $ Image tn (fromIntegral s') l (V2 x x) $ \attP -> do { n <- readIORef tn; glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attP s' n (fromIntegral l) }

getGlCubeSide :: CubeSide -> GLenum
getGlCubeSide CubePosX = GL_TEXTURE_CUBE_MAP_POSITIVE_X
getGlCubeSide CubeNegX = GL_TEXTURE_CUBE_MAP_NEGATIVE_X
getGlCubeSide CubePosY = GL_TEXTURE_CUBE_MAP_POSITIVE_Y
getGlCubeSide CubeNegY = GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
getGlCubeSide CubePosZ = GL_TEXTURE_CUBE_MAP_POSITIVE_Z
getGlCubeSide CubeNegZ = GL_TEXTURE_CUBE_MAP_NEGATIVE_Z