{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE PatternSynonyms #-}
module Graphics.GL.Low (

  -- * In a Nutshell
  --
  -- ** Overview
  -- | OpenGL is a graphics rendering interface. This library exposes a vastly
  -- simplified subset of OpenGL that is hopefully still complete enough for
  -- many purposes, such as following tutorials, making simple games, and
  -- demos. In particular the intention is to concentrate on a subset of
  -- OpenGL 3.2 (Core Profile) roughly corresponding to ES 2.0.
  --
  -- A second primary purpose is to document the complex model behind the
  -- interface in a way that is more elaborate than tutorials and more concise
  -- than the spec. As such, this is an experimental project to aid my own
  -- process of understanding OpenGL. It seems that understanding the entire
  -- picture up-front is the only way to get started, so this should also serve
  -- as a quick reference guide to the core commands and concepts.
  --
  -- This library uses the `gl' package for raw bindings to OpenGL and the
  -- `linear' package for matrices.
  --
  -- (include link to example programs)

  -- ** Objects
  -- | Objects may be created and destroyed by client code. They include:
  --
  -- - Vertex Array Object ('VAO')
  -- - Buffer Objects ('VBO', 'ElementArray')
  -- - Textures ('Tex2D', 'CubeMap')
  -- - Shader 'Program's
  -- - Framebuffer Objects ('FBO')
  -- - Renderbuffer Objects ('RBO')

  -- ** Binding Targets
  -- | Objects are referenced with integers (called names in GL), so binding
  -- targets can be thought of as global variables to put those references.
  -- Many operations implicitly read from these globals to determine what the
  -- target object of the operation is. They include:
  --
  -- - Vertex array binding target (for VAO)
  -- - Buffer binding targets (ARRAY_BUFFER and ELEMENT_ARRAY_BUFFER)
  -- - Texture binding targets (TEXTURE_2D and TEXTURE_CUBE_MAP)
  -- - Framebuffer binding target (for FBO)
  --
  -- (not binding targets but similar)
  --
  -- - Shader program "in use"
  -- - Texture units
  -- - Current active texture unit
  -- - Image attachment points of an FBO

  -- ** Shader Programs
  -- | The role of the second half of a program, the fragment shader, is to
  -- compute the color and depth of pixels covered by rasterized primitives
  -- (points, lines, and triangles) in the process of rendering. The role of
  -- the /first/ half of the program (vertex program) is to arrange the vertices
  -- of those primitives somewhere in clip space. Where these vertices and
  -- their attributes come from in the first place is determined by the VAO
  -- bound to the vertex array binding target. The program may also make use
  -- of uniform variables and texture units assigned by client code before
  -- rendering (but in a process separate from configuring the VAO). At most
  -- one Program can be "in use" at a time.

  -- ** VAO
  -- | The VAO is essential. At least one VAO must be created and bound to the
  -- vertex array binding target before rendering, before configuring a
  -- program's vertex attributes. Here is why: the VAO stores the association
  -- between input variables in the program and a VBO from which to pipe input
  -- from. It also stores the format of the VBO data, which is otherwise just
  -- a big blob. Finally, the VAO stores the state of the element array binding
  -- target used for indexed rendering.
  --
  -- After installing a program with 'useProgram' and binding a source VBO
  -- to the array buffer binding target ('bindVBO') then the bound VAO can be
  -- updated ('setVertexAttributeLayout') with new vertex attribute information.
  -- After this, the VBO can be rebound to configure a different set of inputs
  -- with a different source. Many VAOs can be created and swapped out to pipe
  -- vertex data in different ways to different programs (or the same program).
  --
  -- When a VAO is bound it restores the state of the element array binding
  -- target. For this reason you can think of that binding target as simply
  -- being a function of the VAO itself rather than a separate global state.

  -- ** Uniforms and Samplers (Textures)
  -- | Programs may have uniform variables and "sampler uniforms" as input.
  -- Uniforms are accessible from the vertex or fragment shader part of the
  -- program but their values are fixed during the course of a rendering command.
  -- They can be set and reset with the setUniform family (ex. 'setUniform1f'),
  -- which updates a program object with new uniform values. Among other
  -- things, updating the uniforms each frame is the main way to animate a
  -- scene.
  --
  -- Samplers are textures that the shader can interpolate to get "in between"
  -- values. The texture a sampler uses is determined by the contents of the
  -- texture unit that that sampler points to. The sampler is a uniform with
  -- an integer type. This integer is the texture unit to use. The word texture
  -- should not be construed to mean a color image. Shaders can make use of
  -- many kinds of multi-dimensional data that happen to be available through
  -- the samplers.

  -- ** Texture Objects and Texture Units
  -- | Before a shader can use a texture it must be assigned to a texture unit.
  -- First set the active texture unit to the desired unit number
  -- ('setActiveTextureUnit') then bind the texture object to one of the
  -- two texture binding targets, depending on what kind of texture it is (2D
  -- or cubemap). Binding a texture has the side effect of assigning it to the
  -- active texture unit.

  -- ** Custom Framebuffers
  -- | It is possible (and important to many techniques) to utilize an
  -- off-screen render target. To do this create an FBO ('newFBO'), bind it to
  -- the framebuffer binding target ('bindFramebuffer') and attach a color
  -- /image/ object (texture or renderbuffer object). If necessary a depth
  -- image or combination depth-stencil image can be attached as well. If no
  -- color image is attached then the FBO is incomplete and rendering will be
  -- an error.  After rendering to an FBO any textures that were attached can
  -- be used for a second pass by assigning them to a texture unit. Watch out
  -- for feedback loops accidentally sampling a texture that is also being
  -- rendered to at the same time!
  --
  -- A renderbuffer object is a minor character to be used when you do not
  -- expect to use the results of rendering but need an image anyway. For
  -- example you may need a depth buffer to do depth testing, or you may want
  -- to ignore the (required for rendering to work at all) color buffer.

  -- ** Images and Image Formats
  -- | FBOs have attachment points for /images/. A texture serves as an image
  -- and a renderbuffer object serves as an image. Images have an "internal
  -- format" which describes the size and interpretation of pixel components.
  -- There are seven internal formats, five of which are color image formats
  -- such as grayscale and RGB. The other two are the depth buffer format and
  -- the combination depth-stencil format. RBOs ('newRBO') and empty textures
  -- ('newEmptyTexture2D', 'newEmptyCubeMap') can be created with any of these
  -- formats.
  --
  -- (The above is a gross simplification of OpenGL's image formats. I should
  -- probably revise, because it may greatly improve performance to use some
  -- of the 16-bit color formats rather than 32.)

  -- ** Depth Testing, Stencil Testing, Scissor Testing, Facet Culling
  -- | The depth buffer and stencil buffers, if present in the current
  -- framebuffer, can be used to avoid rendering to points of the screen by
  -- testing against the value stored at those points. For example if commanded
  -- to show a triangle in a region of the framebuffer with a depth greater
  -- than current depth buffer values, then the triangle may not be rendered to
  -- the color buffer or anywhere else (depending on settings). There are many
  -- global settings to switch on and off these tests and the ability to
  -- modify the buffers involved. The stencil test in particular is highly
  -- configurable. The scissor test is the simplest: when activated nothing
  -- outside the scissor box (in screen space) will be rendered. The only
  -- other configuration is to set that scissor box ('setScissorBox').
  -- Polygons facing toward or away from the viewer can be dropped (or culled)
  -- from rendering with 'enableCulling'.

  -- ** Coordinate Systems
  -- | - Screen space is simply the 2D coordinate system of your window.
  -- The viewport transformation (see 'setViewport') determines where in the
  -- window the mapping of the NDS cube (see below) will appear.
  -- - NDS, normalized device coordinates, or sometimes viewport space is a
  -- cube 2x2x2 centered at the origin the inside of which is your final scene,
  -- before it is mapped to the screen via the viewport setting (see
  -- 'setViewport'). If an orthographic projection was used to put the scene in
  -- clip space then clip space and NDS are the same.
  -- - Clip space is the destination of vertices transformed by the
  -- vertex program. Objects here are mapped to NDS using the perspective
  -- division technique to account for the case that the vertex shader used
  -- a perspective matrix.
  -- - Model space is the name for positions of raw vertices as present in
  -- the VBOs. The vertex program will want to somehow move these vertexes
  -- into clip space, representing generally the position and direction the
  -- user is viewing the scene from.

  -- ** Rendering Points, Lines, and Triangles
  -- | The draw family (ex. 'drawTriangles') of commands commissions the
  -- rendering of a certain number of vertices worth of primitives. The
  -- current program will get input from the current VAO, the current texture
  -- units, and execute on all the potentially affected pixels in the current
  -- framebuffer. Vertexes are consumed in the order they appear in their
  -- respective source VBOs. If the VAO is missing, the program is missing, or
  -- the current framebuffer has no color attachment, then rendering will not
  -- work.
  --
  -- The drawIndexed family (ex. 'drawIndexedTriangles') of commands carries
  -- out the same effects as the non-indexed rendering commands but traverses
  -- vertices in an order determined by the sequence of indexes packed in the
  -- ElementArray currently bound to the element array binding target. This
  -- mainly allows a huge reuse of vertex data in the case that the object
  -- being rendered forms a closed mesh.




  -- * VAO
  VAO,
  newVAO,
  bindVAO,
  deleteVAO,

  -- * Buffer Objects
  -- ** VBO
  VBO,
  UsageHint(..),
  newVBO,
  bindVBO,
  updateVBO,
  deleteVBO,

  -- ** Element Array
  ElementArray,
  IndexFormat(..),
  newElementArray,
  bindElementArray,
  updateElementArray,
  deleteElementArray,

  -- * Shader Program
  Program,
  ProgramError(..),
  newProgram,
  newProgramSafe,
  useProgram,
  deleteProgram,

  -- ** Vertex Attributes
  VertexAttributeLayout(..),
  LayoutElement(..),
  ComponentFormat(..),
  setVertexAttributeLayout,

  -- ** Uniform Variables
  --
  -- | Set uniform variables for the current program. To set an array of
  -- uniforms pass a list of more than one value.

  -- *** Float Uniforms
  -- | These call glUniformNfv.
  setUniform1f, 
  setUniform2f,
  setUniform3f,
  setUniform4f,

  -- *** Int Uniforms
  -- | These call glUniformNiv.
  setUniform1i,
  setUniform2i,
  setUniform3i,
  setUniform4i,

  -- *** Matrix Uniforms
  -- | These call glUniformMatrixNfv.
  setUniform22,
  setUniform33,
  setUniform44,

  -- * Textures
  Tex2D,
  CubeMap,
  Dimensions(..),
  Cube(..),
  Side,
  newTexture2D,
  newCubeMap,
  newEmptyTexture2D,
  newEmptyCubeMap,
  deleteTexture,
  setActiveTextureUnit,
  bindTexture2D,
  bindTextureCubeMap,
  Filtering(..),
  setTex2DFiltering,
  setCubeMapFiltering,
  Wrapping(..),
  setTex2DWrapping,
  setCubeMapWrapping,

  -- * Rendering

  -- ** Primitives
  -- | Draw primitives to the framebuffer currently bound to the framebuffer
  -- binding target. Each primitive drawing command takes the number of vertices
  -- in the VBOs to render. The vertices are traversed in order.
  drawPoints,
  drawLines,
  drawLineStrip,
  drawLineLoop,
  drawTriangles,
  drawTriangleStrip,
  drawTriangleFan,

  -- ** Primitives by Index
  -- | Draw primitives as above, but use the order of vertices defined in
  -- the ElementArray currently bound to the element array buffer binding
  -- target.
  drawIndexedPoints,
  drawIndexedLines,
  drawIndexedLineStrip,
  drawIndexedLineLoop,
  drawIndexedTriangles,
  drawIndexedTriangleStrip,
  drawIndexedTriangleFan,

  -- ** Color Buffer
  enableColorWriting,
  disableColorWriting,
  clearColorBuffer,

  -- ** Depth Test
  enableDepthTest,
  disableDepthTest,
  clearDepthBuffer,
  enableDepthWriting,
  disableDepthWriting,

  -- ** Stencil Test
  enableStencilTest,
  disableStencilTest,
  clearStencilBuffer,
  enableStencilWriting,
  disableStencilWriting,

  -- ** Scissor Test
  setScissorBox,
  enableScissorTest,
  disableScissorTest,

  -- ** Facet Culling
  Culling(..),
  enableCulling,
  disableCulling,

  -- ** Blending
  -- | When blending is enabled, colors written to the color buffer will be
  -- blended with the color already there using a formula. The three options
  -- for the formula are ('setBlendEquation'):
  --
  -- - Xs + Yd (FuncAdd, the default)
  -- - Xs - Yd (FuncSub)
  -- - Yd - Xs (FuncReverseSubtract)
  --
  -- where X and Y are source and destination color components respetively.
  -- The factors s and d are blending factors which can be configured
  -- ('setBlendFactors') and should depend on the alpha channel to get a correct
  -- transparency effect. The typical choice is
  --
  -- @
  -- setBlendFactors BlendSourceAlpha BlendOneMinusSourceAlpha
  -- @
  --
  -- When using blending the order of rendering matters. The farther away
  -- primitives should be rendered first to get transparent materials to look
  -- right. This means a depth test is unhelpful when using this technique.
  -- 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.

  BlendFactor(..),
  BlendEquation(..),
  enableBlending,
  disableBlending,
  setBlendFactors,
  setBlendEquation,

  -- ** Viewport
  Viewport(..),
  setViewport,

  -- * Framebuffers
  DefaultFramebuffer,
  FBO,
  bindFramebuffer,
  newFBO,
  attachTex2D,
  attachCubeMap,
  attachRBO,
  deleteFBO,

  -- * Renderbuffers
  RBO,
  newRBO,
  deleteRBO,

  -- * Errors
  GLError(..),
  getGLError,

  -- * Image Formats
  Alpha,
  Luminance,
  LuminanceAlpha,
  RGB,
  RGBA,
  Depth24,
  Depth24Stencil8,

  -- * Classes
  InternalFormat(..),
  Framebuffer(..),
  Texture(..),
  Attachable(..)

) where

import Prelude hiding (sum)
import Control.Exception
import Data.Typeable
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal
import Foreign.C.String
import Data.Vector.Storable (Vector, unsafeWith)
import qualified Data.Vector.Storable as V (length)
import Control.Monad hiding (forM_)
import Data.Word
import Data.Int
import Data.Functor
import Control.Applicative
import Data.Traversable
import Data.Foldable
import Data.Default

import Linear
import Graphics.GL

-- | 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

-- | 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

-- | 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

-- | 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

-- | 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


-- | 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

-- | 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

-- | 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
  

-- | 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


-- | 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

-- | OpenGL internal image formats.
class InternalFormat a where
  internalFormat :: (Eq b, Num b) => proxy a -> b
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

-- | The allowed attachment point for images with an internal format.
class InternalFormat a => Attachable a where
  attachPoint :: (Eq b, Num b) => proxy a -> b
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

-- | 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


-- | 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

-- | A rectangular section of the window.
data Viewport = Viewport
  { viewportX :: Int
  , viewportY :: Int
  , viewportW :: Int
  , viewportH :: Int }
    deriving (Eq, Show)

-- | The size of an image in pixels, parameterized by an image format type.
data Dimensions = Dimensions
  { imageWidth :: Int
  , imageHeight :: Int }
    deriving (Show)

-- | 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)

-- | 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

-- | 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"

class ToGL a where
  toGL :: (Num b, Eq b) => a -> b

-- | Textures have an internal numeric name.
class Texture a where
  textureName :: Num b => a -> b

instance Texture (Tex2D a) where
  textureName (Tex2D n) = fromIntegral n

instance Texture (CubeMap a) where
  textureName (CubeMap n) = fromIntegral n


-- | Blending functions for alpha blending.
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 |
  BlendSourceAlpha |
  BlendOneMinusSourceAlpha
    deriving Show

instance ToGL BlendFactor where
  toGL BlendOne = GL_ONE
  toGL BlendZero = GL_ZERO
  toGL BlendSourceAlpha = GL_SRC_ALPHA
  toGL BlendOneMinusSourceAlpha = GL_ONE_MINUS_SRC_ALPHA

-- | 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

-- | 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

instance Framebuffer DefaultFramebuffer where
  framebufferName _ = 0

instance Framebuffer FBO where
  framebufferName (FBO 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


-- | 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
  unsafeWith src $ \ptr -> glBufferData
    GL_ARRAY_BUFFER
    (fromIntegral len)
    (castPtr ptr)
    (toGL usage)
  return (VBO n)

-- | Delete a VBO.
deleteVBO :: VBO -> IO ()
deleteVBO (VBO n) = withArray [n] (\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
  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
  unsafeWith bytes $ \ptr -> do
    glBufferData
      GL_ELEMENT_ARRAY_BUFFER
      (fromIntegral len)
      (castPtr ptr)
      (toGL usage)
  return (ElementArray n)

-- | Delete an ElementArray
deleteElementArray :: ElementArray -> IO ()
deleteElementArray (ElementArray n) = withArray [n] (\ptr -> glDeleteBuffers 1 ptr)
  
-- | Modify contents in the currently bound ElementArray starting at the
-- specified index in bytes.
updateElementArray :: Vector Word8 -> Int -> IO ()
updateElementArray bytes offset = 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


-- | 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


-- | This configures the currently bound VAO. It calls glVertexAttribPointer
-- and glEnableVertexAttribArray.
setVertexAttributeLayout :: Program -> VertexAttributeLayout -> IO ()
setVertexAttributeLayout (Program p) layout = do
  let layout' = elaborateLayout 0 layout
  let total = totalLayout layout
  forM_ layout' $ \(name, size, offset, fmt) -> do
    attrib <- withCString name $ \ptr -> glGetAttribLocation 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)

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


setUniform1f :: Program -> String -> [Float] -> IO ()
setUniform1f = setUniform glUniform1fv

setUniform2f :: Program -> String -> [V2 Float] -> IO ()
setUniform2f = setUniform
  (\loc cnt val -> glUniform2fv loc cnt (castPtr val))

setUniform3f :: Program -> String -> [V3 Float] -> IO ()
setUniform3f = setUniform
  (\loc cnt val -> glUniform3fv loc cnt (castPtr val))

setUniform4f :: Program -> String -> [V4 Float] -> IO ()
setUniform4f = setUniform
  (\loc cnt val -> glUniform4fv loc cnt (castPtr val))

setUniform1i :: Program -> String -> [Int] -> IO ()
setUniform1i = setUniform
  (\loc cnt val -> glUniform1iv loc cnt (castPtr val))

setUniform2i :: Program -> String -> [V2 Int] -> IO ()
setUniform2i = setUniform 
  (\loc cnt val -> glUniform2iv loc cnt (castPtr val))

setUniform3i :: Program -> String -> [V3 Int] -> IO ()
setUniform3i = setUniform
  (\loc cnt val -> glUniform3iv loc cnt (castPtr val))

setUniform4i :: Program -> String -> [V4 Int] -> IO ()
setUniform4i = setUniform
  (\loc cnt val -> glUniform4iv loc cnt (castPtr val))

setUniform44 :: Program -> String -> [M44 Float] -> IO ()
setUniform44 = setUniform
  (\loc cnt val -> glUniformMatrix4fv loc cnt GL_FALSE (castPtr val))

setUniform33 :: Program -> String -> [M33 Float] -> IO ()
setUniform33 = setUniform
  (\loc cnt val -> glUniformMatrix3fv loc cnt GL_FALSE (castPtr val))

setUniform22 :: Program -> String -> [M22 Float] -> IO ()
setUniform22 = setUniform
  (\loc cnt val -> glUniformMatrix2fv loc cnt GL_FALSE (castPtr val))

setUniform :: Storable a => (GLint -> GLsizei -> Ptr a -> IO ())
           -> Program -> String -> [a]
           -> IO ()
setUniform glAction (Program p) name xs = withArrayLen xs $ \n bytes -> do
  loc <- withCString name (\ptr -> glGetUniformLocation p ptr)
  glAction loc (fromIntegral n) bytes
  

  

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

-- | 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 [textureName 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)

  

-- | 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

-- | Enable the depth test. Attempting to render pixels with a depth value
-- greater than the depth buffer at those pixels will have no effect.
enableDepthTest :: IO ()
enableDepthTest = glEnable GL_DEPTH_TEST

-- | Disable the depth test. Rendering will not be affected by the depth.
-- Use this to render graphics even if they are behind something.
disableDepthTest :: IO ()
disableDepthTest = glDisable GL_DEPTH_TEST

-- | Enable writing depth values to the depth buffer of the current framebuffer.
-- It is enabled by default.
enableDepthWriting :: IO ()
enableDepthWriting = glDepthMask GL_TRUE

-- | Disable writing to the depth buffer.
disableDepthWriting :: IO ()
disableDepthWriting = glDepthMask GL_FALSE

-- | Clear the depth buffer with the maximum depth value.
clearDepthBuffer :: IO ()
clearDepthBuffer = glClear GL_DEPTH_BUFFER_BIT

-- | Enable the stencil test. Any pixels rendered to the screen where the
-- stencil buffer is 1 will not be rendered. This disables writing to the
-- stencil buffer.
enableStencilTest :: IO ()
enableStencilTest = do
  glStencilFunc GL_LESS 1 maxBound
  glStencilOp GL_KEEP GL_KEEP GL_KEEP
  glEnable GL_STENCIL_TEST

-- | Disable the stencil test.
disableStencilTest :: IO ()
disableStencilTest = glDisable GL_STENCIL_TEST

-- | Clear the stencil buffer with all zeros.
clearStencilBuffer :: IO ()
clearStencilBuffer = glClear GL_STENCIL_BUFFER_BIT

-- | Allow rendering to modify the stencil buffer. Any pixels rendered to
-- the screen will set the stencil buffer to 1 at that location.
enableStencilWriting :: IO ()
enableStencilWriting = do
  glStencilFunc GL_ALWAYS 1 maxBound
  glStencilOp GL_KEEP GL_KEEP GL_REPLACE
  glStencilMask 1

-- | Disable rendering to the stencil buffer.
disableStencilWriting :: IO ()
disableStencilWriting = glStencilMask 0



-- | Set the scissor box. Graphics outside this box will not be rendered as
-- long as the scissor test is enabled.
setScissorBox :: Viewport -> IO ()
setScissorBox (Viewport x y w h) =
  glScissor (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)

-- | Enable the scissor test. Graphics outside the scissor box will not be
-- rendered.
enableScissorTest :: IO ()
enableScissorTest = 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)

-- | 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 t@(Tex2D n) =
  glFramebufferTexture2D GL_FRAMEBUFFER (attachPoint t) GL_TEXTURE_2D n 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@(CubeMap n) side =
  glFramebufferTexture2D
    GL_FRAMEBUFFER
    (attachPoint cm)
    (side cubeSideCodes)
    n
    0

cubeSideCodes :: Cube GLenum
cubeSideCodes = Cube
  { cubeLeft   = GL_TEXTURE_CUBE_MAP_NEGATIVE_X
  , cubeRight  = GL_TEXTURE_CUBE_MAP_POSITIVE_X
  , cubeTop    = GL_TEXTURE_CUBE_MAP_POSITIVE_Y
  , cubeBottom = GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
  , cubeFront  = GL_TEXTURE_CUBE_MAP_POSITIVE_Z
  , cubeBack   = GL_TEXTURE_CUBE_MAP_NEGATIVE_Z }

-- | 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)


-- | Enable alpha blending.
enableBlending :: IO ()
enableBlending = glEnable GL_BLEND

-- | Disable alpha blending.
disableBlending :: IO ()
disableBlending = glDisable GL_BLEND

-- | Set the computation for source and destination blending factors.
setBlendFactors :: BlendFactor -> BlendFactor -> IO ()
setBlendFactors s d = glBlendFunc (toGL s) (toGL d)

-- | Set the overall blending function.
setBlendEquation :: BlendEquation -> IO ()
setBlendEquation e = glBlendEquation (toGL e)



-- | 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)