{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, 
             ScopedTypeVariables, TypeFamilies, FlexibleContexts #-}
-- |Utilities for loading texture data.
module Graphics.GLUtil.Textures where
import Control.Monad (forM_)
import Graphics.Rendering.OpenGL
import qualified Graphics.Rendering.OpenGL.GL.VertexArrays as GL
import Data.Array.Storable (StorableArray, withStorableArray)
import Data.ByteString.Internal (ByteString, toForeignPtr)
import Data.Vector.Storable (Vector, unsafeWith)
import Data.Word (Word8, Word16)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (Ptr, plusPtr, castPtr, nullPtr)
import Foreign.Marshal.Array (withArray)

import Graphics.GLUtil.TypeMapping (HasGLType(..))

-- |Pixel format of image data.
data TexColor = TexMono | TexRG | TexRGB | TexBGR | TexRGBA

-- |A basic texture information record.
data TexInfo a = TexInfo { TexInfo a -> GLsizei
texWidth  :: GLsizei
                         , TexInfo a -> GLsizei
texHeight :: GLsizei
                         , TexInfo a -> TexColor
texColor  :: TexColor
                         , TexInfo a -> a
texData   :: a }

-- |Helper for constructing a 'TexInfo' using Haskell 'Int's for image
-- dimensions.
texInfo :: Int -> Int -> TexColor -> a -> TexInfo a
texInfo :: Int -> Int -> TexColor -> a -> TexInfo a
texInfo w :: Int
w h :: Int
h = GLsizei -> GLsizei -> TexColor -> a -> TexInfo a
forall a. GLsizei -> GLsizei -> TexColor -> a -> TexInfo a
TexInfo (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)

-- |Class for containers of texture data.
class HasGLType (Elem a) => IsPixelData a where
  type Elem a
  withPixels :: a -> (Ptr (Elem a) -> IO c) -> IO c

instance HasGLType b => IsPixelData [b] where
  type Elem [b] = b
  withPixels :: [b] -> (Ptr (Elem [b]) -> IO c) -> IO c
withPixels = [b] -> (Ptr (Elem [b]) -> IO c) -> IO c
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray

instance HasGLType b => IsPixelData (Ptr b) where
  type Elem (Ptr b) = b
  withPixels :: Ptr b -> (Ptr (Elem (Ptr b)) -> IO c) -> IO c
withPixels = ((Ptr b -> IO c) -> Ptr b -> IO c)
-> Ptr b -> (Ptr b -> IO c) -> IO c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Ptr b -> IO c) -> Ptr b -> IO c
forall a b. (a -> b) -> a -> b
($)

instance HasGLType b => IsPixelData (ForeignPtr b) where
  type Elem (ForeignPtr b) = b
  withPixels :: ForeignPtr b -> (Ptr (Elem (ForeignPtr b)) -> IO c) -> IO c
withPixels = ForeignPtr b -> (Ptr (Elem (ForeignPtr b)) -> IO c) -> IO c
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr

instance HasGLType b => IsPixelData (StorableArray i b) where
  type Elem (StorableArray i b) = b
  withPixels :: StorableArray i b
-> (Ptr (Elem (StorableArray i b)) -> IO c) -> IO c
withPixels = StorableArray i b
-> (Ptr (Elem (StorableArray i b)) -> IO c) -> IO c
forall i e a. StorableArray i e -> (Ptr e -> IO a) -> IO a
withStorableArray

instance HasGLType b => IsPixelData (Vector b) where
  type Elem (Vector b) = b
  withPixels :: Vector b -> (Ptr (Elem (Vector b)) -> IO c) -> IO c
withPixels = Vector b -> (Ptr (Elem (Vector b)) -> IO c) -> IO c
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
unsafeWith

instance IsPixelData ByteString where
  type Elem ByteString = Word8
  withPixels :: ByteString -> (Ptr (Elem ByteString) -> IO c) -> IO c
withPixels b :: ByteString
b m :: Ptr (Elem ByteString) -> IO c
m = (ForeignPtr Word8, Int, Int) -> IO c
aux ((ForeignPtr Word8, Int, Int) -> IO c)
-> (ByteString -> (ForeignPtr Word8, Int, Int))
-> ByteString
-> IO c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr (ByteString -> IO c) -> ByteString -> IO c
forall a b. (a -> b) -> a -> b
$ ByteString
b
    where aux :: (ForeignPtr Word8, Int, Int) -> IO c
aux (fp :: ForeignPtr Word8
fp,o :: Int
o,_) = ForeignPtr Word8 -> (Ptr Word8 -> IO c) -> IO c
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO c) -> IO c) -> (Ptr Word8 -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p ->
                           Ptr (Elem ByteString) -> IO c
m (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p Int
o)

-- |Wrapper whose 'IsPixelData' instance treats the pointer underlying
-- a 'ByteString' as an array of 'Word16's.
newtype ShortString = ShortString ByteString

instance IsPixelData ShortString where
  type Elem ShortString = Word16
  withPixels :: ShortString -> (Ptr (Elem ShortString) -> IO c) -> IO c
withPixels (ShortString b :: ByteString
b) m :: Ptr (Elem ShortString) -> IO c
m = (ForeignPtr Word8, Int, Int) -> IO c
aux((ForeignPtr Word8, Int, Int) -> IO c)
-> (ByteString -> (ForeignPtr Word8, Int, Int))
-> ByteString
-> IO c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr (ByteString -> IO c) -> ByteString -> IO c
forall a b. (a -> b) -> a -> b
$ ByteString
b
    where aux :: (ForeignPtr Word8, Int, Int) -> IO c
aux (fp :: ForeignPtr Word8
fp,o :: Int
o,_) = ForeignPtr Word8 -> (Ptr Word8 -> IO c) -> IO c
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO c) -> IO c) -> (Ptr Word8 -> IO c) -> IO c
forall a b. (a -> b) -> a -> b
$ \p :: Ptr Word8
p ->
                           Ptr (Elem ShortString) -> IO c
m (Ptr Word16 -> Int -> Ptr Word16
forall a b. Ptr a -> Int -> Ptr b
plusPtr (Ptr Word8 -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
p :: Ptr Word16) Int
o)

-- |Create a new 2D texture with uninitialized contents.
freshTexture :: forall a proxy. HasGLType a
             => Int -> Int -> TexColor -> proxy a -> IO TextureObject
freshTexture :: Int -> Int -> TexColor -> proxy a -> IO TextureObject
freshTexture w :: Int
w h :: Int
h c :: TexColor
c _ = TexInfo (Ptr a) -> IO TextureObject
forall a. IsPixelData a => TexInfo a -> IO TextureObject
loadTexture (TexInfo (Ptr a) -> IO TextureObject)
-> TexInfo (Ptr a) -> IO TextureObject
forall a b. (a -> b) -> a -> b
$ Int -> Int -> TexColor -> Ptr a -> TexInfo (Ptr a)
forall a. Int -> Int -> TexColor -> a -> TexInfo a
texInfo Int
w Int
h TexColor
c (Ptr a
forall a. Ptr a
nullPtr::Ptr a)

-- |Create a new 2D texture with uninitialized 'Word8' contents.
freshTextureWord8 :: Int -> Int -> TexColor -> IO TextureObject
freshTextureWord8 :: Int -> Int -> TexColor -> IO TextureObject
freshTextureWord8 w :: Int
w h :: Int
h c :: TexColor
c = TexInfo (Ptr Word8) -> IO TextureObject
forall a. IsPixelData a => TexInfo a -> IO TextureObject
loadTexture (TexInfo (Ptr Word8) -> IO TextureObject)
-> TexInfo (Ptr Word8) -> IO TextureObject
forall a b. (a -> b) -> a -> b
$ Int -> Int -> TexColor -> Ptr Word8 -> TexInfo (Ptr Word8)
forall a. Int -> Int -> TexColor -> a -> TexInfo a
texInfo Int
w Int
h TexColor
c (Ptr Word8
forall a. Ptr a
nullPtr::Ptr Word8)

-- |Create a new 2D texture with uninitialized 'GLfloat' contents.
freshTextureFloat :: Int -> Int -> TexColor -> IO TextureObject
freshTextureFloat :: Int -> Int -> TexColor -> IO TextureObject
freshTextureFloat w :: Int
w h :: Int
h c :: TexColor
c = TexInfo (Ptr GLfloat) -> IO TextureObject
forall a. IsPixelData a => TexInfo a -> IO TextureObject
loadTexture (TexInfo (Ptr GLfloat) -> IO TextureObject)
-> TexInfo (Ptr GLfloat) -> IO TextureObject
forall a b. (a -> b) -> a -> b
$ Int -> Int -> TexColor -> Ptr GLfloat -> TexInfo (Ptr GLfloat)
forall a. Int -> Int -> TexColor -> a -> TexInfo a
texInfo Int
w Int
h TexColor
c (Ptr GLfloat
forall a. Ptr a
nullPtr::Ptr GLfloat)

-- |Create a new 2D texture with data from a 'TexInfo'.
loadTexture :: IsPixelData a => TexInfo a -> IO TextureObject
loadTexture :: TexInfo a -> IO TextureObject
loadTexture tex :: TexInfo a
tex = do [obj :: TextureObject
obj] <- Int -> IO [TextureObject]
forall a (m :: * -> *).
(GeneratableObjectName a, MonadIO m) =>
Int -> m [a]
genObjectNames 1
                     TextureObject -> TexInfo a -> IO ()
forall a. IsPixelData a => TextureObject -> TexInfo a -> IO ()
reloadTexture TextureObject
obj TexInfo a
tex
                     TextureObject -> IO TextureObject
forall (m :: * -> *) a. Monad m => a -> m a
return TextureObject
obj

-- |Replace a 2D texture's pixel data with data from a 'TexInfo'.
reloadTexture :: forall a. IsPixelData a => 
                 TextureObject -> TexInfo a -> IO ()
reloadTexture :: TextureObject -> TexInfo a -> IO ()
reloadTexture obj :: TextureObject
obj tex :: TexInfo a
tex = do TextureTarget2D -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
textureBinding TextureTarget2D
Texture2D StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just TextureObject
obj
                           TexColor -> IO ()
loadTex (TexColor -> IO ()) -> TexColor -> IO ()
forall a b. (a -> b) -> a -> b
$ TexInfo a -> TexColor
forall a. TexInfo a -> TexColor
texColor TexInfo a
tex
  where loadTex :: TexColor -> IO ()
loadTex TexMono = case DataType
pixelType of
                            GL.UnsignedShort -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
Luminance16 PixelFormat
Luminance
                            GL.Float         -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
R32F PixelFormat
Red
                            GL.HalfFloat     -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
R16F PixelFormat
Red
                            GL.UnsignedByte  -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
R8 PixelFormat
Red
                            _                -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
Luminance' PixelFormat
Luminance
        loadTex TexRG = case DataType
pixelType of
                          GL.UnsignedShort -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RG16 PixelFormat
RGInteger
                          GL.Float -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RG32F PixelFormat
RG
                          GL.HalfFloat -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RG16F PixelFormat
RG
                          GL.UnsignedByte -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RG8UI PixelFormat
RGInteger
                          GL.Byte -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RG8I PixelFormat
RGInteger
                          GL.Int -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RG32I PixelFormat
RGInteger
                          GL.UnsignedInt -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RG32UI PixelFormat
RGInteger
                          _ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error "Unknown pixelType for TexRG"
        loadTex TexRGB = PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RGBA' PixelFormat
RGB
        loadTex TexBGR = PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RGBA' PixelFormat
BGR
        loadTex TexRGBA = case DataType
pixelType of
                            GL.UnsignedShort -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RGBA16 PixelFormat
RGBA
                            GL.Float -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RGBA32F PixelFormat
RGBA
                            GL.HalfFloat -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RGBA16F PixelFormat
RGBA
                            GL.Int -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RGBA32I PixelFormat
RGBAInteger
                            GL.UnsignedInt -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RGBA32UI PixelFormat
RGBAInteger
                            _ -> PixelInternalFormat -> PixelFormat -> IO ()
loadAux PixelInternalFormat
RGBA' PixelFormat
RGBA
        sz :: TextureSize2D
sz = GLsizei -> GLsizei -> TextureSize2D
TextureSize2D (TexInfo a -> GLsizei
forall a. TexInfo a -> GLsizei
texWidth TexInfo a
tex) (TexInfo a -> GLsizei
forall a. TexInfo a -> GLsizei
texHeight TexInfo a
tex)
        pixelType :: DataType
pixelType = Elem a -> DataType
forall a. HasGLType a => a -> DataType
glType (Elem a
forall a. HasCallStack => a
undefined::Elem a)
        loadAux :: PixelInternalFormat -> PixelFormat -> IO ()
loadAux i :: PixelInternalFormat
i e :: PixelFormat
e = a -> (Ptr (Elem a) -> IO ()) -> IO ()
forall a c. IsPixelData a => a -> (Ptr (Elem a) -> IO c) -> IO c
withPixels (TexInfo a -> a
forall a. TexInfo a -> a
texData TexInfo a
tex) ((Ptr (Elem a) -> IO ()) -> IO ())
-> (Ptr (Elem a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ 
                      (TextureTarget2D
-> Proxy
-> GLsizei
-> PixelInternalFormat
-> TextureSize2D
-> GLsizei
-> PixelData (Elem a)
-> IO ()
forall t a.
TwoDimensionalTextureTarget t =>
t
-> Proxy
-> GLsizei
-> PixelInternalFormat
-> TextureSize2D
-> GLsizei
-> PixelData a
-> IO ()
texImage2D TextureTarget2D
Texture2D Proxy
NoProxy 0 PixelInternalFormat
i TextureSize2D
sz 0 (PixelData (Elem a) -> IO ())
-> (Ptr (Elem a) -> PixelData (Elem a)) -> Ptr (Elem a) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       PixelFormat -> DataType -> Ptr (Elem a) -> PixelData (Elem a)
forall a. PixelFormat -> DataType -> Ptr a -> PixelData a
PixelData PixelFormat
e DataType
pixelType)

-- | Set texture coordinate wrapping options for both the 'S' and 'T'
-- dimensions of a 2D texture.
texture2DWrap :: StateVar (Repetition, Clamping)
texture2DWrap :: StateVar (Repetition, Clamping)
texture2DWrap = IO (Repetition, Clamping)
-> ((Repetition, Clamping) -> IO ())
-> StateVar (Repetition, Clamping)
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar (StateVar (Repetition, Clamping) -> IO (Repetition, Clamping)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (TextureTarget2D
-> TextureCoordName -> StateVar (Repetition, Clamping)
forall t.
ParameterizedTextureTarget t =>
t -> TextureCoordName -> StateVar (Repetition, Clamping)
textureWrapMode TextureTarget2D
Texture2D TextureCoordName
S))
                             ([TextureCoordName] -> (TextureCoordName -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TextureCoordName
S,TextureCoordName
T] ((TextureCoordName -> IO ()) -> IO ())
-> ((Repetition, Clamping) -> TextureCoordName -> IO ())
-> (Repetition, Clamping)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Repetition, Clamping) -> TextureCoordName -> IO ()
forall (m :: * -> *).
MonadIO m =>
(Repetition, Clamping) -> TextureCoordName -> m ()
aux)
  where aux :: (Repetition, Clamping) -> TextureCoordName -> m ()
aux x :: (Repetition, Clamping)
x d :: TextureCoordName
d = TextureTarget2D
-> TextureCoordName -> StateVar (Repetition, Clamping)
forall t.
ParameterizedTextureTarget t =>
t -> TextureCoordName -> StateVar (Repetition, Clamping)
textureWrapMode TextureTarget2D
Texture2D TextureCoordName
d StateVar (Repetition, Clamping) -> (Repetition, Clamping) -> m ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Repetition, Clamping)
x

-- | Set texture coordinate wrapping options for the 'S', 'T', and 'R'
-- dimensions of a 3D texture.
texture3DWrap :: StateVar (Repetition, Clamping)
texture3DWrap :: StateVar (Repetition, Clamping)
texture3DWrap = IO (Repetition, Clamping)
-> ((Repetition, Clamping) -> IO ())
-> StateVar (Repetition, Clamping)
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar (StateVar (Repetition, Clamping) -> IO (Repetition, Clamping)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (TextureTarget2D
-> TextureCoordName -> StateVar (Repetition, Clamping)
forall t.
ParameterizedTextureTarget t =>
t -> TextureCoordName -> StateVar (Repetition, Clamping)
textureWrapMode TextureTarget2D
Texture2D TextureCoordName
S))
                             ([TextureCoordName] -> (TextureCoordName -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TextureCoordName
S,TextureCoordName
T,TextureCoordName
R] ((TextureCoordName -> IO ()) -> IO ())
-> ((Repetition, Clamping) -> TextureCoordName -> IO ())
-> (Repetition, Clamping)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Repetition, Clamping) -> TextureCoordName -> IO ()
forall (m :: * -> *).
MonadIO m =>
(Repetition, Clamping) -> TextureCoordName -> m ()
aux)
  where aux :: (Repetition, Clamping) -> TextureCoordName -> m ()
aux x :: (Repetition, Clamping)
x d :: TextureCoordName
d = TextureTarget2D
-> TextureCoordName -> StateVar (Repetition, Clamping)
forall t.
ParameterizedTextureTarget t =>
t -> TextureCoordName -> StateVar (Repetition, Clamping)
textureWrapMode TextureTarget2D
Texture2D TextureCoordName
d StateVar (Repetition, Clamping) -> (Repetition, Clamping) -> m ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Repetition, Clamping)
x


-- | Bind each of the given textures to successive texture units at
-- the given 'TextureTarget' starting with texture unit 0.
withTextures :: BindableTextureTarget t => t -> [TextureObject] -> IO a -> IO a
withTextures :: t -> [TextureObject] -> IO a -> IO a
withTextures tt :: t
tt ts :: [TextureObject]
ts m :: IO a
m = do ((TextureObject, GLuint) -> IO ())
-> [(TextureObject, GLuint)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TextureObject, GLuint) -> IO ()
aux ([TextureObject] -> [GLuint] -> [(TextureObject, GLuint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TextureObject]
ts [0..])
                          a
r <- IO a
m
                          GLuint -> [TextureObject] -> IO ()
cleanup 0 [TextureObject]
ts
                          StateVar TextureUnit
activeTexture StateVar TextureUnit -> TextureUnit -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLuint -> TextureUnit
TextureUnit 0
                          a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
  where aux :: (TextureObject, GLuint) -> IO ()
aux (t :: TextureObject
t,i :: GLuint
i) = do StateVar TextureUnit
activeTexture StateVar TextureUnit -> TextureUnit -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLuint -> TextureUnit
TextureUnit GLuint
i
                       t -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
textureBinding t
tt StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just TextureObject
t
        cleanup :: GLuint -> [TextureObject] -> IO ()
cleanup _ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        cleanup i :: GLuint
i (_:ts' :: [TextureObject]
ts') = do StateVar TextureUnit
activeTexture StateVar TextureUnit -> TextureUnit -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLuint -> TextureUnit
TextureUnit GLuint
i
                               t -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
textureBinding t
tt StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Maybe TextureObject
forall a. Maybe a
Nothing
                               GLuint -> [TextureObject] -> IO ()
cleanup (GLuint
iGLuint -> GLuint -> GLuint
forall a. Num a => a -> a -> a
+1) [TextureObject]
ts'

-- | Bind each of the given 2D textures to successive texture units
-- starting with texture unit 0.
withTextures2D :: [TextureObject] -> IO a -> IO a
withTextures2D :: [TextureObject] -> IO a -> IO a
withTextures2D = TextureTarget2D -> [TextureObject] -> IO a -> IO a
forall t a.
BindableTextureTarget t =>
t -> [TextureObject] -> IO a -> IO a
withTextures TextureTarget2D
Texture2D

-- | Bind each of the given textures to the texture unit they are
-- paired with. The given action is run with these bindings, then the
-- texture bindings are reset. If you don't care which texture units
-- are used, consider using 'withTextures' or 'withTextures2D'.
withTexturesAt :: BindableTextureTarget t
               => t -> [(TextureObject,GLuint)] -> IO a -> IO a
withTexturesAt :: t -> [(TextureObject, GLuint)] -> IO a -> IO a
withTexturesAt tt :: t
tt ts :: [(TextureObject, GLuint)]
ts m :: IO a
m = do ((TextureObject, GLuint) -> IO ())
-> [(TextureObject, GLuint)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TextureObject, GLuint) -> IO ()
aux [(TextureObject, GLuint)]
ts
                            a
r <- IO a
m
                            ((TextureObject, GLuint) -> IO ())
-> [(TextureObject, GLuint)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (GLuint -> IO ()
cleanup (GLuint -> IO ())
-> ((TextureObject, GLuint) -> GLuint)
-> (TextureObject, GLuint)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextureObject, GLuint) -> GLuint
forall a b. (a, b) -> b
snd) [(TextureObject, GLuint)]
ts
                            a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
  where aux :: (TextureObject, GLuint) -> IO ()
aux (t :: TextureObject
t,i :: GLuint
i) = do StateVar TextureUnit
activeTexture StateVar TextureUnit -> TextureUnit -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLuint -> TextureUnit
TextureUnit GLuint
i
                       t -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
textureBinding t
tt StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just TextureObject
t
        cleanup :: GLuint -> IO ()
cleanup i :: GLuint
i = do StateVar TextureUnit
activeTexture StateVar TextureUnit -> TextureUnit -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLuint -> TextureUnit
TextureUnit GLuint
i
                       t -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
textureBinding t
tt StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Maybe TextureObject
forall a. Maybe a
Nothing