GLUtil 0.3.0 → 0.6.1

raw patch · 10 files changed

+495/−48 lines, 10 filesdep +JuicyPixelsdep +containersdep +linearPVP ok

version bump matches the API change (PVP)

Dependencies added: JuicyPixels, containers, linear

API changes (from Hackage documentation)

Files

• GLUtil.cabal +14/−6
• src/Graphics/GLUtil.hs +12/−1
• src/Graphics/GLUtil/JuicyTextures.hs +21/−0
• src/Graphics/GLUtil/Linear.hs +66/−0
• src/Graphics/GLUtil/ShaderProgram.hs +142/−0
• src/Graphics/GLUtil/Shaders.hs +78/−3
• src/Graphics/GLUtil/Textures.hs +49/−11
• src/Graphics/GLUtil/TypeMapping.hs +89/−0
• src/Graphics/GLUtil/VertexArrayObjects.hs +15/−27
• src/Graphics/GLUtil/Viewport.hs +9/−0

@@ -1,5 +1,5 @@ Name:                GLUtil-Version:             0.3.0+Version:             0.6.1 Synopsis:            Miscellaneous OpenGL utilities. License:             BSD3 License-file:        LICENSE@@ -23,22 +23,30 @@ Library   Exposed-modules:     Graphics.GLUtil,                        Graphics.GLUtil.GLError,-                       Graphics.GLUtil.Shaders, -                       Graphics.GLUtil.BufferObjects, +                       Graphics.GLUtil.Shaders,+                       Graphics.GLUtil.ShaderProgram,+                       Graphics.GLUtil.BufferObjects,                        Graphics.GLUtil.Textures,-                       Graphics.GLUtil.VertexArrayObjects+                       Graphics.GLUtil.JuicyTextures,+                       Graphics.GLUtil.VertexArrayObjects,+                       Graphics.GLUtil.Linear,+                       Graphics.GLUtil.TypeMapping,+                       Graphics.GLUtil.Viewport      Build-depends:       base >= 4.2 && < 5,                        bytestring,                        array,+                       containers,+                       linear,+                       JuicyPixels >= 3,                        OpenGLRaw >= 1.1,                        OpenGL >= 2.4,                        vector >= 0.7-+  Build-tools:         cpphs   GHC-Options:         -Odph -Wall   HS-Source-Dirs:      src    source-repository this   type:     git+  tag:      0.6.1   location: http://github.com/acowley/GLUtil.git-  tag:      0.2.2

@@ -3,11 +3,22 @@ module Graphics.GLUtil (module Graphics.GLUtil.BufferObjects,                         module Graphics.GLUtil.Shaders,                         module Graphics.GLUtil.Textures,+                        readTexture,                         module Graphics.GLUtil.GLError,-                        module Graphics.GLUtil.VertexArrayObjects) where+                        module Graphics.GLUtil.VertexArrayObjects,+                        module Graphics.GLUtil.ShaderProgram,+                        module Graphics.GLUtil.TypeMapping,+                        module Graphics.GLUtil.Linear,+                        module Graphics.GLUtil.Viewport) where  import Graphics.GLUtil.BufferObjects import Graphics.GLUtil.Shaders import Graphics.GLUtil.Textures import Graphics.GLUtil.GLError import Graphics.GLUtil.VertexArrayObjects+import Graphics.GLUtil.ShaderProgram+import Graphics.GLUtil.TypeMapping+import Graphics.GLUtil.Viewport++import Graphics.GLUtil.JuicyTextures (readTexture)+import Graphics.GLUtil.Linear

@@ -0,0 +1,21 @@+{-# LANGUAGE RankNTypes #-}+module Graphics.GLUtil.JuicyTextures where+import Codec.Picture (readImage, DynamicImage(..), Image(..))+import Control.Applicative ((<$>))+import Graphics.GLUtil.Textures+import Graphics.Rendering.OpenGL (TextureObject)++readTexInfo :: FilePath+            -> (forall a. IsPixelData a => TexInfo a -> IO b)+            -> IO (Either String b)+readTexInfo f k = readImage f >>= either (return . Left) aux+  where aux (ImageY8 (Image w h p)) = Right <$> k (texInfo w h TexMono p)+        aux (ImageYF (Image w h p)) = Right <$> k (texInfo w h TexMono p)+        aux (ImageYA8 _) = return $ Left "YA format not supported"+        aux (ImageRGB8 (Image w h p)) = Right <$> k (texInfo w h TexRGB p)+        aux (ImageRGBF (Image w h p)) = Right <$> k (texInfo w h TexRGB p)+        aux (ImageRGBA8 (Image w h p)) = Right <$> k (texInfo w h TexRGBA p)+        aux (ImageYCbCr8 _) = return $ Left "YCbCr format not supported"++readTexture :: FilePath -> IO (Either String TextureObject)+readTexture f = readTexInfo f loadTexture

@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}+{-# OPTIONS_GHC -cpp -pgmPcpphs -optP--cpp -optP--hashes #-}+-- |Support for writing "Linear" types to uniform locations in+-- shader programs.+module Graphics.GLUtil.Linear (AsUniform(..)) where+import Foreign.Marshal.Array (withArray)+import Foreign.Marshal.Utils (with)+import Foreign.Ptr (Ptr, castPtr)+import Foreign.Storable (Storable)+import Graphics.Rendering.OpenGL (UniformLocation)+import Graphics.Rendering.OpenGL.Raw.Core31+import Linear+import Unsafe.Coerce (unsafeCoerce)++-- | A type class for things we can write to uniform locations in+-- shader programs.+class AsUniform t where+  asUniform :: t -> UniformLocation -> IO ()++getUL :: UniformLocation -> GLint+getUL = unsafeCoerce++castVecComponent :: Ptr (t a) -> Ptr a+castVecComponent = castPtr++castMatComponent :: Ptr (t (f a)) -> Ptr a+castMatComponent = castPtr++instance AsUniform GLint where+  x `asUniform` loc = with x $ glUniform1iv (getUL loc) 1++instance AsUniform GLuint where+  x `asUniform` loc = with x $ glUniform1uiv (getUL loc) 1++instance AsUniform GLfloat where+  x `asUniform` loc = with x $ glUniform1fv (getUL loc) 1++#define UNIFORMVEC_T(d,ht,glt) instance AsUniform (V ## d ht) where {v `asUniform` loc = with v $ glUniform##d##glt##v (getUL loc) 1 . castVecComponent}++#define UNIFORMVEC(d) UNIFORMVEC_T(d,GLint,i); UNIFORMVEC_T(d,GLuint,ui); UNIFORMVEC_T(d,GLfloat,f)++UNIFORMVEC(2)+UNIFORMVEC(3)+UNIFORMVEC(4)++instance AsUniform (M22 GLfloat) where+  m `asUniform` loc = with m+                    $ glUniformMatrix2fv (getUL loc) 1 1 . castMatComponent++instance AsUniform (M33 GLfloat) where+  m `asUniform` loc = with m+                    $ glUniformMatrix3fv (getUL loc) 1 1 . castMatComponent++instance AsUniform (M44 GLfloat) where+  m `asUniform` loc = with m+                    $ glUniformMatrix4fv (getUL loc) 1 1 . castMatComponent++-- Support lists of vectors as uniform arrays of vectors.++#define UNIFORMARRAY_T(d,ht,glt) instance AsUniform [V##d ht] where {l `asUniform` loc = withArray l $ glUniform##d##glt##v (getUL loc) (fromIntegral $ length l) . castVecComponent}++#define UNIFORMARRAY(d) UNIFORMARRAY_T(d,GLint,i); UNIFORMARRAY_T(d,GLuint,ui); UNIFORMARRAY_T(d,GLfloat,f)++UNIFORMARRAY(2)+UNIFORMARRAY(3)+UNIFORMARRAY(4)

@@ -0,0 +1,142 @@+-- |Convenience interface for working with GLSL shader+-- programs. Provides an interface for setting attributes and+-- uniforms.+module Graphics.GLUtil.ShaderProgram (ShaderProgram(..), loadShaderProgram, +                                      loadShaderProgramWith,+                                      loadGeoProgram,+                                      loadGeoProgramWith,+                                      loadShaderExplicit, +                                      getAttrib, enableAttrib, setAttrib, +                                      setUniform, getUniform) where+import Prelude hiding (lookup)+import Control.Applicative ((<$>), (<*>))+import Data.List (find, findIndex)+import Data.Map.Strict (Map, fromList, lookup)+import Data.Maybe (isJust, isNothing, catMaybes)+import Graphics.GLUtil.Shaders (loadShader, loadGeoShader, linkShaderProgram,+                                linkGeoProgramWith)+import Graphics.GLUtil.GLError (throwError)+import Graphics.Rendering.OpenGL++-- |Representation of a GLSL shader program that has been compiled and+-- linked.+data ShaderProgram = +  ShaderProgram { attribs  :: Map String (AttribLocation, VariableType)+                , uniforms :: Map String (UniformLocation, VariableType)+                , program  :: Program }++-- |Load a 'ShaderProgram' from a vertex and fragment shader source+-- files. the third argument is a tuple of the attribute names and+-- uniform names that will be set in this program. If all attributes+-- and uniforms are desired, consider using 'loadShaderProgram'.+loadShaderExplicit :: FilePath -> FilePath -> ([String],[String])+                   -> IO ShaderProgram+loadShaderExplicit vsrc fsrc names =+  do vs <- loadShader vsrc+     fs <- loadShader fsrc+     p <- linkShaderProgram [vs] [fs]+     throwError+     (attrs,unis) <- getExplicits p names+     return $ ShaderProgram (fromList attrs) (fromList unis) p++-- |Load a 'ShaderProgram' from a vertex shader source file and a+-- fragment shader source file. The active attributes and uniforms in+-- the linked program are recorded in the 'ShaderProgram'.+loadShaderProgram :: FilePath -> FilePath -> IO ShaderProgram+loadShaderProgram vsrc fsrc = loadShaderProgramWith vsrc fsrc (\_ -> return ())++-- |Load a 'ShaderProgram' from a vertex shader source file, a+-- geometry shader source file, and a fragment shader source file. The+-- active attributes and uniforms in the linked program are recorded+-- in the 'ShaderProgram'.+loadGeoProgram :: FilePath -> FilePath -> FilePath -> IO ShaderProgram+loadGeoProgram vsrc gsrc fsrc = +  loadGeoProgramWith vsrc gsrc fsrc (\_ -> return ())++-- |Load a 'ShaderProgram' from a vertex shader source file and a+-- fragment shader source file. The active attributes and uniforms in+-- the linked program are recorded in the 'ShaderProgram'. The+-- supplied 'IO' function is applied to the new program after shader+-- objects are attached to the program, but before linking. This+-- supports the use of 'bindFragDataLocation' to map fragment shader+-- outputs.+loadShaderProgramWith :: FilePath -> FilePath -> (Program -> IO ())+                      -> IO ShaderProgram+loadShaderProgramWith vsrc fsrc m = loadProgramWithAux vsrc Nothing fsrc m++-- |Load a 'ShaderProgram' from a vertex shader source file, a+-- geometry shader source file, and a fragment shader source file. The+-- active attributes and uniforms in the linked program are recorded+-- in the 'ShaderProgram'. The supplied 'IO' function is applied to+-- the new program after shader objects are attached to the program,+-- but before linking. This supports the use of 'bindFragDataLocation'+-- to map fragment shader outputs.+loadGeoProgramWith :: FilePath -> FilePath -> FilePath -> (Program -> IO ())+                   -> IO ShaderProgram+loadGeoProgramWith vsrc gsrc fsrc m = loadProgramWithAux vsrc (Just gsrc) fsrc m++-- | Helper for @load*Program*@ variants.+loadProgramWithAux :: FilePath -> Maybe FilePath -> FilePath+                   -> (Program -> IO ()) -> IO ShaderProgram+loadProgramWithAux vsrc gsrc fsrc m =+  do vs <- loadShader vsrc+     gs <- maybe (return []) (fmap (:[]) . loadGeoShader) gsrc+     fs <- loadShader fsrc+     p <- linkGeoProgramWith [vs] gs [fs] m+     throwError+     (attrs,unis) <- getActives p+     return $ ShaderProgram (fromList attrs) (fromList unis) p+     ++getActives :: Program -> +              IO ( [(String, (AttribLocation, VariableType))]+                 , [(String, (UniformLocation, VariableType))] )+getActives p = +  (,) <$> (get (activeAttribs p) >>= mapM (aux (attribLocation p)))+      <*> (get (activeUniforms p) >>= mapM (aux (uniformLocation p)))+  where aux f (_,t,name) = get (f name) >>= \l -> return (name, (l, t))++getExplicits :: Program -> ([String], [String]) ->+                IO ( [(String, (AttribLocation, VariableType))]+                   , [(String, (UniformLocation, VariableType))] )+getExplicits p (anames, unames) = +  do attrs <- get (activeAttribs p)+     attrs' <- mapM (aux (get . (attribLocation p))) . checkJusts $+               map (\a -> find (\(_,_,n) -> n == a) attrs) anames+     unis <- get (activeUniforms p)+     unis' <- mapM (aux (get . (uniformLocation p))) . checkJusts $+              map (\u -> find (\(_,_,n) -> n == u) unis) unames+     return (attrs', unis')+  where aux f (_,t,n) = f n >>= \l -> return (n, (l,t))+        checkJusts xs+          | all isJust xs = catMaybes xs+          | otherwise = let Just i = findIndex isNothing xs+                        in error $ "Missing GLSL variable: " ++ anames !! i++setUniform :: Uniform a => ShaderProgram -> String -> a -> IO ()+setUniform sp name = maybe (const (putStrLn warn >> return ()))+                           (\(u,_) -> let u' = uniform u+                                      in \x -> u' $= x)+                           (lookup name $ uniforms sp)+  where warn = "WARNING: uniform "++name++" is not active"++getUniform :: ShaderProgram -> String -> UniformLocation+getUniform sp n = maybe (error msg) fst . lookup n $ uniforms sp+  where msg = "Uniform "++show n++" is not active"++setAttrib :: ShaderProgram -> String -> +             IntegerHandling -> VertexArrayDescriptor a -> IO ()+setAttrib sp name = maybe (\_ _ -> putStrLn warn >> return ())+                          (\(a,_) -> let vap = vertexAttribPointer a+                                     in \ih vad -> (($= (ih, vad)) vap))+                          (lookup name $ attribs sp)+  where warn = "WARNING: attrib "++name++" is not active"++getAttrib :: ShaderProgram -> String -> AttribLocation+getAttrib sp n = maybe (error msg) fst . lookup n $ attribs sp+  where msg = "Attrib "++show n++" is not active"++enableAttrib :: ShaderProgram -> String -> IO ()+enableAttrib sp name = maybe (return ())+                             (($= Enabled) . vertexAttribArray . fst)+                             (lookup name $ attribs sp)

@@ -1,10 +1,20 @@ -- |Utilities for working with fragment and vertex shader programs.-module Graphics.GLUtil.Shaders (loadShader, linkShaderProgram, namedUniform, +module Graphics.GLUtil.Shaders (loadShader, loadGeoShader,+                                linkShaderProgram,+                                linkShaderProgramWith, +                                linkGeoProgram, linkGeoProgramWith,+                                namedUniform,                                  uniformScalar, uniformVec, uniformMat,                                  namedUniformMat, uniformGLMat4) where-import Control.Monad (unless)+import Control.Applicative ((<$>))+import Control.Monad (unless, replicateM)+import Foreign.C.String (peekCStringLen, withCStringLen)+import Foreign.Marshal.Alloc (alloca, allocaBytes)+import Foreign.Marshal.Array (withArray)+import Foreign.Storable (peek) import Graphics.Rendering.OpenGL import Graphics.Rendering.OpenGL.Raw.Core31+import Graphics.Rendering.OpenGL.Raw.ARB.GeometryShader4 import Graphics.GLUtil.GLError import Foreign.Ptr (Ptr) import Unsafe.Coerce (unsafeCoerce)@@ -29,11 +39,76 @@     ioError (userError "shader compilation failed")   return shader +-- |Specialized loading for geometry shaders that are not yet fully+-- supported by the Haskell OpenGL package.+loadGeoShader :: FilePath -> IO GeometryShader+loadGeoShader filePath = do+  src <- readFile filePath+  [shader@(GeometryShader gid)] <- genObjectNames 1+  setSource gid src+  glCompileShader gid+  printError+  ok <- alloca $ \buf -> do+          glGetShaderiv gid gl_COMPILE_STATUS buf+          fmap (> 0) (peek buf)+  infoLogLen <- alloca $ \ptr -> do glGetShaderiv gid gl_INFO_LOG_LENGTH ptr+                                    peek ptr+  infoLog <- alloca $ \len ->+               allocaBytes (fromIntegral infoLogLen) $ \chars -> do +                 glGetShaderInfoLog gid infoLogLen len chars+                 len' <- fromIntegral <$> peek len+                 peekCStringLen (chars, len')+  unless (null infoLog)+         (mapM_ putStrLn +                ["Shader info log for '" ++ filePath ++ "':", infoLog, ""])+  unless ok $ do+    deleteObjectNames [shader]+    ioError (userError "shader compilation failed")+  return shader+  where setSource i src = +          do withCStringLen src $ \(charBuf,len)-> do+               withArray [charBuf] $ \charBufsBuf ->+                 withArray [fromIntegral len] $ \lengthsBuf ->+                   glShaderSource i 1 charBufsBuf lengthsBuf++ -- |Link vertex and fragment shaders into a 'Program'. linkShaderProgram :: [VertexShader] -> [FragmentShader] -> IO Program-linkShaderProgram vs fs = do+linkShaderProgram vs fs = linkShaderProgramWith vs fs (\_ -> return ())++-- |Link vertex and fragment shaders into a 'Program'. The supplied+-- 'IO' action is run after attaching shader objects to the new+-- program, but before linking. This supports the use of+-- 'bindFragDataLocation' to map fragment shader outputs.+linkShaderProgramWith :: [VertexShader] -> [FragmentShader]+                      -> (Program -> IO ()) -> IO Program+linkShaderProgramWith vs fs m = linkGeoProgramWith vs [] fs m++newtype GeometryShader = GeometryShader { geometryShaderID :: GLuint }+  deriving (Eq,Ord,Show)++instance ObjectName GeometryShader where+  genObjectNames n = replicateM n $ +                     fmap GeometryShader (glCreateShader gl_GEOMETRY_SHADER)+  deleteObjectNames = mapM_ (glDeleteShader . geometryShaderID)+  isObjectName = fmap (> 0) . glIsShader . geometryShaderID++-- |Link vertex, geometry, and fragment shaders into a 'Program'.+linkGeoProgram :: [VertexShader] -> [GeometryShader] -> [FragmentShader]+               -> IO Program+linkGeoProgram vs gs fs = linkGeoProgramWith vs gs fs (\_ -> return ())++-- |Link vertex, geometry, and fragment shaders into a 'Program'. The+-- supplied 'IO' action is run after attaching shader objects to the+-- new program, but before linking. This supports the use of+-- 'bindFragDataLocation' to map fragment shader outputs.+linkGeoProgramWith :: [VertexShader] -> [GeometryShader] -> [FragmentShader]+                   -> (Program -> IO ()) -> IO Program+linkGeoProgramWith vs gs fs m = do   [prog] <- genObjectNames 1   attachedShaders prog $= (vs, fs)+  mapM_ (glAttachShader (unsafeCoerce prog) . geometryShaderID) gs+  m prog   linkProgram prog   printError   ok <- get (linkStatus prog)

@@ -2,8 +2,11 @@              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 Graphics.Rendering.OpenGL.Raw.Core31 (glGenerateMipmap,+                                             gl_TEXTURE_2D, gl_TEXTURE_CUBE_MAP) import Data.Array.Storable (StorableArray, withStorableArray) import Data.ByteString.Internal (ByteString, toForeignPtr) import Data.Vector.Storable (Vector, unsafeWith)@@ -11,8 +14,9 @@ import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr, plusPtr, castPtr) import Foreign.Marshal.Array (withArray)-import Foreign.Storable (Storable) +import Graphics.GLUtil.TypeMapping (HasGLType(..))+ -- |Pixel format of image data. data TexColor = TexMono | TexRGB | TexBGR | TexRGBA @@ -27,15 +31,6 @@ texInfo :: Int -> Int -> TexColor -> a -> TexInfo a texInfo w h = TexInfo (fromIntegral w) (fromIntegral h) --- |Open mapping from Haskell types to OpenGL types.-class Storable a => HasGLType a where-  glType :: a -> DataType--instance HasGLType Int where glType _ = GL.Int-instance HasGLType Word8 where glType _ = GL.UnsignedByte-instance HasGLType Word16 where glType _ = GL.UnsignedShort-instance HasGLType Float where glType _ = GL.Float- -- |Class for containers of texture data. class HasGLType (Elem a) => IsPixelData a where   type Elem a@@ -78,7 +73,7 @@                            m (plusPtr (castPtr p :: Ptr Word16) o)  -- |Create a new 2D texture with data from a 'TexInfo'.-loadTexture :: IsPixelData a => TexInfo a -> IO (TextureObject)+loadTexture :: IsPixelData a => TexInfo a -> IO TextureObject loadTexture tex = do [obj] <- genObjectNames 1                      reloadTexture obj tex                      return obj@@ -90,7 +85,9 @@                            loadTex $ texColor tex   where loadTex TexMono = case pixelType of                             GL.UnsignedShort -> loadAux Luminance16 Luminance+                            GL.Float         -> loadAux R32F Red                             _                -> loadAux Luminance' Luminance+                                     loadTex TexRGB = loadAux RGBA' RGB         loadTex TexBGR = loadAux RGBA' BGR         loadTex TexRGBA = loadAux RGBA' RGBA@@ -99,3 +96,44 @@         loadAux i e = withPixels (texData tex) $                        (texImage2D Nothing NoProxy 0 i sz 0 .                        PixelData e pixelType)++-- | Set texture coordinate wrapping options for both the 'S' and 'T'+-- dimensions of a 2D texture.+texture2DWrap :: StateVar (Repetition, Clamping)+texture2DWrap = makeStateVar (get (textureWrapMode Texture2D S))+                             (forM_ [S,T] . aux)+  where aux x d = textureWrapMode Texture2D d $= x++-- | Set texture coordinate wrapping options for the 'S', 'T', and 'R'+-- dimensions of a 3D texture.+texture3DWrap :: StateVar (Repetition, Clamping)+texture3DWrap = makeStateVar (get (textureWrapMode Texture2D S))+                             (forM_ [S,T,R] . aux)+  where aux x d = textureWrapMode Texture2D d $= x+++-- | Bind each of the given textures to successive texture units at+-- the given 'TextureTarget'.+withTextures :: TextureTarget -> [TextureObject] -> IO a -> IO a+withTextures tt ts m = do mapM_ aux (zip ts [0..])+                          r <- m+                          cleanup 0 ts+                          return r+  where aux (t,i) = do activeTexture $= TextureUnit i+                       textureBinding tt $= Just t+        cleanup _ [] = return ()+        cleanup i (_:ts') = do activeTexture $= TextureUnit i+                               textureBinding Texture2D $= Nothing+                               cleanup (i+1) ts'++-- | Bind each of the given 2D textures to successive texture units.+withTextures2D :: [TextureObject] -> IO a -> IO a+withTextures2D = withTextures Texture2D++-- | Generate a complete set of mipmaps for the currently bound+-- texture object.+generateMipmap' :: TextureTarget -> IO ()+generateMipmap' Texture2D = glGenerateMipmap gl_TEXTURE_2D+generateMipmap' TextureCubeMap = glGenerateMipmap gl_TEXTURE_CUBE_MAP+generateMipmap' _ = error $ "generateMipmap' is only defined for "+++                            "2D textures and cube maps."

@@ -0,0 +1,89 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+-- |This module contains classes and functions to relate Haskell types+-- with OpenGL DataTypes (typically used to describe the values stored+-- in arrays) and VariableTypes (used as attributes and uniforms in+-- GLSL programs).+module Graphics.GLUtil.TypeMapping where+import Data.Int+import Data.Word+import Foreign.Storable (Storable)+import qualified Graphics.Rendering.OpenGL as GL+import Graphics.Rendering.OpenGL+import Linear (V2, V3, V4, M22, M33, M44)++class HasVariableType a where+  variableType :: a -> VariableType++instance HasVariableType Float where variableType _ = Float'+instance HasVariableType GLfloat where variableType _ = Float'+instance HasVariableType GLint where variableType _ = Int'+instance HasVariableType Int32 where variableType _ = Int'+instance HasVariableType Word32 where variableType _ = UnsignedInt'+instance HasVariableType GLuint where variableType _ = UnsignedInt'++instance HasVariableType (V2 GLfloat) where variableType _ = FloatVec2+instance HasVariableType (V3 GLfloat) where variableType _ = FloatVec3+instance HasVariableType (V4 GLfloat) where variableType _ = FloatVec4++instance HasVariableType (V2 GLint) where variableType _ = IntVec2+instance HasVariableType (V3 GLint) where variableType _ = IntVec3+instance HasVariableType (V4 GLint) where variableType _ = IntVec4++instance HasVariableType (V2 Int32) where variableType _ = IntVec2+instance HasVariableType (V3 Int32) where variableType _ = IntVec3+instance HasVariableType (V4 Int32) where variableType _ = IntVec4++instance HasVariableType (V2 Word32) where variableType _ = UnsignedIntVec2+instance HasVariableType (V3 Word32) where variableType _ = UnsignedIntVec3+instance HasVariableType (V4 Word32) where variableType _ = UnsignedIntVec4++instance HasVariableType (V2 GLuint) where variableType _ = UnsignedIntVec2+instance HasVariableType (V3 GLuint) where variableType _ = UnsignedIntVec3+instance HasVariableType (V4 GLuint) where variableType _ = UnsignedIntVec4++instance HasVariableType (M22 GLfloat) where variableType _ = FloatMat2+instance HasVariableType (M33 GLfloat) where variableType _ = FloatMat3+instance HasVariableType (M44 GLfloat) where variableType _ = FloatMat4++-- | Maps each 'VariableType' to its corresponding+-- 'DataType'. Typically this indicates the element type of composite+-- variable types (e.g. @variableDataType FloatVec2 = Float@). Note+-- that this is a partial mapping as we are primarily supporting the+-- use of these types as inputs to GLSL programs where types such as+-- Bool are not supported.+variableDataType :: VariableType -> DataType+variableDataType Float' = GL.Float+variableDataType FloatVec2 = GL.Float+variableDataType FloatVec3 = GL.Float+variableDataType FloatVec4 = GL.Float+variableDataType Int' = GL.Int+variableDataType IntVec2 = GL.Int+variableDataType IntVec3 = GL.Int+variableDataType IntVec4 = GL.Int+variableDataType UnsignedInt' = GL.UnsignedInt+variableDataType UnsignedIntVec2 = GL.UnsignedInt+variableDataType UnsignedIntVec3 = GL.UnsignedInt+variableDataType UnsignedIntVec4 = GL.UnsignedInt+variableDataType FloatMat2 = GL.Float+variableDataType FloatMat3 = GL.Float+variableDataType FloatMat4 = GL.Float+variableDataType FloatMat2x3 = GL.Float	+variableDataType FloatMat2x4 = GL.Float	 +variableDataType FloatMat3x2 = GL.Float	 +variableDataType FloatMat3x4 = GL.Float	 +variableDataType FloatMat4x2 = GL.Float	 +variableDataType FloatMat4x3 = GL.Float+variableDataType _ = error "Unsupported variable type!"++-- |Open mapping from Haskell types to OpenGL types.+class Storable a => HasGLType a where+  glType :: a -> DataType++instance HasGLType Int where glType _ = GL.Int+instance HasGLType GLint where glType _ = GL.Int+instance HasGLType Word8 where glType _ = GL.UnsignedByte+instance HasGLType Word16 where glType _ = GL.UnsignedShort+instance HasGLType Word32 where glType _ = GL.UnsignedInt+instance HasGLType GLuint where glType _ = GL.UnsignedInt+instance HasGLType Float where glType _ = GL.Float+instance HasGLType GLfloat where glType _ = GL.Float

@@ -1,36 +1,24 @@ -- | A thin layer over OpenGL 3.1+ vertex array objects.-module Graphics.GLUtil.VertexArrayObjects -  (VertexArrayObject(..), VAO, makeVAO, deleteVAO, bindVertexArray) where-import Foreign.Marshal.Array (allocaArray)-import Foreign.Marshal.Utils (with)-import Foreign.Storable (peek)-import Graphics.Rendering.OpenGL.Raw.Core31---- |A vertex array object captures OpenGL state needed for drawing a--- vertex array. It encapsulates the binding of an array buffer and an--- element buffer, as well as vertex attribute setup.-newtype VertexArrayObject = VertexArrayObject GLuint+module Graphics.GLUtil.VertexArrayObjects (makeVAO, withVAO, VAO) where+import Control.Applicative+import Graphics.Rendering.OpenGL --- |Short alias.+-- |Short alias for 'VertexArrayObject'. type VAO = VertexArrayObject  -- |Allocate a 'VertexArrayObject', and initialize it with the -- provided action. This action should bind the buffer data, index -- data (if necessary), and setup vertex attributes. makeVAO :: IO () -> IO VertexArrayObject-makeVAO m = do vao <- allocaArray 1 $ \ptr -> -                        glGenVertexArrays 1 ptr >> peek ptr-               glBindVertexArray vao-               m-               glBindVertexArray 0-               return $ VertexArrayObject vao---- |Delete a 'VertexArrayObject'. Do not use the VAO after running--- this action!-deleteVAO :: VertexArrayObject -> IO ()-deleteVAO (VertexArrayObject i) = with i $ glDeleteVertexArrays 1+makeVAO setup = do [vao] <- genObjectNames 1+                   bindVertexArrayObject $= Just vao+                   setup+                   bindVertexArrayObject $= Nothing+                   return vao --- |Bind a 'VertexArrayObject', or ensure that no VAO is bound.-bindVertexArray :: Maybe VertexArrayObject -> IO ()-bindVertexArray (Just (VertexArrayObject i)) = glBindVertexArray i-bindVertexArray Nothing = glBindVertexArray 0+-- |Run an action with the given 'VertexArrayObject' bound.+withVAO :: VertexArrayObject -> IO r -> IO r+withVAO vao useIt = do bindVertexArrayObject $= Just vao+                       r <- useIt+                       bindVertexArrayObject $= Nothing+                       return r

@@ -0,0 +1,9 @@+module Graphics.GLUtil.Viewport where+import Graphics.Rendering.OpenGL++withViewport :: Position -> Size -> IO a -> IO a+withViewport p s m = do oldVP <- get viewport+                        viewport $= (p,s)+                        r <- m+                        viewport $= oldVP+                        return r