packages feed

lowgl 0.2.0.0 → 0.2.0.1

raw patch · 16 files changed

+1416/−2 lines, 16 files

Files

+ Graphics/GL/Low/Blending.hs view
@@ -0,0 +1,127 @@+-- | When blending is enabled, colors written to the color buffer will be+-- blended using a formula with the color already there. The three options+-- for the formula are:+--+-- - S*s + D*d ('FuncAdd', the default)+-- - S*s - D*d ('FuncSubtract')+-- - D*d - S*s ('FuncReverseSubtract')+--+-- where S and D are source and destination color components respectively. The+-- factors s and d are computed blending factors which can depend on the alpha+-- component of the source pixel, the destination pixel, or a specified+-- constant color. See 'basicBlending' for a common choice.+--+-- The order of rendering matters when using blending. The farther-away+-- primitives should be rendered first to get transparent materials to look+-- right. This means a depth test is unhelpful when using blending. Also+-- blending many layers of transparent primitives can significantly degrade+-- performance. For these reasons transparency effects may be better+-- accomplished with an off-screen rendering pass followed by a suitable+-- shader.+--+-- @+-- blending example program here+-- @++module Graphics.GL.Low.Blending where++import Data.Default+import Graphics.GL++import Graphics.GL.Low.Classes++-- | Enable blending with the specified blending parameters.+enableBlending :: Blending -> IO ()+enableBlending (Blending s d f (r,g,b,a)) = do+  glBlendFunc (toGL s) (toGL d)+  glBlendEquation (toGL f)+  let c = realToFrac+  glBlendColor (c r) (c g) (c b) (c a)+  glEnable GL_BLEND++-- | Disable alpha blending.+disableBlending :: IO ()+disableBlending = glDisable GL_BLEND++-- | This blending configuration is suitable for ordinary alpha blending+-- transparency effects.+--+-- @+-- Blending+--   { sFactor   = BlendSourceAlpha+--   , dFactor   = BlendOneMinusSourceAlpha+--   , blendFunc = FuncAdd }+-- @+basicBlending :: Blending+basicBlending = def+  { sFactor = BlendSourceAlpha+  , dFactor = BlendOneMinusSourceAlpha }+++-- | Blending parameters.+data Blending = Blending+  { sFactor :: BlendFactor+  , dFactor :: BlendFactor+  , blendFunc :: BlendEquation+  , blendColor :: (Float,Float,Float,Float) }++-- | The default blending parameters have no effect if enabled. The result+-- will be no blending effect.+instance Default Blending where+  def = Blending+    { sFactor = BlendOne+    , dFactor = BlendZero+    , blendFunc = FuncAdd+    , blendColor = (0,0,0,0) }++-- | Blending functions.+data BlendEquation =+  FuncAdd | -- ^ the default+  FuncSubtract |+  FuncReverseSubtract+    deriving Show++instance Default BlendEquation where+  def = FuncAdd++instance ToGL BlendEquation where+  toGL FuncAdd = GL_FUNC_ADD+  toGL FuncSubtract = GL_FUNC_SUBTRACT+  toGL FuncReverseSubtract = GL_FUNC_REVERSE_SUBTRACT+++-- | Blending factors.+data BlendFactor =+  BlendOne |+  BlendZero |+  BlendSourceColor |+  BlendOneMinusSourceColor |+  BlendDestColor |+  BlendOneMinusDestColor |+  BlendSourceAlpha |+  BlendOneMinusSourceAlpha |+  BlendDestAlpha |+  BlendOneMinusDestAlpha |+  BlendConstantColor |+  BlendOneMinusConstantColor |+  BlendConstantAlpha |+  BlendOneMinusConstantAlpha+    deriving Show++instance ToGL BlendFactor where+  toGL BlendOne = GL_ONE+  toGL BlendZero = GL_ZERO+  toGL BlendSourceColor = GL_SRC_COLOR+  toGL BlendOneMinusSourceColor = GL_ONE_MINUS_SRC_COLOR+  toGL BlendDestColor = GL_DST_COLOR+  toGL BlendOneMinusDestColor = GL_ONE_MINUS_DST_COLOR+  toGL BlendSourceAlpha = GL_SRC_ALPHA+  toGL BlendOneMinusSourceAlpha = GL_ONE_MINUS_SRC_ALPHA+  toGL BlendDestAlpha = GL_DST_ALPHA+  toGL BlendOneMinusDestAlpha = GL_ONE_MINUS_DST_ALPHA+  toGL BlendConstantColor = GL_ONE_MINUS_CONSTANT_COLOR+  toGL BlendOneMinusConstantColor = GL_ONE_MINUS_CONSTANT_COLOR+  toGL BlendConstantAlpha = GL_CONSTANT_ALPHA+  toGL BlendOneMinusConstantAlpha = GL_ONE_MINUS_CONSTANT_ALPHA++
+ Graphics/GL/Low/BufferObject.hs view
@@ -0,0 +1,123 @@+-- | VBO and ElementArrays. Both are buffer objects but are used for two+-- different things.+module Graphics.GL.Low.BufferObject (+  VBO,+  ElementArray,+  UsageHint(..),+  newVBO,+  updateVBO,+  bindVBO,+  newElementArray,+  updateElementArray,+  bindElementArray,+  deleteBufferObject+) where++import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable+import qualified Data.Vector.Storable as V+import Data.Vector.Storable (Vector)+import Data.Word++import Graphics.GL++import Graphics.GL.Low.Classes++-- | A VBO is a buffer object which has vertex data. Shader programs use VBOs+-- as input to their vertex attributes according to the configuration of the+-- bound VAO.+data VBO = VBO GLuint deriving Show++-- | A buffer object which has a packed sequence of vertex indices. Indexed+-- rendering uses the ElementArray bound to the element array binding target.+data ElementArray = ElementArray GLuint deriving Show++-- | Usage hint for allocation of buffer object storage.+data UsageHint = StaticDraw  -- ^ Data will seldomly change.+               | DynamicDraw -- ^ Data will change.+               | StreamDraw  -- ^ Data will change very often.+                 deriving Show++instance ToGL UsageHint where+  toGL StaticDraw  = GL_STATIC_DRAW+  toGL DynamicDraw = GL_DYNAMIC_DRAW+  toGL StreamDraw  = GL_STREAM_DRAW++instance GLObject VBO where+  glObjectName (VBO n) = fromIntegral n++instance GLObject ElementArray where+  glObjectName (ElementArray n) = fromIntegral n++instance BufferObject VBO++instance BufferObject ElementArray+++-- | Create a buffer object from a blob of bytes. The usage argument hints+-- at how often you will modify the data.+newVBO :: Vector Word8 -> UsageHint -> IO VBO+newVBO src usage = do+  n <- alloca (\ptr -> glGenBuffers 1 ptr >> peek ptr)+  let len = V.length src+  glBindBuffer GL_ARRAY_BUFFER n+  V.unsafeWith src $ \ptr -> glBufferData+    GL_ARRAY_BUFFER+    (fromIntegral len)+    (castPtr ptr)+    (toGL usage)+  return (VBO n)++-- | Delete a VBO or ElementArray.+deleteBufferObject :: BufferObject a => a -> IO ()+deleteBufferObject bo = withArray [glObjectName bo] (\ptr -> glDeleteBuffers 1 ptr)++-- | Modify the data in the currently bound VBO starting from the specified+-- index in bytes.+updateVBO :: Vector Word8 -> Int -> IO ()+updateVBO src offset = do+  let len = V.length src+  V.unsafeWith src $ \ptr -> glBufferSubData+    GL_ARRAY_BUFFER +    (fromIntegral offset)+    (fromIntegral len)+    (castPtr ptr)++-- | Bind a VBO to the array buffer binding target. The buffer object bound+-- there will be replaced, if any.+bindVBO :: VBO -> IO ()+bindVBO (VBO n) = glBindBuffer GL_ARRAY_BUFFER n+++-- | Create a new ElementArray buffer object from the blob of packed indices.+-- The usage argument hints at how often you plan to modify the data.+newElementArray :: Vector Word8 -> UsageHint -> IO ElementArray+newElementArray bytes usage = do+  n <- alloca (\ptr -> glGenBuffers 1 ptr >> peek ptr)+  glBindBuffer GL_ELEMENT_ARRAY_BUFFER n+  let len = V.length bytes+  V.unsafeWith bytes $ \ptr -> do+    glBufferData+      GL_ELEMENT_ARRAY_BUFFER+      (fromIntegral len)+      (castPtr ptr)+      (toGL usage)+  return (ElementArray n)++-- | Modify contents in the currently bound ElementArray starting at the+-- specified index in bytes.+updateElementArray :: Vector Word8 -> Int -> IO ()+updateElementArray bytes offset = V.unsafeWith bytes $ \ptr -> do+  glBufferSubData+    GL_ELEMENT_ARRAY_BUFFER+    (fromIntegral offset)+    (fromIntegral (V.length bytes))+    (castPtr ptr)+++-- | Assign an ElementArray to the element array binding target. It will+-- replace the ElementArray already bound there, if any. Note that the state+-- of the element array binding target is a function of the current VAO.+bindElementArray :: ElementArray -> IO ()+bindElementArray (ElementArray n) = glBindBuffer GL_ELEMENT_ARRAY_BUFFER n
+ Graphics/GL/Low/Classes.hs view
@@ -0,0 +1,31 @@+module Graphics.GL.Low.Classes where++import Graphics.GL++-- | OpenGL internal image formats.+class InternalFormat a where+  internalFormat :: (Eq b, Num b) => proxy a -> b++-- | The allowed attachment point for images with an internal format.+class InternalFormat a => Attachable a where+  attachPoint :: (Eq b, Num b) => proxy a -> b++-- | Textures are GL objects.+class GLObject a => Texture a where++-- | Framebuffers can be bound to the framebuffer binding target. There is+-- a default framebuffer and the client may create an arbitrary number of+-- new framebuffer objects.+class Framebuffer a where+  framebufferName :: Num b => a -> b++class GLObject a => BufferObject a where++-- | Mappable to GL enums.+class ToGL a where+  toGL :: (Num b, Eq b) => a -> b++-- | All GL objects have some numeric name.+class GLObject a where+  glObjectName :: Num b => a -> b+
+ Graphics/GL/Low/Color.hs view
@@ -0,0 +1,19 @@+module Graphics.GL.Low.Color where++import Graphics.GL++-- | Allow rendering commands to modify the color buffer of the current+-- framebuffer.+enableColorWriting :: IO ()+enableColorWriting = glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE++-- | Disable rendering to color buffer.+disableColorWriting :: IO ()+disableColorWriting = glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE++-- | Clear the color buffer of the current framebuffer with the specified+-- color. Has no effect if writing to the color buffer is disabled.+clearColorBuffer :: (Float, Float, Float) -> IO ()+clearColorBuffer (r, g, b) = do+  glClearColor (realToFrac r) (realToFrac g) (realToFrac b) 1.0+  glClear GL_COLOR_BUFFER_BIT
+ Graphics/GL/Low/Cube.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+module Graphics.GL.Low.Cube where++import Data.Functor+import Data.Foldable+import Control.Applicative+import Data.Traversable+import Data.Monoid++-- | Six values, one on each side.+data Cube a = Cube+  { cubeRight  :: a+  , cubeLeft   :: a+  , cubeTop    :: a+  , cubeBottom :: a+  , cubeFront  :: a+  , cubeBack   :: a }+    deriving (Show, Functor, Foldable, Traversable)++-- | A type to pick one of the sides of a cube. See the accessors of the+-- type 'Cube'.+type Side = forall a . Cube a -> a++instance Applicative Cube where+  pure x = Cube x x x x x x+  (Cube f1 f2 f3 f4 f5 f6) <*> (Cube x1 x2 x3 x4 x5 x6) =+    Cube (f1 x1) (f2 x2) (f3 x3) (f4 x4) (f5 x5) (f6 x6)++instance Monoid a => Monoid (Cube a) where+  mempty = Cube mempty mempty mempty mempty mempty mempty+  (Cube x1 x2 x3 x4 x5 x6) `mappend` (Cube y1 y2 y3 y4 y5 y6) = Cube+    (x1 <> y1)+    (x2 <> y2)+    (x3 <> y3)+    (x4 <> y4)+    (x5 <> y5)+    (x6 <> y6)+
+ Graphics/GL/Low/Depth.hs view
@@ -0,0 +1,17 @@+module Graphics.GL.Low.Depth where++import Graphics.GL++-- | Enable the depth test. Attempting to render pixels with a depth value+-- greater than the depth buffer at those pixels will have no effect. Otherwise+-- the depth in the buffer will get updated to the new pixel's depth.+enableDepthTest :: IO ()+enableDepthTest = glEnable GL_DEPTH_TEST++-- | Disable the depth test and depth buffer updates.+disableDepthTest :: IO ()+disableDepthTest = glDisable GL_DEPTH_TEST++-- | Clear the depth buffer with the maximum depth value.+clearDepthBuffer :: IO ()+clearDepthBuffer = glClear GL_DEPTH_BUFFER_BIT
+ Graphics/GL/Low/Error.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternSynonyms #-}+module Graphics.GL.Low.Error where++import Control.Exception+import Data.Typeable++import Graphics.GL++-- | Detectable errors.+data GLError =+  InvalidEnum | -- ^ Enum argument out of range.+  InvalidValue | -- ^ Integer argument out of range.+  InvalidOperation | -- ^ Operation illegal in current state.+  InvalidFramebufferOperation | -- ^ Framebuffer is not complete.+  OutOfMemory+    deriving Typeable++instance Exception GLError++instance Show GLError where+  show InvalidEnum = "INVALID_ENUM enum argument out of range"+  show InvalidValue = "INVALID_VALUE Numeric argument out of range"+  show InvalidOperation = "INVALID_OPERATION Illegal in current state"+  show InvalidFramebufferOperation = "INVALID_FRAMEBUFFER_OPERATION Framebuffer object is not complete"+  show OutOfMemory = "Not enough memory left to execute command"++-- | Check for a GL Error.+getGLError :: IO (Maybe GLError)+getGLError = do+  n <- glGetError+  return $ case n of+    GL_NO_ERROR -> Nothing+    GL_INVALID_ENUM -> Just InvalidEnum+    GL_INVALID_VALUE -> Just InvalidValue+    GL_INVALID_OPERATION -> Just InvalidOperation+    GL_INVALID_FRAMEBUFFER_OPERATION -> Just InvalidFramebufferOperation+    GL_OUT_OF_MEMORY -> Just OutOfMemory+    _ -> error ("unknown GL error " ++ show n)
+ Graphics/GL/Low/Framebuffer.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE RankNTypes #-}+module Graphics.GL.Low.Framebuffer (+  FBO,+  RBO,+  DefaultFramebuffer,+  bindFramebuffer,+  newFBO,+  deleteFBO,+  attachTex2D,+  attachCubeMap,+  attachRBO,+  newRBO,+  deleteRBO+) where++import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable++import Data.Default+import Graphics.GL++import Graphics.GL.Low.Classes+import Graphics.GL.Low.Common+import Graphics.GL.Low.Cube+import Graphics.GL.Low.Texture+++-- | A framebuffer object is an alternative rendering destination. Once an FBO+-- is bound to framebuffer binding target, it is possible to attach images+-- (textures or RBOs) for color, depth, or stencil rendering.+newtype FBO = FBO GLuint deriving Show++-- | An RBO is a kind of image object used for rendering. The only thing+-- you can do with an RBO is attach it to an FBO.+data RBO a = RBO { unRBO :: GLuint } deriving Show++-- | The default framebuffer. Bind this to render to the screen as usual.+-- Use the Default instance method 'def' to construct it.+data DefaultFramebuffer = DefaultFramebuffer deriving Show++instance Default DefaultFramebuffer where+  def = DefaultFramebuffer++instance Framebuffer DefaultFramebuffer where+  framebufferName _ = 0++instance Framebuffer FBO where+  framebufferName = glObjectName++instance GLObject FBO where+  glObjectName (FBO n) = fromIntegral n++instance GLObject (RBO a) where+  glObjectName (RBO n) = fromIntegral n++-- | Binds an FBO or the default framebuffer to the framebuffer binding target.+-- Replaces the framebuffer already bound there.+bindFramebuffer :: Framebuffer a => a -> IO ()+bindFramebuffer x = glBindFramebuffer GL_FRAMEBUFFER (framebufferName x)++-- | Create a new framebuffer object. Before the framebuffer can be used for+-- rendering it must have a color image attachment.+newFBO :: IO FBO+newFBO = do+  n <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)+  return (FBO n)++-- | Delete an FBO.+deleteFBO :: FBO -> IO ()+deleteFBO (FBO n) = withArray [n] (\ptr -> glDeleteFramebuffers 1 ptr)++-- | Attach a 2D texture to the FBO currently bound to the+-- framebuffer binding target.+attachTex2D :: Attachable a => Tex2D a -> IO ()+attachTex2D tex =+  glFramebufferTexture2D+    GL_FRAMEBUFFER+    (attachPoint tex)+    GL_TEXTURE_2D+    (glObjectName tex)+    0++-- | Attach one of the sides of a cubemap texture to the FBO currently bound+-- to the framebuffer binding target.+attachCubeMap :: Attachable a => CubeMap a -> Side -> IO ()+attachCubeMap cm side =+  glFramebufferTexture2D+    GL_FRAMEBUFFER+    (attachPoint cm)+    (side cubeSideCodes)+    (glObjectName cm)+    0++-- | Attach an RBO to the FBO currently bound to the framebuffer binding+-- target.+attachRBO :: Attachable a => RBO a -> IO ()+attachRBO rbo = glFramebufferRenderbuffer+  GL_FRAMEBUFFER (attachPoint rbo) GL_RENDERBUFFER (unRBO rbo)++-- | Create a new renderbuffer with the specified dimensions.+newRBO :: InternalFormat a => Int -> Int -> IO (RBO a)+newRBO w h = do+  n <- alloca (\ptr -> glGenRenderbuffers 1 ptr >> peek ptr)+  rbo <- return (RBO n)+  glBindRenderbuffer GL_RENDERBUFFER n+  glRenderbufferStorage+    GL_RENDERBUFFER+    (internalFormat rbo)+    (fromIntegral w)+    (fromIntegral h)+  return rbo++-- | Delete an RBO.+deleteRBO :: RBO a -> IO ()+deleteRBO (RBO n) = withArray [n] (\ptr -> glDeleteRenderbuffers 1 ptr)
+ Graphics/GL/Low/ImageFormat.hs view
@@ -0,0 +1,56 @@+module Graphics.GL.Low.ImageFormat where++import Graphics.GL++import Graphics.GL.Low.Classes++-- | 1-byte alpha channel only.+data Alpha = Alpha deriving Show++-- | 1-byte grayscale pixel format.+data Luminance = Luminance deriving Show++-- | 2-byte luminance and alpha channel format.+data LuminanceAlpha = Luminancealpha deriving Show++-- | 3-byte true color pixel format.+data RGB = RGB deriving Show++-- | 4-byte true color plus alpha channel format.+data RGBA = RGBA deriving Show++-- | 24-bit depth format.+data Depth24 = Depth24 deriving Show++-- | Combination depth and stencil format.+data Depth24Stencil8 = Depth24Stencil8 deriving Show++instance InternalFormat RGB where+  internalFormat _ = GL_RGB8+instance InternalFormat RGBA where+  internalFormat _ = GL_RGBA+instance InternalFormat Alpha where+  internalFormat _ = GL_ALPHA+instance InternalFormat Luminance where+  internalFormat _ = GL_LUMINANCE+instance InternalFormat LuminanceAlpha where+  internalFormat _ = GL_LUMINANCE_ALPHA+instance InternalFormat Depth24 where+  internalFormat _ = GL_DEPTH_COMPONENT24+instance InternalFormat Depth24Stencil8 where+  internalFormat _ = GL_DEPTH24_STENCIL8++instance Attachable RGB where+  attachPoint _ = GL_COLOR_ATTACHMENT0+instance Attachable RGBA where+  attachPoint _ = GL_COLOR_ATTACHMENT0+instance Attachable Luminance where+  attachPoint _ = GL_COLOR_ATTACHMENT0+instance Attachable LuminanceAlpha where+  attachPoint _ = GL_COLOR_ATTACHMENT0+instance Attachable Alpha where+  attachPoint _ = GL_COLOR_ATTACHMENT0+instance Attachable Depth24 where+  attachPoint _ = GL_DEPTH_ATTACHMENT+instance Attachable Depth24Stencil8 where+  attachPoint _ = GL_DEPTH_STENCIL_ATTACHMENT
+ Graphics/GL/Low/Render.hs view
@@ -0,0 +1,146 @@+module Graphics.GL.Low.Render (+  Culling(..),+  Viewport(..),+  IndexFormat(..),+  drawPoints,+  drawLines,+  drawLineStrip,+  drawLineLoop,+  drawTriangles,+  drawTriangleStrip,+  drawTriangleFan,+  drawIndexedPoints,+  drawIndexedLines,+  drawIndexedLineStrip,+  drawIndexedLineLoop,+  drawIndexedTriangles,+  drawIndexedTriangleStrip,+  drawIndexedTriangleFan,+  enableScissorTest,+  disableScissorTest,+  enableCulling,+  disableCulling,+  setViewport+) where++import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable++import Graphics.GL++import Graphics.GL.Low.Classes++-- | Facet culling modes.+data Culling =+  CullFront |+  CullBack |+  CullFrontAndBack+    deriving Show++instance ToGL Culling where+  toGL CullFront = GL_FRONT+  toGL CullBack = GL_BACK+  toGL CullFrontAndBack = GL_FRONT_AND_BACK++-- | A rectangular section of the window.+data Viewport = Viewport+  { viewportX :: Int+  , viewportY :: Int+  , viewportW :: Int+  , viewportH :: Int }+    deriving (Eq, Show)++-- | How indices are packed in an ElementArray buffer object.+data IndexFormat =+  UByteIndices  | -- ^ Each index is one unsigned byte.+  UShortIndices | -- ^ Each index is a two byte unsigned int.+  UIntIndices     -- ^ Each index is a four byte unsigned int.+    deriving Show++instance ToGL IndexFormat where+  toGL UByteIndices  = GL_UNSIGNED_BYTE+  toGL UShortIndices = GL_UNSIGNED_SHORT+  toGL UIntIndices   = GL_UNSIGNED_INT++++drawPoints :: Int -> IO ()+drawPoints = drawArrays GL_POINTS++drawLines :: Int -> IO ()+drawLines = drawArrays GL_LINES++drawLineStrip :: Int -> IO ()+drawLineStrip = drawArrays GL_LINE_STRIP++drawLineLoop :: Int -> IO ()+drawLineLoop = drawArrays GL_LINE_LOOP++drawTriangles :: Int -> IO ()+drawTriangles = drawArrays GL_TRIANGLES++drawTriangleStrip :: Int -> IO ()+drawTriangleStrip = drawArrays GL_TRIANGLE_STRIP++drawTriangleFan :: Int -> IO ()+drawTriangleFan = drawArrays GL_TRIANGLE_FAN++drawArrays :: GLenum -> Int -> IO ()+drawArrays mode n = glDrawArrays mode (fromIntegral n) 0++drawIndexedPoints :: Int -> IndexFormat -> IO ()+drawIndexedPoints = drawIndexed GL_POINTS++drawIndexedLines :: Int -> IndexFormat -> IO ()+drawIndexedLines = drawIndexed GL_LINES++drawIndexedLineStrip :: Int -> IndexFormat -> IO ()+drawIndexedLineStrip = drawIndexed GL_LINE_STRIP++drawIndexedLineLoop :: Int -> IndexFormat -> IO ()+drawIndexedLineLoop = drawIndexed GL_LINE_LOOP++drawIndexedTriangles :: Int -> IndexFormat -> IO ()+drawIndexedTriangles = drawIndexed GL_TRIANGLES++drawIndexedTriangleStrip :: Int -> IndexFormat -> IO ()+drawIndexedTriangleStrip = drawIndexed GL_TRIANGLE_STRIP++drawIndexedTriangleFan :: Int -> IndexFormat -> IO ()+drawIndexedTriangleFan = drawIndexed GL_TRIANGLE_FAN++drawIndexed :: GLenum -> Int -> IndexFormat -> IO ()+drawIndexed mode n fmt = glDrawElements mode (fromIntegral n) (toGL fmt) nullPtr++-- | Enable the scissor test. Graphics outside the scissor box will not be+-- rendered.+enableScissorTest :: Viewport -> IO ()+enableScissorTest (Viewport x y w h) = do+  glScissor (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)+  glEnable GL_SCISSOR_TEST++-- | Disable the scissor test.+disableScissorTest :: IO ()+disableScissorTest = glDisable GL_SCISSOR_TEST+++-- | Enable facet culling. The argument specifies whether front faces, back+-- faces, or both will be omitted from rendering. If both front and back+-- faces are culled you can still render points and lines.+enableCulling :: Culling -> IO ()+enableCulling c = do+  case c of+    CullFront -> glCullFace GL_FRONT+    CullBack -> glCullFace GL_BACK+    CullFrontAndBack -> glCullFace GL_FRONT_AND_BACK+  glEnable GL_CULL_FACE++-- | Disable facet culling. Front and back faces will now be rendered.+disableCulling :: IO ()+disableCulling = glDisable GL_CULL_FACE++-- | Set the viewport. The default viewport simply covers the entire window.+setViewport :: Viewport -> IO ()+setViewport (Viewport x y w h) =+  glViewport (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
+ Graphics/GL/Low/Shader.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Graphics.GL.Low.Shader (+  Program,+  ProgramError(..),+  newProgramSafe,+  deleteProgram,+  newProgram,+  useProgram,+  setUniform1f,+  setUniform2f,+  setUniform3f,+  setUniform4f,+  setUniform1i,+  setUniform2i,+  setUniform3i,+  setUniform4i,+  setUniform44,+  setUniform33,+  setUniform22+) where++import Foreign.Ptr+import Foreign.C.String+import Foreign.Marshal+import Foreign.Storable+import Control.Exception+import Control.Monad (when, forM_)+import Data.Typeable++import Graphics.GL+import Linear++import Graphics.GL.Low.Classes+import Graphics.GL.Low.VertexAttrib++-- | A Program object is the combination of a compiled vertex shader and fragment+-- shader. Programs have three kinds of inputs: vertex attributes, uniforms,+-- and samplers. Programs have two outputs: fragment color and fragment depth.+-- At most one program can be "in use" at a time. Same idea as binding targets+-- it's just not called that.+newtype Program = Program GLuint deriving Show++-- | Either a vertex shader or a fragment shader.+data ShaderType = VertexShader | FragmentShader deriving Show++instance ToGL ShaderType where+  toGL VertexShader = GL_VERTEX_SHADER+  toGL FragmentShader = GL_FRAGMENT_SHADER++-- | The error message emitted by the driver when shader compilation or+-- linkage fails.+data ProgramError =+  VertexShaderError String |+  FragmentShaderError String |+  LinkError String+    deriving (Show, Typeable)+  +instance Exception ProgramError++-- | Same as 'newProgram' but does not throw exceptions.+newProgramSafe :: String -> String -> IO (Either ProgramError Program)+newProgramSafe vcode fcode = try $ newProgram vcode fcode++-- | Delete a program.+deleteProgram :: Program -> IO ()+deleteProgram (Program n) = glDeleteProgram n++-- | Compile the code for a vertex shader and a fragment shader, then link+-- them into a new program. If the compiler or linker fails it will throw+-- a ProgramError.+newProgram :: String -- ^ vertex shader source code+           -> String -- ^ fragment shader source code+           -> IO Program+newProgram vcode fcode = do+  vertexShaderId <- compileShader vcode VertexShader+  fragmentShaderId <- compileShader fcode FragmentShader+  programId <- glCreateProgram+  glAttachShader programId vertexShaderId+  glAttachShader programId fragmentShaderId+  glLinkProgram programId+  result <- alloca $ \ptr ->+    glGetProgramiv programId GL_LINK_STATUS ptr >> peek ptr+  when (result == GL_FALSE) $ do+    len <- fmap fromIntegral $ alloca $ \ptr ->+      glGetProgramiv programId GL_INFO_LOG_LENGTH ptr >> peek ptr+    errors <- allocaArray len $ \ptr -> do+      glGetProgramInfoLog programId (fromIntegral len) nullPtr ptr+      peekCString ptr+    throwIO (LinkError errors)+  glDeleteShader vertexShaderId+  glDeleteShader fragmentShaderId+  return (Program programId)++-- | Install a program into the rendering pipeline. Replaces the program+-- already in use, if any.+useProgram :: Program -> IO ()+useProgram (Program n) = glUseProgram n++compileShader :: String -> ShaderType -> IO GLuint+compileShader code vertOrFrag = do+  shaderId <- glCreateShader (toGL vertOrFrag)+  withCString code $ \ptr -> with ptr $ \pptr -> do+    glShaderSource shaderId 1 pptr nullPtr+    glCompileShader shaderId+  result <- with GL_FALSE $ \ptr ->+    glGetShaderiv shaderId GL_COMPILE_STATUS ptr >> peek ptr+  when (result == GL_FALSE) $ do+    len <- fmap fromIntegral $ alloca $ \ptr ->+      glGetShaderiv shaderId GL_INFO_LOG_LENGTH ptr >> peek ptr+    errors <- allocaArray len $ \ptr -> do+      glGetShaderInfoLog shaderId (fromIntegral len) nullPtr ptr+      peekCString ptr+    case vertOrFrag of+      VertexShader -> throwIO (VertexShaderError errors)+      FragmentShader -> throwIO (FragmentShaderError errors)+  return shaderId++setUniform1f :: String -> [Float] -> IO ()+setUniform1f = setUniform glUniform1fv++setUniform2f :: String -> [V2 Float] -> IO ()+setUniform2f = setUniform+  (\loc cnt val -> glUniform2fv loc cnt (castPtr val))++setUniform3f :: String -> [V3 Float] -> IO ()+setUniform3f = setUniform+  (\loc cnt val -> glUniform3fv loc cnt (castPtr val))++setUniform4f :: String -> [V4 Float] -> IO ()+setUniform4f = setUniform+  (\loc cnt val -> glUniform4fv loc cnt (castPtr val))++setUniform1i :: String -> [Int] -> IO ()+setUniform1i = setUniform+  (\loc cnt val -> glUniform1iv loc cnt (castPtr val))++setUniform2i :: String -> [V2 Int] -> IO ()+setUniform2i = setUniform +  (\loc cnt val -> glUniform2iv loc cnt (castPtr val))++setUniform3i :: String -> [V3 Int] -> IO ()+setUniform3i = setUniform+  (\loc cnt val -> glUniform3iv loc cnt (castPtr val))++setUniform4i :: String -> [V4 Int] -> IO ()+setUniform4i = setUniform+  (\loc cnt val -> glUniform4iv loc cnt (castPtr val))++setUniform44 :: String -> [M44 Float] -> IO ()+setUniform44 = setUniform+  (\loc cnt val -> glUniformMatrix4fv loc cnt GL_FALSE (castPtr val))++setUniform33 :: String -> [M33 Float] -> IO ()+setUniform33 = setUniform+  (\loc cnt val -> glUniformMatrix3fv loc cnt GL_FALSE (castPtr val))++setUniform22 :: String -> [M22 Float] -> IO ()+setUniform22 = setUniform+  (\loc cnt val -> glUniformMatrix2fv loc cnt GL_FALSE (castPtr val))++setUniform :: Storable a+           => (GLint -> GLsizei -> Ptr a -> IO ())+           -> String+           -> [a]+           -> IO ()+setUniform glAction name xs = withArrayLen xs $ \n bytes -> do+  p <- alloca (\ptr -> glGetIntegerv GL_CURRENT_PROGRAM ptr >> peek ptr)+  if p == 0+    then return ()+    else do+      loc <- withCString name (\ptr -> glGetUniformLocation (fromIntegral p) ptr)+      if loc == -1+        then return ()+        else glAction loc (fromIntegral n) bytes++
+ Graphics/GL/Low/Stencil.hs view
@@ -0,0 +1,137 @@+-- | The stencil test is like a configurable depth test with a dedicated+-- additional buffer. Like the depth test, if the stencil test fails then the+-- pixel being tested will not be rendered. The stencil test happens before the+-- depth test, if it's enabled. For a given pixel, the stencil test passes if+-- the following computation+--+-- > (ref & mask) `stencilOp` (buf & mask)+--+-- computes true. The variables ref and mask are configurable constants, buf is+-- the value in the stencil buffer at the given pixel, and stencilOp is a+-- configurable comparison operation. The stencil op can also be set to pass+-- 'Always' or 'Never'.+--+-- The stencil buffer may be modified in various ways on the following events:+--+-- - When the stencil test fails or+-- - When the stencil test passes then the depth test fails or+-- - When both tests pass.+--+-- An example way of updating the stencil buffer is to write zero, or to write+-- the ref value mentioned above to the location being tested.+--+-- > example program here++module Graphics.GL.Low.Stencil where++import Data.Default+import Data.Bits+import Data.Word++import Graphics.GL+import Graphics.GL.Low.Classes++-- | Enable the stencil test with a set of operating parameters.+enableStencil :: Stencil -> IO ()+enableStencil (Stencil f r m op1 op2 op3) = do+  glStencilFunc (toGL f) (fromIntegral r) (fromIntegral m)+  glStencilOp (toGL op1) (toGL op2) (toGL op2)+  glEnable GL_STENCIL_TEST++-- | Disable the stencil test and updates to the stencil buffer, if one exists.+disableStencil :: IO ()+disableStencil = glDisable GL_STENCIL_TEST++-- | Clear the stencil buffer with all zeros.+clearStencilBuffer :: IO ()+clearStencilBuffer = glClear GL_STENCIL_BUFFER_BIT++-- | In this basic configuration of the stencil, anything rendered will+-- create a silhouette of 1s in the stencil buffer. Attempting to render a+-- second time into the silhouette will have no effect because the stencil+-- test will fail (ref=1 isn't greater than buffer=1).+--+-- @+-- def { func = Greater+--     , ref = 1+--     , onBothPass = Replace }+-- @+basicStencil :: Stencil+basicStencil = def+  { func = Greater+  , ref = 1+  , onBothPass = Replace }++-- | Configuration of the stencil test and associated stencil buffer updating.+data Stencil = Stencil+  { func          :: StencilFunc+  , ref           :: Int+  , mask          :: Word+  , onStencilFail :: StencilOp+  , onDepthFail   :: StencilOp+  , onBothPass    :: StencilOp }++-- | The default state of the stencil, if it were simply enabled, would be+-- to always pass and update nothing in the buffer. It would have no effect+-- on rendering.+instance Default Stencil where+  def = Stencil+    { func = Always+    , ref  = 0+    , mask = complement 0+    , onStencilFail = Keep+    , onDepthFail   = Keep+    , onBothPass    = Keep }++-- the proper implementation of toList f is the one that for any+-- g :: t a -> [a] you can make a unique k such that g = k . f+-- jle`+  +++-- | The stencil test passes under what condition.+data StencilFunc =+  Never |+  Less |+  LessOrEqual |+  Greater |+  GreaterOrEqual |+  Equal |+  NotEqual |+  Always+    deriving Show++instance ToGL StencilFunc where+  toGL x = case x of+    Never -> GL_NEVER+    Less -> GL_LESS+    LessOrEqual -> GL_LEQUAL+    Greater -> GL_GREATER+    GreaterOrEqual -> GL_GEQUAL+    Equal -> GL_EQUAL+    NotEqual -> GL_NOTEQUAL+    Always -> GL_ALWAYS+++-- | Modification action for the stencil buffer. +data StencilOp =+  Keep | -- ^ Do nothing.+  Zero | -- ^ Set to zero.+  Replace | -- ^ Write the ref value passed to enableStencil.+  Increment |+  Decrement |+  Invert | -- ^ Bitwise complement.+  IncrementWrap |+  DecrementWrap+    deriving Show++instance ToGL StencilOp where+  toGL x = case x of+    Keep -> GL_KEEP+    Zero -> GL_ZERO+    Replace -> GL_REPLACE+    Increment -> GL_INCR+    Decrement -> GL_DECR+    Invert -> GL_INVERT+    IncrementWrap -> GL_INCR_WRAP+    DecrementWrap -> GL_DECR_WRAP
+ Graphics/GL/Low/Texture.hs view
@@ -0,0 +1,206 @@+module Graphics.GL.Low.Texture (+  Tex2D,+  CubeMap,+  Filtering(..),+  Wrapping(..),+  Dimensions(..),+  newTexture2D,+  deleteTexture,+  newCubeMap,+  newEmptyTexture2D,+  newEmptyCubeMap,+  bindTexture2D,+  bindTextureCubeMap,+  setActiveTextureUnit,+  setTex2DFiltering,+  setCubeMapFiltering,+  setTex2DWrapping,+  setCubeMapWrapping+) where++import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable+import Data.Vector.Storable+import Data.Word+import Control.Applicative+import Data.Traversable++import Graphics.GL++import Graphics.GL.Low.Classes+import Graphics.GL.Low.Common+import Graphics.GL.Low.Cube++-- | A 2D texture. A program can sample a texture if it has been bound to+-- the appropriate texture unit.+newtype Tex2D a = Tex2D GLuint deriving Show++-- | A cubemap texture is just six 2D textures. A program can sample a cubemap+-- texture if it has been bound to the appropriate texture unit.+newtype CubeMap a = CubeMap GLuint deriving Show++-- | Texture filtering modes.+data Filtering =+  Nearest | -- ^ No interpolation.+  Linear    -- ^ Linear interpolation.+    deriving Show++instance ToGL Filtering where+  toGL Nearest = GL_NEAREST+  toGL Linear = GL_LINEAR++-- | Texture wrapping modes.+data Wrapping =+  Repeat         | -- ^ Tile the texture past the boundary.+  MirroredRepeat | -- ^ Tile the texture but mirror every other tile.+  ClampToEdge      -- ^ Use the edge color for anything past the boundary.+    deriving Show++instance ToGL Wrapping where+  toGL Repeat = GL_REPEAT+  toGL MirroredRepeat = GL_MIRRORED_REPEAT+  toGL ClampToEdge = GL_CLAMP_TO_EDGE++-- | The size of an image in pixels.+data Dimensions = Dimensions+  { imageWidth  :: Int+  , imageHeight :: Int }+    deriving (Show)++instance Texture (Tex2D a) where++instance Texture (CubeMap a) where++instance GLObject (Tex2D a) where+  glObjectName (Tex2D n) = fromIntegral n++instance GLObject (CubeMap a) where+  glObjectName (CubeMap n) = fromIntegral n++-- | Create a new 2D texture from a blob and its image format.+-- Dimensions should be powers of two.+newTexture2D :: InternalFormat a => Vector Word8 -> Dimensions -> IO (Tex2D a)+newTexture2D bytes (Dimensions w h)  = do+  n <- alloca (\ptr -> glGenTextures 1 ptr >> peek ptr)+  glBindTexture GL_TEXTURE_2D n+  tex <- return (Tex2D n)+  unsafeWith bytes $ \ptr -> glTexImage2D+    GL_TEXTURE_2D+    0+    (internalFormat tex)+    (fromIntegral w)+    (fromIntegral h)+    0+    (internalFormat tex)+    GL_UNSIGNED_BYTE+    (castPtr ptr)+  return tex++-- | Delete a texture.+deleteTexture :: Texture a => a -> IO ()+deleteTexture x = withArray [glObjectName x] (\ptr -> glDeleteTextures 1 ptr)++-- | Create a new cube map texture from six blobs and their respective formats.+-- Dimensions should be powers of two.+newCubeMap :: InternalFormat a+           => Cube (Vector Word8, Dimensions)+           -> IO (CubeMap a)+newCubeMap images = do+  n <- alloca (\ptr -> glGenTextures 1 ptr >> peek ptr)+  glBindTexture GL_TEXTURE_CUBE_MAP n+  cm <- return (CubeMap n)+  let fmt = internalFormat cm+  sequenceA (liftA2 (loadCubeMapSide fmt) images cubeSideCodes)+  return cm+  +loadCubeMapSide :: GLenum -> (Vector Word8, Dimensions) -> GLenum -> IO ()+loadCubeMapSide fmt (bytes, (Dimensions w h)) side = do+  unsafeWith bytes $ \ptr -> glTexImage2D+    side+    0+    (fromIntegral fmt)+    (fromIntegral w)+    (fromIntegral h)+    0+    fmt+    GL_UNSIGNED_BYTE+    (castPtr ptr)++-- | Create an empty texture with the specified dimensions and format.+newEmptyTexture2D :: InternalFormat a => Int -> Int -> IO (Tex2D a)+newEmptyTexture2D w h = do+  let w' = fromIntegral w+  let h' = fromIntegral h+  n <- alloca (\ptr -> glGenTextures 1 ptr >> peek ptr)+  tex <- return (Tex2D n)+  let fmt = internalFormat tex+  let fmt' = internalFormat tex+  glBindTexture GL_TEXTURE_2D n+  glTexImage2D GL_TEXTURE_2D 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr+  return tex++-- | Create a cubemap texture where each of the six sides has the specified+-- dimensions and format.+newEmptyCubeMap :: InternalFormat a => Int -> Int -> IO (CubeMap a)+newEmptyCubeMap w h = do+  let w' = fromIntegral w+  let h' = fromIntegral h+  n <- alloca (\ptr -> glGenTextures 1 ptr >> peek ptr)+  tex <- return (CubeMap n)+  let fmt = internalFormat tex+  let fmt' = internalFormat tex+  glBindTexture GL_TEXTURE_CUBE_MAP n+  glTexImage2D GL_TEXTURE_CUBE_MAP_POSITIVE_X 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr+  glTexImage2D GL_TEXTURE_CUBE_MAP_NEGATIVE_X 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr+  glTexImage2D GL_TEXTURE_CUBE_MAP_POSITIVE_Y 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr+  glTexImage2D GL_TEXTURE_CUBE_MAP_NEGATIVE_Y 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr+  glTexImage2D GL_TEXTURE_CUBE_MAP_POSITIVE_Z 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr+  glTexImage2D GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr+  return tex+  ++-- | Bind a 2D texture to the 2D texture binding target and the currently+-- active texture unit.+bindTexture2D :: Tex2D a -> IO ()+bindTexture2D (Tex2D n) = glBindTexture GL_TEXTURE_2D n++-- | Bind a cubemap texture to the cubemap texture binding target and+-- the currently active texture unit.+bindTextureCubeMap :: CubeMap a -> IO ()+bindTextureCubeMap (CubeMap n) = glBindTexture GL_TEXTURE_CUBE_MAP n++-- | Set the active texture unit. The default is zero.+setActiveTextureUnit :: Enum a => a -> IO ()+setActiveTextureUnit n =+  (glActiveTexture . fromIntegral) (GL_TEXTURE0 + fromEnum n)++-- | Set the filtering for the 2D texture currently bound to the 2D texture+-- binding target.+setTex2DFiltering :: Filtering -> IO ()+setTex2DFiltering filt = do+  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER (toGL filt)+  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER (toGL filt)++-- | Set the filtering for the cubemap texture currently bound to the cubemap+-- texture binding target.+setCubeMapFiltering :: Filtering -> IO ()+setCubeMapFiltering filt = do+  glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER (toGL filt)+  glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER (toGL filt)++-- | Set the wrapping mode for the 2D texture currently bound to the 2D+-- texture binding target.+setTex2DWrapping :: Wrapping -> IO ()+setTex2DWrapping wrap = do+  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S (toGL wrap)+  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T (toGL wrap)++-- | Set the wrapping mode for the cubemap texture currently bound to the+-- cubemap texture binding target. Because no blending occurs between cube+-- faces you probably want ClampToEdge.+setCubeMapWrapping :: Wrapping -> IO ()+setCubeMapWrapping wrap = do+  glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S (toGL wrap)+  glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T (toGL wrap)+  glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R (toGL wrap)
+ Graphics/GL/Low/VAO.hs view
@@ -0,0 +1,38 @@+module Graphics.GL.Low.VAO +(+  VAO,+  newVAO,+  deleteVAO,+  bindVAO+) where++import Foreign.Storable+import Foreign.Marshal++import Graphics.GL++import Graphics.GL.Low.Classes++-- | A VAO stores vertex attribute layouts and the VBO source of vertices+-- for those attributes. It also stores the state of the element array binding+-- target. The vertex array binding target admits one VAO at a time.+newtype VAO = VAO GLuint deriving Show++instance GLObject VAO where+  glObjectName (VAO n) = fromIntegral n++-- | Create a new VAO. The only thing you can do with a VAO is bind it to+-- the vertex array binding target.+newVAO :: IO VAO+newVAO = do+  n <- alloca (\ptr -> glGenVertexArrays 1 ptr >> peek ptr)+  return (VAO n)++-- | Delete a VAO.+deleteVAO :: VAO -> IO ()+deleteVAO (VAO n) = withArray [n] (\ptr -> glDeleteVertexArrays 1 ptr)++-- | Assign the VAO to the vertex array binding target. The VAO already bound+-- will be replaced, if any.+bindVAO :: VAO -> IO ()+bindVAO (VAO n) = glBindVertexArray n
+ Graphics/GL/Low/VertexAttrib.hs view
@@ -0,0 +1,127 @@+-- | Vertex Attribute Array.+module Graphics.GL.Low.VertexAttrib where++import Foreign.C.String+import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable+import Control.Monad (forM_)++import Graphics.GL++import Graphics.GL.Low.Classes++-- | The name of a vertex input to a program combined with the+-- component format and number of components for that attribute in the+-- vertex data. Alternatively the size of an unused section of the data+-- in bytes.+data LayoutElement =+  Attrib String Int ComponentFormat | -- ^ Name, component count and component format of a vertex attribute.+  Unused Int -- ^ Size in bytes of an unused section of the vertex data.+    deriving Show++-- | The layout of interleaved vertex attribute data.+type VertexAttributeLayout = [LayoutElement]++-- | The size and interpretation of a vertex attribute component. Normalized+-- components will be mapped to floats in the range [0, 1].+data ComponentFormat =+  VFloat | -- ^ 4-byte float+  VByte | +  VUByte | +  VByteNormalized | +  VUByteNormalized |+  VShort | -- ^ 2-byte signed integer+  VUShort | -- ^ 2-byte unsigned integer+  VShortNormalized |+  VUShortNormalized |+  VInt | -- ^ 4-byte signed integer+  VUInt | -- ^ 4-byte unsigned integer+  VIntNormalized |+  VUIntNormalized+    deriving (Eq, Show)++instance ToGL ComponentFormat where+  toGL VFloat = GL_FLOAT+  toGL VByte = GL_BYTE+  toGL VUByte = GL_UNSIGNED_BYTE+  toGL VByteNormalized = GL_BYTE+  toGL VUByteNormalized = GL_UNSIGNED_BYTE+  toGL VShort = GL_SHORT+  toGL VUShort = GL_UNSIGNED_SHORT+  toGL VShortNormalized = GL_SHORT+  toGL VUShortNormalized = GL_UNSIGNED_SHORT+  toGL VInt = GL_INT+  toGL VUInt = GL_UNSIGNED_INT+  toGL VIntNormalized = GL_INT+  toGL VUIntNormalized = GL_UNSIGNED_INT+  +++elaborateLayout :: Int -> VertexAttributeLayout -> [(String, Int, Int, ComponentFormat)]+elaborateLayout here layout = case layout of+  [] -> []+  (Unused n):xs -> elaborateLayout (here+n) xs+  (Attrib name n fmt):xs ->+    let size = n * sizeOfVertexComponent fmt in+    (name, n, here, fmt) : elaborateLayout (here+size) xs++totalLayout :: VertexAttributeLayout -> Int+totalLayout layout = sum (map arraySize layout) where+  arraySize (Unused n) = n+  arraySize (Attrib _ n fmt) = n * sizeOfVertexComponent fmt++sizeOfVertexComponent :: ComponentFormat -> Int+sizeOfVertexComponent c = case c of+  VByte -> 1+  VUByte -> 1+  VByteNormalized -> 1+  VUByteNormalized -> 1+  VShort -> 2+  VUShort -> 2+  VShortNormalized -> 2+  VUShortNormalized -> 2+  VInt -> 4+  VUInt -> 4+  VIntNormalized -> 4+  VUIntNormalized -> 4+  VFloat -> 4++isNormalized :: ComponentFormat -> Bool+isNormalized c = case c of+  VByte -> False+  VUByte -> False+  VByteNormalized -> True+  VUByteNormalized -> True+  VShort -> False+  VUShort -> False+  VShortNormalized -> True+  VUShortNormalized -> True+  VInt -> False+  VUInt -> False+  VIntNormalized -> True+  VUIntNormalized -> True+  VFloat -> False+++-- | This configures the currently bound VAO. It calls glVertexAttribPointer+-- and glEnableVertexAttribArray.+setVertexAttributeLayout :: VertexAttributeLayout -> IO ()+setVertexAttributeLayout layout = do+  p <- alloca (\ptr -> glGetIntegerv GL_CURRENT_PROGRAM ptr >> peek ptr)+  if p == 0+    then return ()+    else do+      let layout' = elaborateLayout 0 layout+      let total = totalLayout layout+      forM_ layout' $ \(name, size, offset, fmt) -> do+        attrib <- withCString name $ \ptr -> glGetAttribLocation (fromIntegral p) (castPtr ptr)+        let norm = isNormalized fmt+        glVertexAttribPointer+          (fromIntegral attrib)+          (fromIntegral size)+          (toGL fmt)+          (fromIntegral . fromEnum $ norm)+          (fromIntegral offset)+          (castPtr (nullPtr `plusPtr` offset))+        glEnableVertexAttribArray (fromIntegral attrib)
lowgl.cabal view
@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.2.0.0+version:             0.2.0.1  -- A short (one-line) description of the package. synopsis:            Basic gl wrapper and reference@@ -49,6 +49,21 @@ library   -- Modules exported by the library.   exposed-modules:     Graphics.GL.Low+                       Graphics.GL.Low.Blending+                       Graphics.GL.Low.BufferObject+                       Graphics.GL.Low.Color+                       Graphics.GL.Low.Classes+                       Graphics.GL.Low.Cube+                       Graphics.GL.Low.Depth+                       Graphics.GL.Low.Error+                       Graphics.GL.Low.Framebuffer+                       Graphics.GL.Low.ImageFormat+                       Graphics.GL.Low.Render+                       Graphics.GL.Low.Shader+                       Graphics.GL.Low.Stencil+                       Graphics.GL.Low.Texture+                       Graphics.GL.Low.VAO+                       Graphics.GL.Low.VertexAttrib   other-modules:       Graphics.GL.Low.Common      -- Modules included in this library but not exported.@@ -74,4 +89,4 @@ source-repository this   type: git   location: https://github.com/evanrinehart/lowgl-  tag: 0.2.0.0+  tag: 0.2.0.1