GPipe 1.4.1 → 2.0

raw patch · 41 files changed

+6289/−2804 lines, 41 filesdep +exception-transformersdep +gldep +hashtablesdep −GLUTdep −OpenGLdep −Vecdep ~Booleandep ~basedep ~containerssetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: exception-transformers, gl, hashtables, linear

Dependencies removed: GLUT, OpenGL, Vec, Vec-Boolean, list-tries

Dependency ranges changed: Boolean, base, containers, transformers

API changes (from Hackage documentation)

Files

• GPipe.cabal +55/−51
• LICENSE +21/−0
• Setup.hs +2/−0
• Setup.lhs +0/−6
• src/Data/SNMap.hs +49/−0
• src/Formats.hs +0/−289
• src/GPUStream.hs +0/−165
• src/Graphics/GPipe.hs +47/−31
• src/Graphics/GPipe/Buffer.hs +50/−0
• src/Graphics/GPipe/Context.hs +39/−0
• src/Graphics/GPipe/Expr.hs +46/−0
• src/Graphics/GPipe/Format.hs +35/−40
• src/Graphics/GPipe/FragmentStream.hs +39/−0
• src/Graphics/GPipe/FrameBuffer.hs +85/−72
• src/Graphics/GPipe/Internal/Buffer.hs +606/−0
• src/Graphics/GPipe/Internal/Compiler.hs +279/−0
• src/Graphics/GPipe/Internal/Context.hs +256/−0
• src/Graphics/GPipe/Internal/Expr.hs +1123/−0
• src/Graphics/GPipe/Internal/Format.hs +523/−0
• src/Graphics/GPipe/Internal/FragmentStream.hs +196/−0
• src/Graphics/GPipe/Internal/FrameBuffer.hs +516/−0
• src/Graphics/GPipe/Internal/PrimitiveArray.hs +154/−0
• src/Graphics/GPipe/Internal/PrimitiveStream.hs +320/−0
• src/Graphics/GPipe/Internal/Shader.hs +132/−0
• src/Graphics/GPipe/Internal/Texture.hs +1192/−0
• src/Graphics/GPipe/Internal/Uniform.hs +182/−0
• src/Graphics/GPipe/PrimitiveArray.hs +67/−0
• src/Graphics/GPipe/PrimitiveStream.hs +32/−0
• src/Graphics/GPipe/Sampler.hs +72/−0
• src/Graphics/GPipe/Shader.hs +42/−0
• src/Graphics/GPipe/Stream.hs +0/−36
• src/Graphics/GPipe/Stream/Fragment.hs +0/−63
• src/Graphics/GPipe/Stream/Primitive.hs +0/−61
• src/Graphics/GPipe/Texture.hs +104/−46
• src/Graphics/GPipe/Uniform.hs +25/−0
• src/InputAssembler.hs +0/−97
• src/OutputMerger.hs +0/−458
• src/Rasterizer.hs +0/−108
• src/Resources.hs +0/−471
• src/Shader.hs +0/−469
• src/Textures.hs +0/−341

@@ -1,54 +1,58 @@-name: GPipe-version: 1.4.1
-cabal-version: >= 1.8
-build-type: Simple-license: BSD3-copyright: Tobias Bexelius-maintainer: Tobias Bexelius-                 -stability: Experimental-homepage: http://www.haskell.org/haskellwiki/GPipe-package-url: http://hackage.haskell.org/package/GPipe-bug-reports: https://github.com/tobbebex/GPipe/issues-synopsis: A functional graphics API for programmable GPUs-description: GPipe models the entire graphics pipeline in a purely functional, immutable and typesafe way. It is built on top of the programmable pipeline (i.e. non-fixed function) of-             OpenGL 2.1 and uses features such as vertex buffer objects (VBO's), texture objects and GLSL shader code synthetisation to create fast graphics programs. Buffers,-             textures and shaders are cached internally to ensure fast framerate, and GPipe is also capable of managing multiple windows and contexts. By creating your own-             instances of GPipes classes, it's possible to use additional datatypes on the GPU.-             .-             You'll need full OpenGL 2.1 support, including GLSL 1.20 to use GPipe. Thanks to OpenGLRaw, you may still build GPipe programs on machines lacking this support.-             -category: Graphics-author: Tobias Bexelius---Library-    build-depends: 
-                    containers >= 0.4 && <0.5,
-                    list-tries >= 0.4.1 && < 0.5,
-                    GLUT == 2.3.0.0,
-                    OpenGL == 2.5.0.0,
-                    Boolean == 0.0.1,
-                    Vec == 1.0.1,
-                    Vec-Boolean == 1.0.6,
-                    base >= 4 && <5,
-                    transformers
-                       -    other-modules: 
-                   Formats,
-                   GPUStream,
-                   InputAssembler,
-                   OutputMerger,
-                   Rasterizer,
-                   Resources,
-                   Shader,
-                   Textures
-    hs-source-dirs: src-    exposed-modules:
+name:           GPipe
+version:        2.0
+cabal-version:  >= 1.8
+build-type:     Simple
+author:         Tobias Bexelius
+license:        MIT
+license-file:   LICENSE
+copyright:      Tobias Bexelius
+category:       Graphics
+stability:      Experimental
+synopsis:       Typesafe functional GPU graphics programming
+homepage:       http://tobbebex.blogspot.se/
+description:    
+                A typesafe API based on the conceptual model of OpenGl, but without the imperative state machine. 
+                Aims to be as close to the raw OpenGl performance as possible, without compromising type safety or functional style. 
+                Includes DSL for shaders to provide type safety even when crossing into that domain.
+                Uses OpenGl 3.3 core profile under the hood.
+maintainer:     Tobias Bexelius
+
+library
+  hs-source-dirs:   src
+  build-depends:    base >= 4.7 && < 4.9,
+                    transformers >= 0.3 && < 0.5,
+                    exception-transformers >= 0.3 && < 0.5,
+                    containers >= 0.5 && < 0.6,
+                    Boolean >= 0.2 && <0.3,
+                    hashtables >= 1.2 && < 1.3,
+                    gl >= 0.7 && < 0.8,
+                    linear >= 1.18 && < 1.20
+  exposed-modules:  
                     Graphics.GPipe,
+                    Graphics.GPipe.Buffer,
+                    Graphics.GPipe.Context,
+                    Graphics.GPipe.Expr,
                     Graphics.GPipe.Format,
+                    Graphics.GPipe.FragmentStream,
                     Graphics.GPipe.FrameBuffer,
-                    Graphics.GPipe.Stream,
-                    Graphics.GPipe.Stream.Fragment,
-                    Graphics.GPipe.Stream.Primitive,
-                    Graphics.GPipe.Texture
+                    Graphics.GPipe.PrimitiveArray,
+                    Graphics.GPipe.PrimitiveStream,
+                    Graphics.GPipe.Sampler,
+                    Graphics.GPipe.Shader,
+                    Graphics.GPipe.Texture,
+                    Graphics.GPipe.Uniform
+  other-modules:    
+                    Data.SNMap,
+                    Graphics.GPipe.Internal.Buffer,
+                    Graphics.GPipe.Internal.Compiler,
+                    Graphics.GPipe.Internal.Context,
+                    Graphics.GPipe.Internal.Expr,
+                    Graphics.GPipe.Internal.Format,
+                    Graphics.GPipe.Internal.FragmentStream,
+                    Graphics.GPipe.Internal.FrameBuffer,
+                    Graphics.GPipe.Internal.PrimitiveArray,
+                    Graphics.GPipe.Internal.PrimitiveStream,
+                    Graphics.GPipe.Internal.Shader,
+                    Graphics.GPipe.Internal.Texture,
+                    Graphics.GPipe.Internal.Uniform
+  

@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2015 Tobias Bexelius++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

@@ -1,6 +0,0 @@-#!/usr/bin/runhaskell -> module Main where-> import Distribution.Simple-> main :: IO ()-> main = defaultMain-

@@ -0,0 +1,49 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, RankNTypes #-}
+
+module Data.SNMap (
+    SNMap,
+    SNMapReaderT,
+    runSNMapReaderT,
+    newSNMap,
+    memoize,    
+    memoizeM    
+)where
+
+import System.Mem.StableName 
+import qualified Data.HashTable.IO as HT 
+import Data.Functor
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Control.Monad.Trans.Class
+import System.Mem.Weak (addFinalizer)
+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
+import Control.Applicative (Applicative)
+import Control.Monad.Exception (MonadException, MonadAsyncException)
+
+newtype SNMap m a = SNMap (HT.BasicHashTable (StableName (m a)) a)
+
+newSNMap :: IO (SNMap m a)
+newSNMap = SNMap <$> HT.new
+
+memoize :: MonadIO m => SNMap m a -> m a -> m a
+memoize (SNMap h) m = do s <- liftIO $ makeStableName $! m
+                         x <- liftIO $ HT.lookup h s
+                         case x of
+                                Just a -> return a
+                                Nothing -> do a <- m
+                                              liftIO $ do
+                                                  HT.insert h s a
+                                                  addFinalizer m (HT.delete h s)
+                                              return a
+
+newtype SNMapReaderT a m b = SNMapReaderT (ReaderT (SNMap (SNMapReaderT a m) a) m b) deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadAsyncException)
+
+runSNMapReaderT :: MonadIO m => SNMapReaderT a m b -> m b
+runSNMapReaderT (SNMapReaderT m) = do h <- liftIO newSNMap
+                                      runReaderT m h 
+
+instance MonadTrans (SNMapReaderT a) where
+    lift = SNMapReaderT . lift
+
+memoizeM :: MonadIO m => SNMapReaderT a m a -> SNMapReaderT a m a
+memoizeM m = do h <- SNMapReaderT ask
+                memoize h m

@@ -1,289 +0,0 @@-{-# LANGUAGE UndecidableInstances, TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}------------------------------------------------------------------------------------ Module      :  Formats--- Copyright   :  Tobias Bexelius--- License     :  BSD3------ Maintainer  :  Tobias Bexelius--- Stability   :  Experimental--- Portability :  Portable------ |-----------------------------------------------------------------------------------module Formats-(-    AlphaFormat(..),-    DepthFormat(..),-    StencilFormat(..),-    LuminanceFormat(..),-    LuminanceAlphaFormat(..),-    RGBFormat(..),-    RGBAFormat(..),-    CPUFormat4Comp(..),-    CPUFormat3Comp(..),-    CPUFormat2Comp(..),-    CPUFormat1Comp(..),-    StorableCPUFormat(toGLDataType),-    formatRowByteSize,-    GPUFormat(..),-    ColorFormat(fromColor,toColor), -- (..) will give a warning that Color is exported twice, even though we need to export it explicitly to get its constructors-    Color(..),-    Depth,-    Stencil-)-where-import qualified Graphics.Rendering.OpenGL as GL-import Data.Vec ((:.)(..), Vec3, Vec4, zipWith)-import Prelude hiding (zipWith)-import Data.Boolean-import Data.Vec.Boolean---- | A GPU format with only an alpha value.--- These are the associated types in 'GPUFormat' and 'ColorFormat':------ [@CPUFormat AlphaFormat@] 'CPUFormat1Comp'------ [@Color AlphaFormat a@] @Alpha a@-data AlphaFormat = Alpha4 | Alpha8 | Alpha12 | Alpha16 deriving (Eq,Ord,Bounded,Enum,Show)--- | A GPU format with a single color component.--- These are the associated types in 'GPUFormat' and 'ColorFormat':------ [@CPUFormat LuminanceFormat@] 'CPUFormat1Comp'------ [@Color LuminanceFormat a@] @Luminance a@-data LuminanceFormat = Luminance4 | Luminance8 | Luminance12 | Luminance16 | SLuminance8 deriving (Eq,Ord,Bounded,Enum,Show)--- | A GPU format with a single color component and an alpha value.--- These are the associated types in 'GPUFormat' and 'ColorFormat':------ [@CPUFormat LuminanceAlphaFormat@] 'CPUFormat2Comp'------ [@Color LuminanceAlphaFormat a@] @LuminanceAlpha a a@-data LuminanceAlphaFormat = Luminance4Alpha4 | Luminance6Alpha2 | Luminance8Alpha8 | Luminance12Alpha4 | Luminance12Alpha12 | Luminance16Alpha16 | SLuminance8Alpha8 deriving (Eq,Ord,Bounded,Enum,Show)--- | A GPU format with color components for red, green and blue.--- These are the associated types in 'GPUFormat' and 'ColorFormat':------ [@CPUFormat RGBFormat@] 'CPUFormat3Comp'------ [@Color RGBFormat a@] @RGB (@'Vec3'@ a)@-data RGBFormat = R3G3B2 | RGB4 | RGB5 | RGB8 | RGB10 | RGB12 | RGB16 | SRGB8 deriving (Eq,Ord,Bounded,Enum,Show)--- | A GPU format with color components for red, green and blue, and an alpha value.--- These are the associated types in 'GPUFormat' and 'ColorFormat':------ [@CPUFormat RGBAFormat@] 'CPUFormat4Comp'------ [@Color RGBAFormat a@] @RGBA (@'Vec3'@ a) a@-data RGBAFormat = RGBA2 | RGBA4 | RGB5A1 | RGBA8 | RGB10A2 | RGBA12 | RGBA16 | SRGBA8 deriving (Eq,Ord,Bounded,Enum,Show)--- | A GPU format for a depth buffer value.--- This is the associated type in 'GPUFormat':------ [@CPUFormat DepthFormat@] 'CPUFormat1Comp'-data DepthFormat = Depth16 | Depth24 | Depth32 deriving (Eq,Ord,Bounded,Enum,Show)--- | A GPU format for a stencil buffer value.--- This is the associated type in 'GPUFormat':------ [@CPUFormat StencilFormat@] 'CPUFormat1Comp'-data StencilFormat = StencilFormat deriving (Eq,Ord,Bounded,Enum,Show)---- | A CPU format for 4 components (i.e. a RGBA color).-data CPUFormat4Comp = PerComp4 CPUFormat1Comp-                        | UnsignedShort4_4_4_4-                        | UnsignedShort4_4_4_4_Rev-                        | UnsignedShort5_5_5_1-                        | UnsignedShort1_5_5_5_Rev                       -                        | UnsignedInt8_8_8_8-                        | UnsignedInt8_8_8_8_Rev-                        | UnsignedInt10_10_10_2-                        | UnsignedInt2_10_10_10_Rev-                        deriving (Eq,Ord,Show)---- | A CPU format for 3 components (i.e. a RGB color).-data CPUFormat3Comp = PerComp3 CPUFormat1Comp-                        | UnsignedByte3_3_2-                        | UnsignedByte2_3_3_Rev-                        | UnsignedShort5_6_5-                        | UnsignedShort5_6_5_Rev-                        deriving (Eq,Ord,Show)---- | A CPU format for 2 components (i.e. a LuminanceAlpha color).-data CPUFormat2Comp = PerComp2 CPUFormat1Comp-                        deriving (Eq,Ord,Show)---- | A CPU format for 1 component-data CPUFormat1Comp = UnsignedByteFormat-                        | BitmapFormat-                        | ByteFormat-                        | UnsignedShortFormat-                        | ShortFormat-                        | UnsignedIntFormat-                        | IntFormat-                        | FloatFormat-                        deriving (Eq,Ord,Show)--class StorableCPUFormat a where-    sizeOfFormat :: a -> Int-    toGLDataType :: a -> GL.DataType--formatRowByteSize :: StorableCPUFormat a => a -> Int -> Int-formatRowByteSize f x = (x*sizeOfFormat f-1) `div` 8 + 1--instance StorableCPUFormat CPUFormat4Comp where-    sizeOfFormat (PerComp4 a) = 4 * sizeOfFormat a -    sizeOfFormat UnsignedShort4_4_4_4 = 16-    sizeOfFormat UnsignedShort4_4_4_4_Rev = 16-    sizeOfFormat UnsignedShort5_5_5_1 = 16-    sizeOfFormat UnsignedShort1_5_5_5_Rev = 16-    sizeOfFormat UnsignedInt8_8_8_8 = 32-    sizeOfFormat UnsignedInt8_8_8_8_Rev = 32-    sizeOfFormat UnsignedInt10_10_10_2 = 32-    sizeOfFormat UnsignedInt2_10_10_10_Rev = 32-    toGLDataType (PerComp4 a) = toGLDataType a -    toGLDataType UnsignedShort4_4_4_4 = GL.UnsignedShort4444-    toGLDataType UnsignedShort4_4_4_4_Rev = GL.UnsignedShort4444Rev-    toGLDataType UnsignedShort5_5_5_1 = GL.UnsignedShort5551-    toGLDataType UnsignedShort1_5_5_5_Rev = GL.UnsignedShort1555Rev-    toGLDataType UnsignedInt8_8_8_8 = GL.UnsignedInt8888-    toGLDataType UnsignedInt8_8_8_8_Rev = GL.UnsignedInt8888Rev-    toGLDataType UnsignedInt10_10_10_2 = GL.UnsignedInt1010102-    toGLDataType UnsignedInt2_10_10_10_Rev = GL.UnsignedInt2101010Rev-instance StorableCPUFormat CPUFormat3Comp where-    sizeOfFormat (PerComp3 a) = 3 * sizeOfFormat a -    sizeOfFormat UnsignedByte3_3_2 = 8-    sizeOfFormat UnsignedByte2_3_3_Rev = 8-    sizeOfFormat UnsignedShort5_6_5 = 16-    sizeOfFormat UnsignedShort5_6_5_Rev = 16-    toGLDataType (PerComp3 a) = toGLDataType a -    toGLDataType UnsignedByte3_3_2 = GL.UnsignedByte332-    toGLDataType UnsignedByte2_3_3_Rev = GL.UnsignedByte233Rev-    toGLDataType UnsignedShort5_6_5 = GL.UnsignedShort565-    toGLDataType UnsignedShort5_6_5_Rev = GL.UnsignedShort565Rev--instance StorableCPUFormat CPUFormat2Comp where-    sizeOfFormat (PerComp2 a) = 2 * sizeOfFormat a-    toGLDataType (PerComp2 a) = toGLDataType a --instance StorableCPUFormat CPUFormat1Comp where-    sizeOfFormat UnsignedByteFormat = 8 -    sizeOfFormat BitmapFormat = 1-    sizeOfFormat ByteFormat = 8-    sizeOfFormat UnsignedShortFormat = 16-    sizeOfFormat ShortFormat = 16-    sizeOfFormat UnsignedIntFormat = 32-    sizeOfFormat IntFormat = 32-    sizeOfFormat FloatFormat = 32-    toGLDataType UnsignedByteFormat = GL.UnsignedByte-    toGLDataType BitmapFormat = GL.Bitmap-    toGLDataType ByteFormat = GL.Byte-    toGLDataType UnsignedShortFormat = GL.UnsignedShort-    toGLDataType ShortFormat = GL.Short-    toGLDataType UnsignedIntFormat = GL.UnsignedInt-    toGLDataType IntFormat = GL.Int-    toGLDataType FloatFormat = GL.Float--class (StorableCPUFormat (CPUFormat f), Eq (CPUFormat f))=> GPUFormat f where-    type CPUFormat f-    toGLInternalFormat :: f -> GL.PixelInternalFormat-    toGLPixelFormat :: f -> GL.PixelFormat---- | This context is used to select which types can be used in a frame buffers color buffer, and also--- to restrict the type of a texture.-class GPUFormat f => ColorFormat f where-    data Color f :: * -> *-    fromColor :: a -> a -> Color f a -> Vec4 a-    toColor :: Vec4 a -> Color f a--type Depth = Float-type Stencil = Int--instance GPUFormat AlphaFormat where-    type CPUFormat AlphaFormat = CPUFormat1Comp-    toGLInternalFormat Alpha4 = GL.Alpha4-    toGLInternalFormat Alpha8 = GL.Alpha8-    toGLInternalFormat Alpha12 = GL.Alpha12-    toGLInternalFormat Alpha16 = GL.Alpha16-    toGLPixelFormat _ = GL.Alpha-instance GPUFormat DepthFormat where-    type CPUFormat DepthFormat = CPUFormat1Comp-    toGLInternalFormat Depth16 = GL.DepthComponent16-    toGLInternalFormat Depth24 = GL.DepthComponent24-    toGLInternalFormat Depth32 = GL.DepthComponent32-    toGLPixelFormat _ = GL.DepthComponent-instance GPUFormat StencilFormat where-    type CPUFormat StencilFormat = CPUFormat1Comp-    toGLInternalFormat = error "Stencil has no GLFormat"-    toGLPixelFormat _ = GL.StencilIndex-instance GPUFormat LuminanceFormat where-    type CPUFormat LuminanceFormat = CPUFormat1Comp-    toGLInternalFormat Luminance4 = GL.Luminance4-    toGLInternalFormat Luminance8 = GL.Luminance8-    toGLInternalFormat Luminance12 = GL.Luminance12-    toGLInternalFormat Luminance16 = GL.Luminance16-    toGLInternalFormat SLuminance8 = GL.SLuminance8-    toGLPixelFormat _ = GL.Luminance-instance GPUFormat LuminanceAlphaFormat where-    type CPUFormat LuminanceAlphaFormat = CPUFormat2Comp-    toGLInternalFormat Luminance4Alpha4 = GL.Luminance4Alpha4-    toGLInternalFormat Luminance6Alpha2 = GL.Luminance6Alpha2-    toGLInternalFormat Luminance8Alpha8 = GL.Luminance8Alpha8-    toGLInternalFormat Luminance12Alpha4 = GL.Luminance12Alpha4-    toGLInternalFormat Luminance12Alpha12 = GL.Luminance12Alpha12-    toGLInternalFormat Luminance16Alpha16 = GL.Luminance16Alpha16-    toGLInternalFormat SLuminance8Alpha8 = GL.SLuminance8Alpha8-    toGLPixelFormat _ = GL.LuminanceAlpha-instance GPUFormat RGBFormat where-    type CPUFormat RGBFormat = CPUFormat3Comp-    toGLInternalFormat R3G3B2 = GL.R3G3B2-    toGLInternalFormat RGB4 = GL.RGB4-    toGLInternalFormat RGB5 = GL.RGB5-    toGLInternalFormat RGB8 = GL.RGB8-    toGLInternalFormat RGB10 = GL.RGB10-    toGLInternalFormat RGB12 = GL.RGB12-    toGLInternalFormat RGB16 = GL.RGB16-    toGLInternalFormat SRGB8 = GL.SRGB8-    toGLPixelFormat _ = GL.RGB-instance GPUFormat RGBAFormat where-    type CPUFormat RGBAFormat = CPUFormat4Comp-    toGLInternalFormat RGBA2 = GL.RGBA2-    toGLInternalFormat RGBA4 = GL.RGBA4-    toGLInternalFormat RGB5A1 = GL.RGB5A1-    toGLInternalFormat RGBA8 = GL.RGBA8-    toGLInternalFormat RGB10A2 = GL.RGB10A2-    toGLInternalFormat RGBA12 = GL.RGBA12-    toGLInternalFormat RGBA16 = GL.RGBA16-    toGLInternalFormat SRGBA8 = GL.SRGB8Alpha8-    toGLPixelFormat _ = GL.RGBA--instance ColorFormat AlphaFormat where-    data Color AlphaFormat a = Alpha a deriving (Eq,Ord,Show)-    fromColor x _ (Alpha a) = x:.x:.x:.a:.()-    toColor (_:._:._:.d:.()) = Alpha d-instance ColorFormat LuminanceFormat where-    data Color LuminanceFormat a = Luminance a deriving (Eq,Ord,Show)-    fromColor x w (Luminance a) = a:.x:.x:.w:.()-    toColor (a:._:._:._:.()) = Luminance a-instance ColorFormat LuminanceAlphaFormat where-    data Color LuminanceAlphaFormat a = LuminanceAlpha a a deriving (Eq,Ord,Show)-    fromColor x _ (LuminanceAlpha a b) = a:.x:.x:.b:.()-    toColor (a:._:._:.d:.()) = LuminanceAlpha a d-instance ColorFormat RGBFormat where-    data Color RGBFormat a = RGB (Vec3 a) deriving (Eq,Ord,Show)-    fromColor _ w (RGB (a:.b:.c:.())) = a:.b:.c:.w:.()-    toColor (a:.b:.c:._:.()) = RGB $ a:.b:.c:.()-instance ColorFormat RGBAFormat where-    data Color RGBAFormat a = RGBA (Vec3 a) a deriving (Eq,Ord,Show)-    fromColor _ _ (RGBA (a:.b:.c:.()) d) = a:.b:.c:.d:.()-    toColor (a:.b:.c:.d:.()) = RGBA (a:.b:.c:.()) d--instance IfB bool a => IfB bool (Color AlphaFormat a) where-    ifB c (Alpha t) (Alpha e) = Alpha (ifB c t e)-instance IfB bool a => IfB bool (Color LuminanceFormat a) where-    ifB c (Luminance t) (Luminance e) = Luminance (ifB c t e)-instance IfB bool a => IfB bool (Color LuminanceAlphaFormat a) where-    ifB c (LuminanceAlpha t1 t2) (LuminanceAlpha e1 e2) = LuminanceAlpha (ifB c t1 e1) (ifB c t2 e2)-instance IfB bool a => IfB bool (Color RGBFormat a) where-    ifB c (RGB t) (RGB e) = RGB (ifB c t e)-instance IfB bool a => IfB bool (Color RGBAFormat a) where-    ifB c (RGBA t1 t2) (RGBA e1 e2) = RGBA (ifB c t1 e1) (ifB c t2 e2)-    

@@ -1,165 +0,0 @@------------------------------------------------------------------------------------ Module      :  GPUStream--- Copyright   :  Tobias Bexelius--- License     :  BSD3------ Maintainer  :  Tobias Bexelius--- Stability   :  Experimental--- Portability :  Portable------ |--------------------------------------------------------------------------------module GPUStream (-    PrimitiveStream(..),-    FragmentStream(..),-    VertexPosition,-    CullMode(..),-    Primitive(..),-    Triangle(..),-    Line(..),-    Point(..),-    VertexSetup(..),-    PrimitiveStreamDesc,-    FragmentStreamDesc,-    filterFragments,-    loadFragmentColorStream,-    loadFragmentDepthStream,-    loadFragmentColorDepthStream,-    loadFragmentAnyStream-) where--import Shader-import Formats-import Data.Monoid-import Data.Vec (Vec4)-import Resources-import qualified Graphics.Rendering.OpenGL as GL (PrimitiveMode(..))-import Graphics.Rendering.OpenGL (cullFace, ($=), Face(..))-import Control.Arrow (first, second)---- | A stream of primitives built by vertices on the GPU. The first parameter is the primitive type (currently 'Triangle', 'Line' or 'Point') and the second the--- the type of each primitives' vertices' type (built up of atoms of type 'Vertex').-data PrimitiveStream p a = PrimitiveStreamNoShader PrimitiveStreamDesc a | PrimitiveStreamShader [(PrimitiveStreamDesc, a)]--- | A stream of fragments on the GPU, parameterized on the fragments type--- (built up of atoms of type 'Fragment').-newtype FragmentStream a = FragmentStream [(FragmentStreamDesc, Fragment Bool, a)]--type VertexPosition                               = Vec4 (Vertex Float)-data CullMode                                     = CullNone | CullFront | CullBack  deriving (Eq,Ord,Bounded,Enum,Show)-data VertexSetup                                  = VertexSetup [[Float]] | IndexedVertexSetup [[Float]] [Int]  deriving (Eq,Ord,Show)-type PrimitiveStreamDesc                          = [(GL.PrimitiveMode, VertexSetup)]-type FragmentStreamDesc                           = (PrimitiveStreamDesc, CullMode, Vec4 (Vertex Float))--instance Functor (PrimitiveStream p) where-    fmap f (PrimitiveStreamNoShader [] a)         = PrimitiveStreamNoShader [] $ f a-    fmap f (PrimitiveStreamNoShader xs a)         = PrimitiveStreamShader [(xs, f a)]-    fmap f (PrimitiveStreamShader xs)             = PrimitiveStreamShader $ map (second f) xs-instance Functor FragmentStream where-    fmap f (FragmentStream a)                     = FragmentStream $ map (\(x,y,z) -> (x, y, f z)) a--instance Monoid (PrimitiveStream p a) where-    mempty                                        = PrimitiveStreamNoShader [] undefined-    PrimitiveStreamNoShader [] _ `mappend` a      = a-    a `mappend` PrimitiveStreamNoShader [] _      = a-    PrimitiveStreamNoShader xs a `mappend` PrimitiveStreamNoShader ys _ = PrimitiveStreamNoShader (xs ++ ys) a -- Optimization!-    PrimitiveStreamShader xs `mappend` PrimitiveStreamShader ys = PrimitiveStreamShader $ xs ++ ys-    PrimitiveStreamNoShader xs a `mappend` PrimitiveStreamShader ys = PrimitiveStreamShader $ (xs, a):ys-    PrimitiveStreamShader xs `mappend` PrimitiveStreamNoShader ys a = PrimitiveStreamShader $ xs ++ [(ys, a)]-instance Monoid (FragmentStream a) where-    mempty                                        = FragmentStream []-    FragmentStream a `mappend` FragmentStream b   = FragmentStream (a ++ b)---- | Filters out fragments in a stream where the provided function returns 'true'.-filterFragments :: (a -> Fragment Bool) -> FragmentStream a -> FragmentStream a-filterFragments f (FragmentStream xs)             = FragmentStream $ map filterOne xs-    where filterOne (fdesc, b, a)                    = (fdesc, b &&* f a, a)-    ---------------------------------------------class Primitive p where-    getPrimitiveMode :: p -> GL.PrimitiveMode--data Triangle = TriangleStrip | TriangleList | TriangleFan deriving (Eq,Ord,Bounded,Enum,Show)-data Line = LineStrip | LineList deriving (Eq,Ord,Bounded,Enum,Show)-data Point = PointList deriving (Eq,Ord,Bounded,Enum,Show)--instance Primitive Triangle where-    getPrimitiveMode TriangleStrip = GL.TriangleStrip-    getPrimitiveMode TriangleList = GL.Triangles-    getPrimitiveMode TriangleFan = GL.TriangleFan-instance Primitive Line where-    getPrimitiveMode LineStrip = GL.LineStrip-    getPrimitiveMode LineList = GL.Lines-instance Primitive Point where-    getPrimitiveMode PointList = GL.Points--------------------------------------------loadFragmentColorStream :: ColorFormat f => FragmentStream (Color f (Fragment Float)) -> ContextCacheIO () -> ContextCacheIO ()-loadFragmentColorStream = loadFragmentColorStream' . fmap (fromColor 0 1)-    where loadFragmentColorStream' (FragmentStream xs) = layerMapM_ drawCallColor xs-loadFragmentDepthStream :: FragmentStream (Fragment Float) -> ContextCacheIO () -> ContextCacheIO ()-loadFragmentDepthStream (FragmentStream xs) = layerMapM_ (drawCallColorDepth  . setDefaultColor) xs-                                              where-                                                  setDefaultColor (desc, notDisc, d) = (desc, notDisc, (0,d))--loadFragmentColorDepthStream :: ColorFormat f => FragmentStream (Color f (Fragment Float), Fragment Float) -> ContextCacheIO () -> ContextCacheIO ()-loadFragmentColorDepthStream = loadFragmentColorDepthStream' . fmap (first (fromColor 0 1))-    where loadFragmentColorDepthStream' (FragmentStream xs) = layerMapM_ drawCallColorDepth xs-loadFragmentAnyStream :: FragmentStream a -> ContextCacheIO () -> ContextCacheIO ()-loadFragmentAnyStream (FragmentStream xs) = layerMapM_ (drawCallColor  . setDefaultColor) xs-                                            where-                                                setDefaultColor (desc, notDisc, _) = (desc, notDisc, 0)--layerMapM_ f (x:xs) io = layerMapM_ f xs (f x io)-layerMapM_ _ [] io = io--drawCallColor ((vss, cull, vPos), nd, c) io = drawCall vss cull io $ getShaders vPos nd c Nothing-drawCallColorDepth ((vss, cull, vPos), nd, (c,d)) io = drawCall vss cull io $ getShaders vPos nd c (Just d)--mapSelect = map . select-    where select (x:xs) ys = let (a:b) = drop x ys-                             in a: select (map (\t-> t-x-1) xs) b-          select [] _      = []--drawCall vss cull io ((vkey,vstr,vuns), (fkey,fstr,funs), ins) = do-    vss' <- mapM (evalVertexSetups ins) vss-    vkey' <- ioEvaluate vkey-    fkey' <- ioEvaluate fkey-    s <- ioEvaluate (length ins)-    vuns' <- ioEvaluate vuns-    funs' <- ioEvaluate funs-    cull' <- ioEvaluate cull-    io-    (pr, (vu, fu)) <- createProgramResource vkey' vstr fkey' fstr s-    useProgramResource pr-    useUniforms vu vuns'-    useUniforms fu funs'-    liftIO $ useCull cull'-    mapM_ (drawVertexSetups ins) vss'--evalVertexSetups ins (p, VertexSetup v) = do-    xs <- ioEvaluate (mapSelect ins v)-    vs <- ioEvaluate (length v)-    p' <- ioEvaluate p-    return (v, xs, p', vs, Nothing)-evalVertexSetups ins (p, IndexedVertexSetup v i) = do-    xs <- ioEvaluate (mapSelect ins v)-    i' <- ioEvaluate i-    vs <- ioEvaluate (length v)-    p' <- ioEvaluate p-    return (v, xs, p', vs, Just i')-   -drawVertexSetups ins (v, xs, p', vs, Nothing) = do-    vb <- createVertexBuffer xs ins v-    liftIO $ drawVertexBuffer p' vb vs-drawVertexSetups ins (v, xs, p', vs, Just i') = do-    ib <- createIndexBuffer i' vs-    vb <- createVertexBuffer xs ins v-    liftIO $ drawIndexVertexBuffer p' vb ib--useCull CullNone = cullFace $= Nothing-useCull CullFront = cullFace $= Just Front-useCull CullBack = cullFace $= Just Back

@@ -1,31 +1,47 @@------------------------------------------------------------------------------------ Module      :  GPipe--- Copyright   :  Tobias Bexelius--- License     :  BSD3------ Maintainer  :  Tobias Bexelius--- Stability   :  Experimental--- Portability :  Portable------ |--- GPipe models the entire graphics pipeline in a purely functional, immutable and typesafe way. It is built on top of the programmable pipeline (i.e. non-fixed function) of--- OpenGL 2.1 and uses features such as vertex buffer objects (VBO's), texture objects and GLSL shader code synthetisation to create fast graphics programs. Buffers,--- textures and shaders are cached internally to ensure fast framerate, and GPipe is also capable of managing multiple windows and contexts. By creating your own--- instances of GPipes classes, it's possible to use additional datatypes on the GPU.------ You'll need full OpenGL 2.1 support, including GLSL 1.20 to use GPipe. Thanks to OpenGLRaw, you may still build GPipe programs on machines lacking this support.------ This is a conveniance module, combining GPipes all other modules.--------------------------------------------------------------------------------module Graphics.GPipe (-    module X-) where--import Graphics.GPipe.Stream as X-import Graphics.GPipe.Stream.Primitive as X-import Graphics.GPipe.Stream.Fragment as X-import Graphics.GPipe.FrameBuffer as X-import Graphics.GPipe.Texture as X-import Graphics.GPipe.Format as X+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- A typesafe API based on the conceptual model of OpenGl, but without the imperative state machine. 
+-- Aims to be as close to the raw OpenGl performance as possible, without compromising type safety or functional style. 
+-- Includes DSL for shaders to provide type safety even when crossing into that domain.
+--  Uses OpenGl 3.3 core profile under the hood.
+--
+-- This is a convenience module, combining GPipes all other modules.
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe (
+    module Graphics.GPipe.Context,
+    module Graphics.GPipe.Format,
+    module Graphics.GPipe.Buffer,
+    module Graphics.GPipe.PrimitiveArray,
+    module Graphics.GPipe.PrimitiveStream,
+    module Graphics.GPipe.FragmentStream,
+    module Graphics.GPipe.FrameBuffer,
+    module Graphics.GPipe.Shader,
+    module Graphics.GPipe.Expr,
+    module Graphics.GPipe.Uniform,
+    module Graphics.GPipe.Texture,
+    module Graphics.GPipe.Sampler
+)
+where
+
+import Graphics.GPipe.Context
+import Graphics.GPipe.Format
+import Graphics.GPipe.Buffer
+import Graphics.GPipe.PrimitiveArray
+import Graphics.GPipe.PrimitiveStream
+import Graphics.GPipe.FragmentStream
+import Graphics.GPipe.FrameBuffer
+import Graphics.GPipe.Shader
+import Graphics.GPipe.Expr
+import Graphics.GPipe.Uniform
+import Graphics.GPipe.Texture
+import Graphics.GPipe.Sampler

@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}
+
+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.Buffer
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- Buffers are arrays of data that resides on the GPU. A buffer is strongly typed with an immutable size, but it's content is mutable. A buffer lives in
+-- an object space and may be shared between contexts.
+--
+-- Buffers in GPipe are used to store vertices, indices and uniform values and can also be used to copy pixel data to and from textures. They can be written 
+-- from the host (ie the normal Haskell world) but cannot be read back (but textures can).
+--
+-- The atomic buffer element types are @'B' a@, @'B2' a@, @'B3' a@ and @'B4' a@ where @a@ is a normal haskell type such as 'Int32' or 'Float'. By creating instances of the
+-- type class 'BufferFormat' you may create new composite buffer types. 
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe.Buffer (
+    -- * Buffer data type
+    Buffer(),
+    BufferFormat(type HostFormat, toBuffer),
+    ToBuffer(),
+    
+    -- * Atomic buffer types
+    -- | These types represent primitive host values such as 'Float' and 'Int32' in a buffer. @'B2' a@, @'B3' a@ and @'B4' a@ represent vectors of 2, 3 and 4 values of host type @a@.
+    --   You cannot do anything special with values of these lifted types (like add two @'B' 'Float'@s), only convert it into something useful later, e.g. in a 'PrimitiveStream'.
+    --
+    --   Since vertex arrays have to be 4 byte aligned, only combinations that add up to a multiple of 4 byte is provided (except for some instances of @'B3' a@ which will be automatically padded when necessary).       
+    B(), B2(), B3(), B4(), BPacked(),
+    Normalized(..), 
+
+    -- * Operating on Buffers
+    newBuffer,
+    bufferLength,
+    writeBuffer,
+    copyBuffer,
+    BufferStartPos,        
+    
+    -- * Buffer colors
+    BufferColor,
+)
+where
+
+import Graphics.GPipe.Internal.Buffer 

@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.Context
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- A Context in GPipe (just as in OpenGl) consist of two things, a window and an object space. The object space consists of Buffers, Textures and Shaders. 
+-- You may create a context without a window (for example for rendering to textures that are saved as pngs instead of showed), and you can create a 
+-- context that shares the object space with another context. 
+--
+-- Context creation is abstracted away from GPipe, and you need a package that provides a 'ContextFactory', such as @GPipe-GLFW@.
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe.Context (
+    -- * The ContextT monad transformer
+    ContextT(),
+    runContextT,
+    runSharedContextT,
+    getContextBuffersSize,    
+    swapContextBuffers,
+    -- * External interfaces
+    -- | Users of GPipe shouldn't bother with these functions, instead use a separate window manager package such as GPipe-GLFW that will provide you with
+    --   a function of type 'ContextFactory'.
+    --
+    --   To create a window manager package, create a 'ContextFactory' function that provides a 'ContextHandle' with all functionality needed.
+    ContextFactory,
+    ContextHandle(..),
+    withContextWindow,
+    -- * Hardware exceptions
+    GPipeException(..),
+)
+where
+
+import Graphics.GPipe.Internal.Context 

@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.Expr
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- This module provides the DSL for shader operations in GPipe. The type @'S' x a@ is an opaque type that represents a value of type @a@ in a shader stage @x@, eg @S F Float@ means a
+-- floating point value in a fragment stream.
+--
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe.Expr (
+    -- * Atomic shader type
+    S(),   
+    V, F,
+    VFloat, VInt, VWord, VBool,
+    FFloat, FInt, FWord, FBool,
+
+    -- * Type classes where the Prelude ones are lacking
+    Convert(..),
+    Integral'(..),
+    Real'(..),
+    module Data.Boolean,
+
+    -- * Additional functions
+    dFdx,
+    dFdy,
+    fwidth,
+
+    -- * Shader control structures    
+    ShaderBase(),
+    ShaderType(..),   
+    while,
+    ifThen,
+    ifThenElse,
+    ifThenElse'    
+)
+where
+
+import Data.Boolean
+import Graphics.GPipe.Internal.Expr

@@ -1,40 +1,35 @@-{-# LANGUAGE TypeFamilies #-}
------------------------------------------------------------------------------------ Module      :  Graphics.GPipe.Format--- Copyright   :  Tobias Bexelius--- License     :  BSD3------ Maintainer  :  Tobias Bexelius--- Stability   :  Experimental--- Portability :  Portable------ | This module defines the various formats that are used by 'FrameBuffer's and textures, both--- on the GPU and the CPU.--------------------------------------------------------------------------------module Graphics.GPipe.Format (-    -- * GPU formats-    AlphaFormat(..),-    LuminanceFormat(..),-    LuminanceAlphaFormat(..),-    RGBFormat(..),-    RGBAFormat(..),-    DepthFormat(..),-    StencilFormat(..),-    GPUFormat(type CPUFormat),-    ColorFormat(),-    Color(..),-    Depth,-    Stencil,-    -- * CPU formats-    CPUFormat4Comp(..),-    CPUFormat3Comp(..),-    CPUFormat2Comp(..),-    CPUFormat1Comp(..),-    StorableCPUFormat(),--) where--import Formats-+{-# LANGUAGE TypeFamilies          #-}
+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.Format
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- This module provides data types for all formats of textures and frame buffers. None of the type classes in this module are intended to be instanced by anyone else. In fact, 
+-- GPipe only uses these type classes through the GADT 'Format', which is closed, so any new instances wouldnt be considered anyway. 
+
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe.Format (
+    -- * Texture formats
+    Format(..), 
+    TextureFormat(),
+    RFloat, RInt, RWord, RGFloat, RGInt, RGWord, RGBFloat, RGBInt, RGBWord, RGBAFloat, RGBAInt, RGBAWord, Depth, Stencil, DepthStencil, 
+    -- * Format constraints    
+    ColorSampleable(type Color, type ColorElement),
+    ColorRenderable(),
+    DepthRenderable(),
+    StencilRenderable(),
+    -- * Context formats
+    ContextFormat(..),
+    ContextColorFormat(),
+    contextBits,
+) 
+where
+
+import Graphics.GPipe.Internal.Format 

@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.FragmentStream
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- A 'Graphics.GPipe.PrimitiveStream.PrimitiveStream' can be rasterized, i.e. chopped up in pixel sized fragments, each of which contains an interpolated value of the primitives vertices, producing
+-- a 'FragmentStream'.
+
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe.FragmentStream (
+    -- * The data type
+    FragmentStream(),
+    FragmentInput(..),
+    ToFragment(),
+    FlatVFloat(..),
+    NoPerspectiveVFloat(..),
+
+    -- * Creating FragmentStreams
+    rasterize,
+    VPos,
+    Side(..),
+    ViewPort(..),
+    DepthRange(..),
+    
+    -- * Various FragmentStream operations   
+    filterFragments,   
+    withRasterizedInfo,
+    RasterizedInfo(..),
+)
+where
+
+import Graphics.GPipe.Internal.FragmentStream

@@ -1,72 +1,85 @@------------------------------------------------------------------------------------ Module      :  Graphics.GPipe.FrameBuffer--- Copyright   :  Tobias Bexelius--- License     :  BSD3------ Maintainer  :  Tobias Bexelius--- Stability   :  Experimental--- Portability :  Portable------ | 'FrameBuffer's are 2D images in which fragments from 'FragmentStream's are painted. A 'FrameBuffer'--- may contain any combination of a color buffer, a depth buffer and a stencil buffer.--- 'FrameBuffer's may be shown in windows, saved to memory or converted to textures.--- 'FrameBuffer's have no size, but takes the size of the window when shown, or are given a size when--- saved to memory or converted to a texture.--------------------------------------------------------------------------------module Graphics.GPipe.FrameBuffer (-    -- * The data type-    FrameBuffer(),-    -- * Displaying framebuffers-    newWindow,-    -- * Creation-    -- | These functions create new 'FrameBuffer's with initial color, depth values and\/or stencil values.-    newFrameBufferColor,-    newFrameBufferColorDepth,-    newFrameBufferColorStencil,-    newFrameBufferColorDepthStencil,-    newFrameBufferDepth,-    newFrameBufferStencil,-    newFrameBufferDepthStencil,-    -- * Data retrieval-    -- | These functions provides the means for saving a 'FrameBuffer' to main memory without the need to-    -- show it in a window.-    getFrameBufferColor,-    getFrameBufferDepth,-    getFrameBufferStencil,-    getFrameBufferCPUFormatByteSize,-    -- * Paint operations-    -- | These functions paint 'FragmentStream's on 'FrameBuffer's. A lot of different functions are-    -- provided for different types of 'FrameBuffer's and 'FragmentStream's, all which takes more or less-    -- state values. The preffered way of using those is to curry them into the specific  functions you need-    -- in your GPipe program, e.g.-    ---    -- @paintSolid =@ 'paintColorRastDepth' 'Lequal' 'True' 'NoBlending' @(RGB (vec@ 'True'@))@-    ---    -- The @RastDepth@-functions uses the rasterized depth for the fragments.-    ---    -- Functions with two 'StencilOps' arguments use them in this order: First if stencil test fail, second if stencil test pass.-    -- Functions with three 'StencilOps' arguments use them in this order: First if stencil test fail, second if depth test fail, third if depth test pass.-    paintColor,-    paintDepth,-    paintColorDepth,-    paintStencil,-    paintDepthStencil,-    paintColorStencil,-    paintColorDepthStencil,-    paintRastDepth,-    paintColorRastDepth,-    paintRastDepthStencil,-    paintColorRastDepthStencil,-    ColorMask, Blending(..), BlendEquation(..), BlendingFactor(..), LogicOp(..),-    ComparisonFunction(..), DepthFunction, DepthMask,-    StencilOps(..), StencilOp(..), StencilTest(..), StencilTests(..),-    FragmentDepth,-) where--import OutputMerger----+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.FrameBuffer
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- | This module defines all functions and types for drawing into a context window 
+--   or texture from a 'Graphics.GPipe.Shader.Shader'.
+-----------------------------------------------------------------------------
+module Graphics.GPipe.FrameBuffer (
+    -- * Draw into the context window
+    drawContextColor,
+    drawContextDepth,
+    drawContextColorDepth,
+    drawContextStencil,
+    drawContextColorStencil,
+    drawContextDepthStencil,
+    drawContextColorDepthStencil,
+
+    -- * Draw into one or more texture images
+    draw,
+    drawDepth,
+    drawStencil,
+    drawDepthStencil,
+    drawColor,
+    DrawColors(),
+
+    -- * Texture images
+    Image(),
+    imageEquals,
+    imageSize,
+    getTexture1DImage,
+    getTexture1DArrayImage, 
+    getTexture2DImage, 
+    getTexture2DArrayImage, 
+    getTexture3DImage, 
+    getTextureCubeImage,    
+    
+    -- * Clearing the context window
+    -- | Use these functions to clear the color, depth or stencil values in the context's window 
+    clearContextColor,
+    clearContextDepth,
+    clearContextStencil, 
+    clearContextDepthStencil, 
+
+    -- * Clearing texture images
+    -- | Use these functions to clear the color, depth or stencil values in texture images. 
+    clearColorImage,
+    clearDepthImage,
+    clearStencilImage,
+    clearDepthStencilImage,
+        
+    -- * Color drawing types
+    FragColor, 
+    ContextColorOption(..),
+    ColorMask,
+    UseBlending,
+    Blending(..),
+    ConstantColor,
+    BlendingFactors(..),
+    BlendEquation(..),
+    BlendingFactor(..),
+    LogicOp(..),
+
+    -- * Depth drawing types        
+    FragDepth,      
+    DepthOption(..),
+    DepthMask,
+    DepthFunction,
+    
+    -- * Stencil drawing types
+    StencilOptions,
+    StencilOption(..),
+    DepthStencilOption(..),   
+    FrontBack(..),    
+    StencilOp(..),
+)
+where
+
+import Graphics.GPipe.Internal.Texture
+import Graphics.GPipe.Internal.FrameBuffer 

@@ -0,0 +1,606 @@+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE Arrows, TypeFamilies, ScopedTypeVariables,
+  FlexibleContexts, FlexibleInstances , TypeSynonymInstances #-}
+
+module Graphics.GPipe.Internal.Buffer 
+(
+    BufferFormat(..),
+    BufferColor,
+    Buffer(),
+    ToBuffer(),
+    B(..), B2(..), B3(..), B4(..),
+    toB22, toB3, toB21, toB12, toB11,
+    Uniform(..), Normalized(..), BPacked(),
+    BInput(..),
+    newBuffer,
+    writeBuffer,
+    copyBuffer,
+    BufferStartPos,
+    bufSize, bufName, bufElementSize, bufferLength, bufBElement, bufferWriteInternal, makeBuffer, getUniformAlignment, UniformAlignment
+) where
+
+import Graphics.GPipe.Internal.Context
+
+import Graphics.GL.Core33
+import Graphics.GL.Types
+import Foreign.Marshal.Utils
+import Foreign.Marshal.Alloc
+
+import Prelude hiding ((.), id)
+import Control.Monad.Trans.State
+import Control.Category
+import Control.Arrow
+import Control.Monad (void)
+import Foreign.Storable
+import Foreign.Ptr
+import Control.Monad.IO.Class
+import Data.Word
+import Data.Int
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class (lift)
+import Data.IORef
+import Control.Applicative ((<$>))
+import Control.Monad.Trans.Writer.Lazy
+import Linear.V4
+import Linear.V3
+import Linear.V2
+import Linear.V1
+import Linear.V0
+
+-- | The class that constraints which types can live in a buffer.
+class BufferFormat f where
+    -- | The type a value of this format has when it lives on the host (i.e. normal Haskell world) 
+    type HostFormat f
+    -- | An arrow action that turns a value from it's host representation to it's buffer representation. Use 'toBuffer' from
+    --   the GPipe provided instances to operate in this arrow. Also note that this arrow needs to be able to return a value
+    --   lazily, so ensure you use
+    -- 
+    --   @proc ~pattern -> do ...@ 
+    toBuffer :: ToBuffer (HostFormat f) f
+    getGlType :: f -> GLenum
+    peekPixel :: f -> Ptr () -> IO (HostFormat f)
+    getGlPaddedFormat :: f -> GLenum  
+    getGlType = error "This is only defined for BufferColor types"
+    peekPixel = error "This is only defined for BufferColor types"
+    getGlPaddedFormat = error "This is only defined for BufferColor types"
+
+-- | A @Buffer os b@ lives in the object space @os@ and contains elements of type @b@. 
+data Buffer os b = Buffer {
+                    bufName :: BufferName,                   
+                    bufElementSize :: Int,
+                    -- | Retrieve the number of elements in a buffer.
+                    bufferLength :: Int,
+                    bufBElement :: BInput -> b,
+                    bufWriter :: Ptr () -> HostFormat b -> IO ()
+                    }
+
+instance Eq (Buffer os b) where
+    a == b = bufName a == bufName b
+
+bufSize :: forall os b. Buffer os b -> Int
+bufSize b = bufElementSize b * bufferLength b
+
+type BufferName = IORef GLuint
+type Offset = Int
+type Stride = Int
+type BufferStartPos = Int 
+
+data BInput = BInput {bInSkipElems :: Int, bInInstanceDiv :: Int}
+
+type ToBufferInput = (BufferName, Stride, BInput)
+
+type UniformAlignment = Int
+
+data AlignmentMode = Align4 | AlignUniform | AlignPackedIndices | AlignUnknown deriving (Eq)
+
+-- | The arrow type for 'toBuffer'.
+data ToBuffer a b = ToBuffer
+    (Kleisli (StateT Offset (WriterT [Int] (Reader (ToBufferInput, UniformAlignment, AlignmentMode)))) a b) -- Normal = aligned to 4 bytes
+    (Kleisli (StateT (Ptr (), [Int]) IO) a b) -- Normal = aligned to 4 bytes
+    AlignmentMode 
+
+instance Category ToBuffer where
+    id = ToBuffer id id AlignUnknown
+    ToBuffer a b m1 . ToBuffer x y m2 = ToBuffer (a.x) (b.y) (comb m1 m2)
+        where
+            -- If only one uniform or one PackedIndices, use that, otherwise use Align4  
+            comb AlignUniform AlignUnknown = AlignUniform
+            comb AlignUnknown AlignUniform = AlignUniform
+            comb AlignUnknown AlignPackedIndices = AlignPackedIndices 
+            comb AlignPackedIndices AlignUnknown = AlignPackedIndices 
+            comb AlignUnknown AlignUnknown = AlignUnknown 
+            comb _ _ = Align4
+
+instance Arrow ToBuffer where
+    arr f = ToBuffer (arr f) (arr f) AlignUnknown
+    first (ToBuffer a b m) = ToBuffer (first a) (first b) m
+
+-- | The atomic buffer value that represents a host value of type 'a'.     
+data B a = B { bName :: IORef GLuint, bOffset :: Int, bStride :: Int, bSkipElems :: Int, bInstanceDiv :: Int}
+
+-- | An atomic buffer value that represents a vector of 2 'a's on the host. 
+newtype B2 a = B2 { unB2 :: B a } -- Internal
+-- | An atomic buffer value that represents a vector of 3 'a's on the host. 
+newtype B3 a = B3 { unB3 :: B a } -- Internal
+-- | An atomic buffer value that represents a vector of 4 'a's on the host. This works similar to '(B a, B a, B a, B a)' but has some performance advantage, especially when used
+--   in 'VertexArray's.
+newtype B4 a = B4 { unB4 :: B a } -- Internal
+
+-- | Split up a @'B4' a@ into two @'B2' a@s.
+toB22 :: forall a. (Storable a, BufferFormat (B2 a)) => B4 a -> (B2 a, B2 a)
+-- | Discard the last component of a @'B4' a@ to get a @'B3' a@.
+toB3 :: forall a. (Storable a, BufferFormat (B3 a)) => B4 a -> B3 a
+-- | Split up a @'B3' a@ into a @'B2' a@ and a @'B1' a@.
+toB21 :: forall a. (Storable a, BufferFormat (B a)) => B3 a -> (B2 a, B a)
+-- | Split up a @'B3' a@ into a @'B1' a@ and a @'B2' a@.
+toB12 :: forall a. (Storable a, BufferFormat (B a)) => B3 a -> (B a, B2 a)
+-- | Split up a @'B2' a@ into two @'B1' a@s.
+toB11 :: forall a. (Storable a, BufferFormat (B a)) => B2 a -> (B a, B a)
+
+toB22 (B4 b) = (B2 b, B2 $ b { bOffset = bOffset b + 2 * sizeOf (undefined :: a) })
+toB3 (B4 b) = B3 b
+toB21 (B3 b) = (B2 b, b { bOffset = bOffset b + 2*sizeOf (undefined :: a) })
+toB12 (B3 b) = (b, B2 $ b { bOffset = bOffset b + sizeOf (undefined :: a) })
+toB11 (B2 b) = (b, b { bOffset = bOffset b + sizeOf (undefined :: a) })
+
+-- | Any buffer value that is going to be used as a uniform needs to be wrapped in this newtype. This will cause is to be aligned
+--   properly for uniform usage. It can still be used as input for vertex arrays, but due to the uniform alignment it will probably be
+--   padded quite heavily and thus wasteful.
+newtype Uniform a = Uniform a
+
+-- | This wrapper is used for integer values to indicate that it should be interpreted as a floating point value, in the range [-1,1] or [0,1] depending on wether it is a
+--   signed or unsigned integer (i.e. 'Int' or 'Word').
+newtype Normalized a = Normalized a
+
+-- | This works like a 'B a', but has an alignment smaller than 4 bytes that is the limit for vertex buffers, and thus cannot be used for those. 
+--   Index buffers on the other hand need to be tightly packed, so you need to use this type for index buffers of 'Word8' or 'Word16'. 
+newtype BPacked a = BPacked (B a) 
+
+toBufferBUnaligned :: forall a. Storable a => ToBuffer a (B a)
+toBufferBUnaligned = ToBuffer 
+                (Kleisli $ const static)
+                (Kleisli writer)
+                Align4
+            where
+                size = sizeOf (undefined :: a)
+                static = do ((name, stride, bIn),_,_) <- lift $ lift ask
+                            offset <- get
+                            put $ offset + size
+                            return $ B name offset stride (bInSkipElems bIn) (bInInstanceDiv bIn)
+                writer a = do (ptr,pads) <- get
+                              put (ptr `plusPtr` size, pads)
+                              liftIO $ poke (castPtr ptr) a
+                              return undefined
+
+toBufferB :: forall a. Storable a => ToBuffer a (B a)
+toBufferB = toBufferBUnaligned -- Will always be 4 aligned, only 4 size types defined for B1                                
+                              
+toBufferB2 :: forall a. Storable a => ToBuffer (V2 a) (B2 a)
+toBufferB2 = proc ~(V2 a b) -> do
+        (if sizeOf (undefined :: a) >= 4 then alignWhen [(AlignUniform, 2 * sizeOf (undefined :: a))] else id) -< () -- Small optimization if someone puts non-usable types in a uniform
+        a' <- toBufferBUnaligned  -< a
+        toBufferBUnaligned -< b
+        returnA -< B2 a' -- Will always be 4 aligned, only 4 size types defined for B2
+toBufferB3 :: forall a. Storable a => ToBuffer (V3 a) (B3 a)
+toBufferB3 = proc ~(V3 a b c) -> do
+        (if sizeOf (undefined :: a) >= 4 then alignWhen [(AlignUniform, 4 * sizeOf (undefined :: a))] else id) -< () -- Small optimization if someone puts non-usable types in a uniform 
+        a' <- toBufferBUnaligned -< a
+        toBufferBUnaligned -< b
+        toBufferBUnaligned -< c
+        (if sizeOf (undefined :: a) < 4 then alignWhen [(Align4, 4), (AlignUniform, 4)] else id) -< () -- For types smaller than 4 we need to pad 
+        returnA -< B3 a'
+toBufferB4 :: forall a. Storable a => ToBuffer (V4 a) (B4 a)
+toBufferB4 = proc ~(V4 a b c d) -> do
+        (if sizeOf (undefined :: a) >= 4 then alignWhen [(AlignUniform, 4 * sizeOf (undefined :: a))] else id) -< () -- Small optimization if someone puts non-usable types in a uniform 
+        a' <- toBufferBUnaligned -< a
+        toBufferBUnaligned -< b
+        toBufferBUnaligned -< c
+        toBufferBUnaligned -< d
+        returnA -< B4 a' -- Will always be 4 aligned
+
+instance BufferFormat a => BufferFormat (Uniform a) where
+    type HostFormat (Uniform a) = HostFormat a
+    toBuffer = arr Uniform . ToBuffer 
+                    (Kleisli elementBuilderA)
+                    (Kleisli writerA)
+                    AlignUniform
+        where
+            ToBuffer (Kleisli elementBuilderA') (Kleisli writerA') _ = toBuffer :: ToBuffer (HostFormat a) a
+            elementBuilderA a = do (_,x,_) <- lift $ lift ask
+                                   a' <- elementBuilderA' a
+                                   setElemAlignM [(AlignUniform, x)] ()                                   
+                                   return a'
+            writerA a = do a' <- writerA' a
+                           setWriterAlignM ()
+                           return a'
+instance BufferFormat a => BufferFormat (Normalized a) where
+    type HostFormat (Normalized a) = HostFormat a
+    toBuffer = arr Normalized . toBuffer                                   
+    getGlType (Normalized a) = getGlType a
+    getGlPaddedFormat (Normalized a) = case getGlPaddedFormat a of
+                                            GL_RGBA_INTEGER -> GL_RGBA
+                                            GL_RGB_INTEGER -> GL_RGB
+                                            GL_RG_INTEGER -> GL_RG
+                                            GL_RED_INTEGER -> GL_RED
+                                            x -> x
+
+instance BufferFormat a => BufferFormat (V0 a) where
+    type HostFormat (V0 a) = V0 (HostFormat a)
+    toBuffer = arr (const V0)
+instance BufferFormat a => BufferFormat (V1 a) where
+    type HostFormat (V1 a) = V1 (HostFormat a)
+    toBuffer = proc ~(V1 a) -> do
+                a' <- toBuffer -< a
+                returnA -< V1 a'
+instance BufferFormat a => BufferFormat (V2 a) where
+    type HostFormat (V2 a) = V2 (HostFormat a)
+    toBuffer = proc ~(V2 a b) -> do
+                (a', b') <- toBuffer -< (a,b)
+                returnA -< V2 a' b'
+instance BufferFormat a => BufferFormat (V3 a) where
+    type HostFormat (V3 a) = V3 (HostFormat a)
+    toBuffer = proc ~(V3 a b c) -> do
+                (a', b', c') <- toBuffer -< (a, b, c)
+                returnA -< V3 a' b' c'
+instance BufferFormat a => BufferFormat (V4 a) where
+    type HostFormat (V4 a) = V4 (HostFormat a)
+    toBuffer = proc ~(V4 a b c d) -> do
+                (a', b', c', d') <- toBuffer -< (a, b, c, d)
+                returnA -< V4 a' b' c' d'
+
+   
+instance (BufferFormat a, BufferFormat b) => BufferFormat (a, b) where
+    type HostFormat (a,b) = (HostFormat a, HostFormat b)
+    toBuffer = proc ~(a, b) -> do
+                a' <- toBuffer -< a
+                b' <- toBuffer -< b
+                returnA -< (a', b')
+instance (BufferFormat a, BufferFormat b, BufferFormat c) => BufferFormat (a, b, c) where
+    type HostFormat (a,b,c) = (HostFormat a, HostFormat b, HostFormat c)
+    toBuffer = proc ~(a, b, c) -> do
+                ((a', b'), c') <- toBuffer -< ((a, b), c)
+                returnA -< (a', b', c')
+instance (BufferFormat a, BufferFormat b, BufferFormat c, BufferFormat d) => BufferFormat (a, b, c, d) where
+    type HostFormat (a,b,c,d) = (HostFormat a, HostFormat b, HostFormat c, HostFormat d)
+    toBuffer = proc ~(a, b, c, d) -> do
+                ((a', b', c'), d') <- toBuffer -< ((a, b, c), d)
+                returnA -< (a', b', c', d')
+
+-- | Create a buffer with a specified number of elements.
+newBuffer :: (MonadIO m, BufferFormat b) => Int -> ContextT w os f m (Buffer os b)
+newBuffer elementCount | elementCount < 0 = error "newBuffer, length negative" 
+                       | otherwise = do
+    (buffer, nameRef, name) <- liftContextIO $ do
+                       name <- alloca (\ptr -> glGenBuffers 1 ptr >> peek ptr) 
+                       nameRef <- newIORef name
+                       uniAl <- getUniformAlignment
+                       let buffer = makeBuffer nameRef elementCount uniAl
+                       bname <- readIORef $ bufName buffer
+                       glBindBuffer GL_COPY_WRITE_BUFFER bname  
+                       glBufferData GL_COPY_WRITE_BUFFER (fromIntegral $ bufSize buffer) nullPtr GL_STREAM_DRAW
+                       return (buffer, nameRef, name)
+    addContextFinalizer nameRef $ with name (glDeleteBuffers 1)
+    addVAOBufferFinalizer nameRef
+    return buffer 
+
+bufferWriteInternal :: Buffer os f -> Ptr () -> [HostFormat f] -> IO (Ptr ())         
+bufferWriteInternal b ptr (x:xs) = do bufWriter b ptr x
+                                      bufferWriteInternal b (ptr `plusPtr` bufElementSize b) xs
+bufferWriteInternal _ ptr [] = return ptr
+
+-- | Write a buffer from the host (i.e. the normal Haskell world).
+writeBuffer :: MonadIO m => Buffer os b -> BufferStartPos -> [HostFormat b] -> ContextT w os f m ()
+writeBuffer buffer offset elems | offset < 0 || offset >= bufferLength buffer = error "writeBuffer, offset out of bounds"
+                                | otherwise = 
+    let maxElems = max 0 $ bufferLength buffer - offset
+        elemSize = bufElementSize buffer
+        off = fromIntegral $ offset * elemSize
+        
+    in liftContextIOAsync $ do 
+                          bname <- readIORef $ bufName buffer
+                          glBindBuffer GL_COPY_WRITE_BUFFER bname
+                          ptr <- glMapBufferRange GL_COPY_WRITE_BUFFER off (fromIntegral $maxElems * elemSize) (GL_MAP_WRITE_BIT + GL_MAP_FLUSH_EXPLICIT_BIT)
+                          end <- bufferWriteInternal buffer ptr (take maxElems elems)
+                          glFlushMappedBufferRange GL_COPY_WRITE_BUFFER off (fromIntegral $ end `minusPtr` ptr) 
+                          void $ glUnmapBuffer GL_COPY_WRITE_BUFFER 
+
+-- | Copies values from one buffer to another (of the same type).
+--
+--   @copyBuffer fromBuffer fromStart toBuffer toStart length@ will copy @length@ elements from position @fromStart@ in @fromBuffer@ to position @toStart@ in @toBuffer@.
+copyBuffer :: MonadIO m => Buffer os b -> BufferStartPos -> Buffer os b -> BufferStartPos -> Int -> ContextT w os f m ()
+copyBuffer bFrom from bTo to len | from < 0 || from >= bufferLength bFrom = error "writeBuffer, source offset out of bounds"
+                                 | to < 0 || to >= bufferLength bTo = error "writeBuffer, destination offset out of bounds"
+                                 | len < 0 = error "writeBuffer, length negative"
+                                 | len + from > bufferLength bFrom = error "writeBuffer, source buffer too small"
+                                 | len + to > bufferLength bTo = error "writeBuffer, destination buffer too small"
+                                 | otherwise = liftContextIOAsync $ do 
+                                                      bnamef <- readIORef $ bufName bFrom
+                                                      bnamet <- readIORef $ bufName bTo
+                                                      glBindBuffer GL_COPY_READ_BUFFER bnamef
+                                                      glBindBuffer GL_COPY_WRITE_BUFFER bnamet
+                                                      let elemSize = bufElementSize bFrom -- same as for bTo
+                                                      glCopyBufferSubData GL_COPY_READ_BUFFER GL_COPY_WRITE_BUFFER (fromIntegral $ from * elemSize) (fromIntegral $ to * elemSize) (fromIntegral $ len * elemSize)   
+
+----------------------------------------------
+
+alignWhen :: [(AlignmentMode, Int)] -> ToBuffer a a
+alignWhen x = ToBuffer (Kleisli $ setElemAlignM x) (Kleisli setWriterAlignM) AlignUniform where
+
+setElemAlignM :: [(AlignmentMode, Int)] -> b -> StateT Offset (WriterT [Int] (Reader (ToBufferInput, UniformAlignment, AlignmentMode))) b
+setElemAlignM x a = do
+                     (_,_,m) <- lift $ lift ask
+                     pad <- case lookup m x of
+                                Nothing -> return 0
+                                Just al -> do
+                                    offset <- get
+                                    let pad = al - 1 - ((offset - 1) `mod` al)
+                                    put $ offset + pad
+                                    return pad
+                     lift $ tell [pad]
+                     return a   
+setWriterAlignM :: b -> StateT (Ptr a, [Int]) IO b
+setWriterAlignM a = do (ptr, pad:pads) <- get
+                       put (ptr `plusPtr` pad, pads)
+                       return a
+        
+
+
+getUniformAlignment :: IO Int
+getUniformAlignment = fromIntegral <$> alloca (\ ptr -> glGetIntegerv GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT ptr >> peek ptr)
+            
+makeBuffer :: forall os b. BufferFormat b => BufferName -> Int -> UniformAlignment -> Buffer os b
+makeBuffer name elementCount uniformAlignment  = do
+    let ToBuffer a b m = toBuffer :: ToBuffer (HostFormat b) b
+        err = error "toBuffer, toVertex or toUniform are creating values that are dependant on the actual HostFormat values, this is not allowed since it doesn't allow static creation of shaders" :: HostFormat b
+        elementM = runWriterT (runStateT (runKleisli a err) 0)
+        ((_,elementSize),pads) = runReader elementM ((name, undefined, undefined), uniformAlignment, m)
+        elementF bIn = (fst . fst) $ runReader elementM ((name, elementSize, bIn), uniformAlignment, m)
+        writer ptr x = void $ runStateT (runKleisli b x) (ptr,pads)
+    Buffer name elementSize elementCount elementF writer
+
+-- | This type family restricts what host and buffer types a texture format may be converted into. 
+-- 'BufferColor t h' for a texture representation 't' and a host representation 'h' will evaluate to a buffer type used in the transfer.
+-- This family is closed, i.e. you cannot create additional instances to it.    
+type family BufferColor c h where
+    BufferColor Float Int32 = Normalized (B Int32)
+    BufferColor Float Word32 = Normalized (B Word32)
+    BufferColor Float Float = B Float
+    BufferColor Int Int32   = B Int32
+
+    BufferColor Word Word32 = B Word32
+    BufferColor Word Word16 = BPacked Word16
+    BufferColor Word Word8  = BPacked Word8
+
+    BufferColor (V2 Float) (V2 Int32) = Normalized (B2 Int32) 
+    BufferColor (V2 Float) (V2 Int16) = Normalized (B2 Int16) 
+    BufferColor (V2 Float) (V2 Word32) = Normalized (B2 Word32) 
+    BufferColor (V2 Float) (V2 Word16) = Normalized (B2 Word16) 
+    BufferColor (V2 Float) (V2 Float) = B2 Float
+
+    BufferColor (V2 Int) (V2 Int32) = B2 Int32
+    BufferColor (V2 Int) (V2 Int16) = B2 Int16
+
+    BufferColor (V2 Word) (V2 Word32) = B2 Word32
+    BufferColor (V2 Word) (V2 Word16) = B2 Word16
+
+    BufferColor (V3 Float) (V3 Int32) = Normalized (B3 Int32) 
+    BufferColor (V3 Float) (V3 Int16) = Normalized (B3 Int16)
+    BufferColor (V3 Float) (V3 Int8)  = Normalized (B3 Int8)
+    BufferColor (V3 Float) (V3 Word32) = Normalized (B3 Word32) 
+    BufferColor (V3 Float) (V3 Word16) = Normalized (B3 Word16)
+    BufferColor (V3 Float) (V3 Word8)  = Normalized (B3 Word8)
+    BufferColor (V3 Float) (V3 Float) = B3 Float
+
+    BufferColor (V3 Int) (V3 Int32) = B3 Int32
+    BufferColor (V3 Int) (V3 Int16) = B3 Int16
+    BufferColor (V3 Int) (V3 Int8)  = B3 Int8
+
+    BufferColor (V3 Word) (V3 Word32) = B3 Word32
+    BufferColor (V3 Word) (V3 Word16) = B3 Word16
+    BufferColor (V3 Word) (V3 Word8)  = B3 Word8
+
+    BufferColor (V4 Float) (V4 Int32) = Normalized (B4 Int32)
+    BufferColor (V4 Float) (V4 Int16) = Normalized (B4 Int16)
+    BufferColor (V4 Float) (V4 Int8)  = Normalized (B4 Int8)
+    BufferColor (V4 Float) (V4 Word32) = Normalized (B4 Word32)
+    BufferColor (V4 Float) (V4 Word16) = Normalized (B4 Word16)
+    BufferColor (V4 Float) (V4 Word8)  = Normalized (B4 Word8)
+    BufferColor (V4 Float) (V4 Float) = B4 Float
+
+    BufferColor (V4 Int) (V4 Int32) = B4 Int32
+    BufferColor (V4 Int) (V4 Int16) = B4 Int16
+    BufferColor (V4 Int) (V4 Int8)  = B4 Int8
+
+    BufferColor (V4 Word) (V4 Word32) = B4 Word32
+    BufferColor (V4 Word) (V4 Word16) = B4 Word16
+    BufferColor (V4 Word) (V4 Word8)  = B4 Word8
+
+peekPixel1 :: Storable a => t -> Ptr x -> IO a
+peekPixel1 _ = peek . castPtr 
+peekPixel2 :: (Storable a) => t -> Ptr x -> IO (V2 a)
+peekPixel2 _ ptr = do x <- peek (castPtr ptr)
+                      y <- peekElemOff (castPtr ptr ) 1
+                      return (V2 x y) 
+peekPixel3 :: (Storable a) => t -> Ptr x -> IO (V3 a)
+peekPixel3 _ ptr = do x <- peek (castPtr ptr)
+                      y <- peekElemOff (castPtr ptr ) 1
+                      z <- peekElemOff (castPtr ptr ) 2
+                      return (V3 x y z) 
+peekPixel4 :: (Storable a) => t -> Ptr x -> IO (V4 a)
+peekPixel4 _ ptr = do x <- peek (castPtr ptr)
+                      y <- peekElemOff (castPtr ptr ) 1
+                      z <- peekElemOff (castPtr ptr ) 2
+                      w <- peekElemOff (castPtr ptr ) 3
+                      return (V4 x y z w) 
+
+
+instance BufferFormat (B Int32) where
+    type HostFormat (B Int32) = Int32
+    toBuffer = toBufferB
+    getGlType _ = GL_INT
+    peekPixel = peekPixel1 
+    getGlPaddedFormat _ = GL_RED_INTEGER
+
+instance BufferFormat (B Word32) where
+    type HostFormat (B Word32) = Word32
+    toBuffer = toBufferB
+    getGlType _ = GL_UNSIGNED_INT
+    peekPixel = peekPixel1 
+    getGlPaddedFormat _ = GL_RED_INTEGER
+   
+instance BufferFormat (BPacked Word16) where
+    type HostFormat (BPacked Word16) = Word16
+    toBuffer = let ToBuffer a b _ = toBufferB :: ToBuffer Word16 (B Word16) in arr BPacked . ToBuffer a b AlignPackedIndices 
+    getGlType _ = GL_UNSIGNED_SHORT
+    peekPixel = peekPixel1 
+    getGlPaddedFormat _ = GL_RED_INTEGER
+
+instance BufferFormat (BPacked Word8) where
+    type HostFormat (BPacked Word8) = Word8
+    toBuffer = let ToBuffer a b _ = toBufferB :: ToBuffer Word8 (B Word8) in arr BPacked . ToBuffer a b AlignPackedIndices 
+    getGlType _ = GL_UNSIGNED_BYTE
+    peekPixel = peekPixel1 
+    getGlPaddedFormat _ = GL_RED_INTEGER      
+
+instance BufferFormat (B Float) where
+    type HostFormat (B Float) = Float
+    toBuffer = toBufferB
+    getGlType _ = GL_FLOAT
+    peekPixel = peekPixel1 
+    getGlPaddedFormat _ = GL_RED
+
+instance BufferFormat (B2 Int32) where
+    type HostFormat (B2 Int32) = V2 Int32
+    toBuffer = toBufferB2
+    getGlType _ = GL_INT
+    peekPixel = peekPixel2 
+    getGlPaddedFormat _ = GL_RG_INTEGER
+
+instance BufferFormat (B2 Int16) where
+    type HostFormat (B2 Int16) = V2 Int16
+    toBuffer = toBufferB2
+    getGlType _ = GL_SHORT
+    peekPixel = peekPixel2 
+    getGlPaddedFormat _ = GL_RG_INTEGER
+
+instance BufferFormat (B2 Word32) where
+    type HostFormat (B2 Word32) = V2 Word32
+    toBuffer = toBufferB2
+    getGlType _ = GL_UNSIGNED_INT
+    peekPixel = peekPixel2 
+    getGlPaddedFormat _ = GL_RG_INTEGER
+
+instance BufferFormat (B2 Word16) where
+    type HostFormat (B2 Word16) = V2 Word16
+    toBuffer = toBufferB2
+    getGlType _ = GL_UNSIGNED_SHORT
+    peekPixel = peekPixel2 
+    getGlPaddedFormat _ = GL_RG_INTEGER
+
+instance BufferFormat (B2 Float) where
+    type HostFormat (B2 Float) = V2 Float
+    toBuffer = toBufferB2
+    getGlType _ = GL_FLOAT
+    peekPixel = peekPixel2 
+    getGlPaddedFormat _ = GL_RG
+
+instance BufferFormat (B3 Int32) where
+    type HostFormat (B3 Int32) = V3 Int32
+    toBuffer = toBufferB3
+    getGlType _ = GL_INT
+    peekPixel = peekPixel3 
+    getGlPaddedFormat _ = GL_RGB_INTEGER
+
+instance BufferFormat (B3 Int16) where
+    type HostFormat (B3 Int16) = V3 Int16
+    toBuffer = toBufferB3
+    getGlType _ = GL_SHORT
+    peekPixel = peekPixel3 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B3 Int8) where
+    type HostFormat (B3 Int8) = V3 Int8
+    toBuffer = toBufferB3
+    getGlType _ = GL_BYTE
+    peekPixel = peekPixel3 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B3 Word32) where
+    type HostFormat (B3 Word32) = V3 Word32
+    toBuffer = toBufferB3
+    getGlType _ = GL_UNSIGNED_INT
+    peekPixel = peekPixel3 
+    getGlPaddedFormat _ = GL_RGB_INTEGER
+
+instance BufferFormat (B3 Word16) where
+    type HostFormat (B3 Word16) = V3 Word16
+    toBuffer = toBufferB3
+    getGlType _ = GL_UNSIGNED_SHORT
+    peekPixel = peekPixel3 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B3 Word8) where
+    type HostFormat (B3 Word8) = V3 Word8
+    toBuffer = toBufferB3
+    getGlType _ = GL_UNSIGNED_BYTE
+    peekPixel = peekPixel3 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B3 Float) where
+    type HostFormat (B3 Float) = V3 Float
+    toBuffer = toBufferB3
+    getGlType _ = GL_FLOAT
+    peekPixel = peekPixel3 
+    getGlPaddedFormat _ = GL_RGB
+
+instance BufferFormat (B4 Int32) where
+    type HostFormat (B4 Int32) = V4 Int32
+    toBuffer = toBufferB4
+    getGlType _ = GL_INT
+    peekPixel = peekPixel4 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B4 Int16) where
+    type HostFormat (B4 Int16) = V4 Int16
+    toBuffer = toBufferB4
+    getGlType _ = GL_SHORT
+    peekPixel = peekPixel4 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B4 Int8) where
+    type HostFormat (B4 Int8) = V4 Int8
+    toBuffer = toBufferB4
+    getGlType _ = GL_BYTE
+    peekPixel = peekPixel4 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B4 Word32) where
+    type HostFormat (B4 Word32) = V4 Word32
+    toBuffer = toBufferB4
+    getGlType _ = GL_UNSIGNED_INT
+    peekPixel = peekPixel4 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B4 Word16) where
+    type HostFormat (B4 Word16) = V4 Word16
+    toBuffer = toBufferB4
+    getGlType _ = GL_UNSIGNED_SHORT
+    peekPixel = peekPixel4 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B4 Word8) where
+    type HostFormat (B4 Word8) = V4 Word8
+    toBuffer = toBufferB4
+    getGlType _ = GL_UNSIGNED_BYTE
+    peekPixel = peekPixel4 
+    getGlPaddedFormat _ = GL_RGBA_INTEGER
+
+instance BufferFormat (B4 Float) where
+    type HostFormat (B4 Float) = V4 Float
+    toBuffer = toBufferB4
+    getGlType _ = GL_FLOAT
+    peekPixel = peekPixel4 
+    getGlPaddedFormat _ = GL_RGBA
+    
+
+    

@@ -0,0 +1,279 @@+{-# LANGUAGE PatternGuards, PatternSynonyms #-}
+module Graphics.GPipe.Internal.Compiler where
+
+import Graphics.GPipe.Internal.Context
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Exception (MonadException)
+import qualified Data.IntMap as Map
+import Data.IntMap ((!))
+import Data.Maybe
+import Control.Monad
+import Control.Monad.Trans.State.Lazy (evalStateT, get, put)
+import Control.Monad.Trans.Class (lift)
+
+import Graphics.GL.Core33
+import Foreign.Marshal.Utils
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Storable (peek)
+import Foreign.C.String
+import Foreign.Marshal.Array
+import Foreign.Ptr (nullPtr)
+import Data.Either
+import Control.Exception (throwIO)
+import Data.IORef
+import Data.List (zip5)
+import Data.Monoid ((<>))
+
+data Drawcall s = Drawcall {
+                    drawcallFBO :: s -> (Maybe (IO FBOKeys, IO ()), IO ()),
+                    drawcallName :: Int,
+                    rasterizationName :: Int,
+                    vertexsSource :: String,
+                    fragmentSource :: String,
+                    usedInputs :: [Int],
+                    usedVUniforms :: [Int],
+                    usedVSamplers :: [Int],
+                    usedFUniforms :: [Int],
+                    usedFSamplers :: [Int]
+                    }                                      
+
+-- index/binding refers to what is used in the final shader. Index space is limited, usually 16
+-- attribname is what was declared, but all might not be used. Attribname share namespace with uniforms and textures and is unlimited(TM)
+type Binding = Int
+
+-- TODO: Add usedBuffers to RenderIOState, ie Map.IntMap (s -> (Binding -> IO (), Int)) and the like
+--       then create a function that checks that none of the input buffers are used as output, and throws if it is
+
+data RenderIOState s = RenderIOState 
+    {
+        uniformNameToRenderIO :: Map.IntMap (s -> Binding -> IO ()),
+        samplerNameToRenderIO :: Map.IntMap (s -> Binding -> IO ()),
+        rasterizationNameToRenderIO :: Map.IntMap (s -> IO ()),
+        inputArrayToRenderIOs :: Map.IntMap (s -> [[Binding] -> ((IO [VAOKey], IO ()), IO ())])
+    }  
+  
+newRenderIOState :: RenderIOState s
+newRenderIOState = RenderIOState Map.empty Map.empty Map.empty Map.empty
+
+mapRenderIOState :: (s -> s') -> RenderIOState s' -> RenderIOState s -> RenderIOState s
+mapRenderIOState f (RenderIOState a b c d) (RenderIOState i j k l) = let g x = x . f in RenderIOState (Map.union i $ Map.map g a) (Map.union j $ Map.map g b) (Map.union k $ Map.map g c) (Map.union l $ Map.map g d)
+
+data BoundState = BoundState { 
+                        boundUniforms :: Map.IntMap Int, 
+                        boundSamplers :: Map.IntMap Int,
+                        boundRasterizerN :: Int
+                        }  
+
+
+-- | May throw a GPipeException 
+compile :: (Monad m, MonadIO m, MonadException m) => [IO (Drawcall s)] -> RenderIOState s -> ContextT w os f m (ContextData -> s -> IO (Maybe String))
+compile dcs s = do
+    drawcalls <- liftIO $ sequence dcs -- IO only for SNMap
+    (maxUnis, 
+     maxSamplers,
+     maxVUnis,
+     maxVSamplers,
+     maxFUnis,
+     maxFSamplers) <- liftContextIO $ do 
+                       maxUnis <- alloca (\ptr -> glGetIntegerv GL_MAX_COMBINED_UNIFORM_BLOCKS ptr >> peek ptr)
+                       maxSamplers <- alloca (\ptr -> glGetIntegerv GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS ptr >> peek ptr)
+                       maxVUnis <- alloca (\ptr -> glGetIntegerv GL_MAX_VERTEX_UNIFORM_BLOCKS ptr >> peek ptr)
+                       maxVSamplers <- alloca (\ptr -> glGetIntegerv GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS ptr >> peek ptr)
+                       maxFUnis <- alloca (\ptr -> glGetIntegerv GL_MAX_FRAGMENT_UNIFORM_BLOCKS ptr >> peek ptr)
+                       maxFSamplers <- alloca (\ptr -> glGetIntegerv GL_MAX_TEXTURE_IMAGE_UNITS ptr >> peek ptr)
+                       return 
+                        (fromIntegral maxUnis, 
+                         fromIntegral maxSamplers,
+                         fromIntegral maxVUnis, 
+                         fromIntegral maxVSamplers,
+                         fromIntegral maxFUnis, 
+                         fromIntegral maxFSamplers)
+
+    let vUnisPerDc = map usedVUniforms drawcalls
+        vSampsPerDc = map usedVSamplers drawcalls
+        fUnisPerDc = map usedFUniforms drawcalls
+        fSampsPerDc = map usedFSamplers drawcalls
+        unisPerDc = zipWith orderedUnion vUnisPerDc fUnisPerDc
+        sampsPerDc = zipWith orderedUnion vSampsPerDc fSampsPerDc
+        
+        limitErrors = concat [
+            ["Too many uniform blocks used in a single shader program\n" | any (\ xs -> length xs >= maxUnis) unisPerDc], 
+            ["Too many textures used in a single shader program\n" | any (\ xs -> length xs >= maxSamplers) sampsPerDc],
+            ["Too many uniform blocks used in a single vertex shader\n" | any (\ xs -> length xs >= maxVUnis) vUnisPerDc],
+            ["Too many textures used in a single vertex shader\n" | any (\ xs -> length xs >= maxVSamplers) vSampsPerDc],
+            ["Too many uniform blocks used in a single fragment shader\n" | any (\ xs -> length xs >= maxFUnis) fUnisPerDc],
+            ["Too many textures used in a single fragment shader\n" | any (\ xs -> length xs >= maxFSamplers) fSampsPerDc]
+            ]
+        
+        allocatedUniforms = allocate maxUnis unisPerDc      
+        allocatedSamplers = allocate maxSamplers sampsPerDc
+    compRet <- evalStateT (mapM comp  (zip5 drawcalls unisPerDc sampsPerDc allocatedUniforms allocatedSamplers)) (BoundState Map.empty Map.empty (-1))
+    fAdd <- getContextFinalizerAdder
+    let (errs, ret) = partitionEithers compRet
+        (pnames, fs) = unzip ret
+        fr cd x = foldl (\ io f -> do mErr <- io
+                                      mErr2 <- f x cd fAdd
+                                      return $ mErr <> mErr2)
+                        (return Nothing) 
+                        fs
+        allErrs = limitErrors ++ errs
+    if null allErrs 
+        then do  
+            forM_ pnames (\pNameRef -> do pName <- liftIO $ readIORef pNameRef 
+                                          addContextFinalizer pNameRef (glDeleteProgram pName))
+            return fr
+        else do
+            liftContextIOAsync $ mapM_ (readIORef >=> glDeleteProgram) pnames
+            liftIO $ throwIO $ GPipeException $ concat allErrs   
+ where   
+    comp (Drawcall fboSetup primN rastN vsource fsource inps _ _ _ _, unis, samps, ubinds, sbinds) = do
+           BoundState uniState sampState boundRastN <- get
+           let (bindUni, uniState') = makeBind uniState (uniformNameToRenderIO s) (zip unis ubinds)
+           let (bindSamp, sampState') = makeBind sampState (samplerNameToRenderIO s) $ zip samps sbinds
+           let bindRast = if rastN == boundRastN then const $ return () else rasterizationNameToRenderIO s ! rastN 
+           put $ BoundState uniState' sampState' rastN
+           
+           lift $ do ePname <- liftContextIO $ do
+                              vShader <- glCreateShader GL_VERTEX_SHADER
+                              mErrV <- compileShader vShader vsource
+                              fShader <- glCreateShader GL_FRAGMENT_SHADER                             
+                              mErrF <- compileShader fShader fsource
+                              if isNothing mErrV && isNothing mErrV 
+                                then do pName <- glCreateProgram
+                                        glAttachShader pName vShader
+                                        glAttachShader pName fShader
+                                        mapM_ (\(name, ix) -> withCString ("in"++ show name) $ glBindAttribLocation pName ix) $ zip inps [0..]
+                                        mPErr <- linkProgram pName
+                                        glDetachShader pName vShader
+                                        glDetachShader pName fShader
+                                        glDeleteShader vShader
+                                        glDeleteShader fShader
+                                        case mPErr of
+                                            Just errP -> do glDeleteProgram pName 
+                                                            return $ Left $ "Linking a GPU progam failed:\n" ++ errP ++ "\nVertex source:\n" ++ vsource ++ "\nFragment source:\n" ++ fsource
+                                            Nothing -> return $ Right pName
+                                else do glDeleteShader vShader
+                                        glDeleteShader fShader
+                                        let err = maybe "" (\e -> "A vertex shader compilation failed:\n" ++ e ++ "\nSource:\n" ++ vsource) mErrV
+                                              ++ maybe "" (\e -> "A fragment shader compilation failed:\n" ++ e ++ "\nSource:\n" ++ fsource) mErrF
+                                        return $ Left err
+                     case ePname of                   
+                          Left err -> return $ Left err
+                          Right pName -> liftContextIO $ do                                                          
+                              forM_ (zip unis ubinds) $ \(name, bind) -> do
+                                    uix <- withCString ("uBlock" ++ show name) $ glGetUniformBlockIndex pName
+                                    glUniformBlockBinding pName uix (fromIntegral bind)
+                              
+                              glUseProgram pName -- For setting texture uniforms
+                              forM_ (zip samps sbinds) $ \(name, bind) -> do
+                                    six <- withCString ("s" ++ show name) $ glGetUniformLocation pName
+                                    glUniform1i six (fromIntegral bind)
+                              pNameRef <- newIORef pName
+                                                                 
+                              return $ Right (pNameRef, \x cd fAdd -> do
+                                           -- Drawing with program --
+                                           pName' <- readIORef pNameRef -- Cant use pName, need to touch pNameRef
+                                           glUseProgram pName'
+                                           bindUni x 
+                                           bindSamp x
+                                           bindRast x
+                                           let (mfbokeyio, blendio) = fboSetup x
+                                           blendio
+                                           mError <- case mfbokeyio of
+                                                Nothing -> do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0
+                                                              return Nothing
+                                                Just (fbokeyio, fboio) -> do
+                                                   fbokey <- fbokeyio
+                                                   mfbo <- getFBO cd fbokey
+                                                   case mfbo of
+                                                        Just fbo -> do fbo' <- readIORef fbo
+                                                                       glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                                                       return Nothing
+                                                        Nothing -> do fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)
+                                                                      fbo <- newIORef fbo'
+                                                                      void $ fAdd fbo $ with fbo' (glDeleteFramebuffers 1)
+                                                                      setFBO cd fbokey fbo
+                                                                      glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                                                      glEnable GL_FRAMEBUFFER_SRGB
+                                                                      fboio                                                                      
+                                                                      let numColors = length $ fboColors fbokey
+                                                                      withArray [GL_COLOR_ATTACHMENT0 .. (GL_COLOR_ATTACHMENT0 + fromIntegral numColors - 1)] $ glDrawBuffers (fromIntegral numColors)
+                                                                      getFBOerror                                           
+                                           when (isNothing mError) $                             
+                                               -- Draw each Vertex Array --
+                                               forM_ (map ($ inps) ((inputArrayToRenderIOs s ! primN) x)) $ \ ((keyio, vaoio), drawio) -> do
+                                                    key <- keyio
+                                                    mvao <- getVAO cd key
+                                                    case mvao of
+                                                        Just vao -> do vao' <- readIORef vao
+                                                                       glBindVertexArray vao'
+                                                        Nothing -> do vao' <- alloca (\ptr -> glGenVertexArrays 1 ptr >> peek ptr)
+                                                                      vao <- newIORef vao'
+                                                                      void $ fAdd vao $ with vao' (glDeleteVertexArrays 1)
+                                                                      setVAO cd key vao
+                                                                      glBindVertexArray vao'
+                                                                      vaoio
+                                                    drawio
+                                           return mError)
+
+    compileShader name source = do 
+        withCStringLen source $ \ (ptr, len) ->
+                                    with ptr $ \ pptr ->
+                                        with (fromIntegral len) $ \ plen ->
+                                            glShaderSource name 1 pptr plen
+        glCompileShader name
+        compStatus <- alloca $ \ ptr -> glGetShaderiv name GL_COMPILE_STATUS ptr >> peek ptr
+        if compStatus /= GL_FALSE
+            then return Nothing
+            else do logLen <- alloca $ \ ptr -> glGetShaderiv name GL_INFO_LOG_LENGTH ptr >> peek ptr
+                    let logLen' = fromIntegral logLen
+                    liftM Just $ allocaArray logLen' $ \ ptr -> do
+                                    glGetShaderInfoLog name logLen nullPtr ptr
+                                    peekCString ptr 
+    linkProgram name = do glLinkProgram name
+                          linkStatus <- alloca $ \ ptr -> glGetProgramiv name GL_LINK_STATUS ptr >> peek ptr
+                          if linkStatus /= GL_FALSE
+                            then return Nothing
+                            else do logLen <- alloca $ \ ptr -> glGetProgramiv name GL_INFO_LOG_LENGTH ptr >> peek ptr
+                                    let logLen' = fromIntegral logLen
+                                    liftM Just $ allocaArray logLen' $ \ ptr -> do
+                                                    glGetProgramInfoLog name logLen nullPtr ptr
+                                                    peekCString ptr 
+
+orderedUnion :: Ord a => [a] -> [a] -> [a]
+orderedUnion xxs@(x:xs) yys@(y:ys) | x == y    = x : orderedUnion xs ys
+                                   | x < y     = x : orderedUnion xs yys
+                                   | otherwise = y : orderedUnion xxs ys
+orderedUnion xs [] = xs
+orderedUnion [] ys = ys
+
+-- Optimization, save gl calls to already bound buffers/samplers
+makeBind :: Map.IntMap Int -> Map.IntMap (s -> Binding -> IO ()) -> [(Int, Int)] -> (s -> IO (), Map.IntMap Int)
+makeBind m iom ((n,b):xs) = (g, m'')
+    where 
+        (f, m') = makeBind m iom xs
+        (io, m'') = case Map.lookup b m' of
+                            Just x | x == n -> (const $ return (), m')
+                            _               -> (\s -> (iom ! n) s b, Map.insert b n m')      
+        g s = f s >> io s
+makeBind m _ [] = (const $ return (), m)                          
+
+allocate :: Int -> [[Int]] -> [[Int]]
+allocate mx = allocate' Map.empty []
+    where allocate' m ys ((x:xs):xss) | Just a <- Map.lookup x m  = allocate' m (a:ys) (xs:xss) 
+                                      | ms <- Map.size m, ms < mx = allocate' (Map.insert x ms m) (ms:ys) (xs:xss)
+                                      | otherwise                 = let (ek,ev) = findLastUsed m mx (ys ++ xs ++ concat xss) in allocate' (Map.insert x ev (Map.delete ek m)) (ev:ys) (xs:xss)
+          allocate' m ys (_:xss) = reverse ys : allocate' m [] xss 
+          allocate' _ _ [] = []
+          
+          findLastUsed m n (x:xs) | n > 1 = let (a, m') = Map.updateLookupWithKey (const $ const Nothing) x m 
+                                                n' = if isJust a then n-1 else n
+                                            in findLastUsed m' n' xs
+          findLastUsed m _ _ = head $ Map.toList m                                    
+          
+getFBOerror :: MonadIO m => m (Maybe String)                  
+getFBOerror = do status <- glCheckFramebufferStatus GL_DRAW_FRAMEBUFFER
+                 return $ case status of
+                    GL_FRAMEBUFFER_COMPLETE -> Nothing
+                    GL_FRAMEBUFFER_UNSUPPORTED -> Just "The combination of draw images (FBO) used in the render call is unsupported by this graphics driver\n"
+                    _ -> error "GPipe internal FBO error"      

@@ -0,0 +1,256 @@+{-# LANGUAGE RankNTypes, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, GADTs, DeriveDataTypeable #-}
+
+module Graphics.GPipe.Internal.Context 
+(
+    ContextFactory,
+    ContextHandle(..),
+    ContextT(),
+    GPipeException(..),
+    runContextT,
+    runSharedContextT,
+    liftContextIO,
+    liftContextIOAsync,
+    addContextFinalizer,
+    getContextFinalizerAdder,
+    getRenderContextFinalizerAdder ,
+    swapContextBuffers,
+    withContextWindow,
+    addVAOBufferFinalizer,
+    addFBOTextureFinalizer,
+    getContextData,
+    getRenderContextData,
+    getVAO, setVAO,
+    getFBO, setFBO,
+    ContextData,
+    VAOKey(..), FBOKey(..), FBOKeys(..),
+    Render(..), render, getContextBuffersSize
+)
+where
+
+import Graphics.GPipe.Internal.Format
+import Control.Monad.Exception (MonadException, Exception, MonadAsyncException,bracket)
+import Control.Monad.Trans.Reader 
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Applicative (Applicative, (<$>))
+import Data.Typeable (Typeable)
+import qualified Data.Map.Strict as Map 
+import Graphics.GL.Core33
+import Graphics.GL.Types
+import Control.Concurrent.MVar
+import Data.IORef
+import Control.Monad
+import Data.List (delete)
+import Foreign.C.Types
+import Data.Maybe (maybeToList)
+import Linear.V2 (V2(V2))
+import Control.Monad.Trans.Error
+import Control.Exception (throwIO)
+
+type ContextFactory c ds w = ContextFormat c ds -> IO (ContextHandle w)
+
+data ContextHandle w = ContextHandle {
+    -- | Like a 'ContextFactory' but creates a context that shares the object space of this handle's context  
+    newSharedContext :: forall c ds. ContextFormat c ds -> IO (ContextHandle w),
+    -- | Run an OpenGL IO action in this context, returning a value to the caller. The thread calling this may not be the same creating the context. 
+    contextDoSync :: forall a. IO a -> IO a,
+    -- | Run an OpenGL IO action in this context, that doesn't return any value to the caller. The thread calling this may not be the same creating the context (for finalizers it is most definetly not).
+    contextDoAsync :: IO () -> IO (),
+    -- | Swap the front and back buffers in the context's default frame buffer. This will be called as an argument to 'contextDoSync' so you can assume it is run on the right GL thread. 
+    contextSwap :: IO (),   
+    -- | Get the current size of the context's default framebuffer (which may change if the window is resized). This will be called as an argument to 'contextDoSync' so you can assume it is run on the right GL thread. 
+    contextFrameBufferSize :: IO (Int, Int),
+    -- | Delete this context and close any associated window. The thread calling this may not be the same creating the context.  
+    contextDelete :: IO (),
+    -- | A value representing the context's window. It is recommended that this is an opaque type that doesn't have any exported functions. Instead, provide 'ContextT' actions 
+    --   that are implemented in terms of 'withContextWindow' to expose any functionality to the user that need a reference the context's window.
+    contextWindow :: w
+} 
+
+-- | The monad transformer that encapsulates a GPipe context (which wraps an OpenGl context).
+--
+--   A value of type @ContextT w os f m a@ is an action on a context with these parameters:
+--
+--   [@w@] The type of the window that is bound to this context. It is defined by the window manager package and is probably an opaque type.
+--
+--   [@os@] An abstract type that is used to denote the object space. This is an forall type defined by the 'runContextT' call which will restrict any objects created inside this context 
+--          to be returned from it or used by another context (the same trick as the 'ST' monad uses).
+--
+--   [@f@] The format of the context's default frame buffer, always an instance of 'ContextFormat'.
+--
+--   [@m@] The monad this monad transformer wraps. Need to have 'IO' in the bottom for this 'ContextT' to be runnable.
+--
+--   [@a@] The value returned from this monad action. 
+--
+newtype ContextT w os f m a = 
+    ContextT (ReaderT (ContextHandle w, (ContextData, SharedContextDatas)) m a) 
+    deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadAsyncException)
+    
+instance MonadTrans (ContextT w os f) where
+    lift = ContextT . lift 
+
+-- | Run a 'ContextT' monad transformer, creating a window (unless the 'ContextFormat' is 'ContextFormatNone') that is later destroyed when the action returns. This function will
+--   also create a new object space. 
+--   You need a 'ContextFactory', which is provided by an auxillary package, such as @GPipe-GLFW@.
+runContextT :: (MonadIO m, MonadAsyncException m) => ContextFactory c ds w -> ContextFormat c ds -> (forall os. ContextT w os (ContextFormat c ds) m a) -> m a
+runContextT cf f (ContextT m) = 
+    bracket 
+        (liftIO $ cf f)
+        (liftIO . contextDelete)
+        $ \ h -> do cds <- liftIO newContextDatas
+                    cd <- liftIO $ addContextData cds
+                    let ContextT i = initGlState
+                        rs = (h, (cd, cds))
+                    runReaderT (i >> m) rs
+
+-- | Run a 'ContextT' monad transformer inside another one, creating a window (unless the 'ContextFormat' is 'ContextFormatNone') that is later destroyed when the action returns. The inner 'ContextT' monad
+-- transformer will share object space with the outer one. The 'ContextFactory' of the outer context will be used in the creation of the inner context. 
+runSharedContextT :: (MonadIO m, MonadAsyncException m) => ContextFormat c ds -> ContextT w os (ContextFormat c ds) (ContextT w os f m) a -> ContextT w os f m a
+runSharedContextT f (ContextT m) =
+    bracket
+        (do (h',(_,cds)) <- ContextT ask
+            h <- liftIO $ newSharedContext h' f
+            cd <- liftIO $ addContextData cds
+            return (h,cd)
+        )
+        (\(h,cd) -> do cds <- ContextT $ asks (snd . snd)
+                       liftIO $ removeContextData cds cd
+                       liftIO $ contextDelete h)
+        $ \(h,cd) -> do cds <- ContextT $ asks (snd . snd)
+                        let ContextT i = initGlState
+                            rs = (h, (cd, cds))
+                        runReaderT (i >> m) rs
+
+initGlState :: MonadIO m => ContextT w os f m ()
+initGlState = liftContextIOAsync $ do glEnable GL_FRAMEBUFFER_SRGB
+                                      glEnable GL_SCISSOR_TEST
+                                      glPixelStorei GL_PACK_ALIGNMENT 1
+                                      glPixelStorei GL_UNPACK_ALIGNMENT 1
+
+liftContextIO :: MonadIO m => IO a -> ContextT w os f m a
+liftContextIO m = ContextT (asks fst) >>= liftIO . flip contextDoSync m
+
+addContextFinalizer :: MonadIO m => IORef a -> IO () -> ContextT w os f m ()
+addContextFinalizer k m = ContextT (asks fst) >>= liftIO . void . mkWeakIORef k . flip contextDoAsync m
+
+getContextFinalizerAdder  :: MonadIO m =>  ContextT w os f m (IORef a -> IO () -> IO ())
+getContextFinalizerAdder = do h <- ContextT (asks fst)
+                              return $ \k m -> void $ mkWeakIORef k (contextDoAsync h m)  
+
+liftContextIOAsync :: MonadIO m => IO () -> ContextT w os f m ()
+liftContextIOAsync m = ContextT (asks fst) >>= liftIO . flip contextDoAsync m
+
+-- | Run this action after a 'render' call to swap out the context windows back buffer with the front buffer, effectively showing the result.
+--   This call may block if vsync is enabled in the system and/or too many frames are outstanding.
+--   After this call, the context window content is undefined and should be cleared at earliest convenience using 'clearContextColor' and friends.
+swapContextBuffers :: MonadIO m => ContextT w os f m ()
+swapContextBuffers = ContextT (asks fst) >>= (\c -> liftIO $ contextDoSync c $ contextSwap c)
+
+type ContextDoAsync = IO () -> IO ()
+
+-- | A monad in which shaders are run.
+newtype Render os f a = Render (ErrorT String (ReaderT (ContextDoAsync, (ContextData, SharedContextDatas)) IO) a) deriving (Monad, Applicative, Functor)
+
+-- | Run a 'Render' monad, that may have the effect of the context window or textures being drawn to.
+--
+--   May throw a 'GPipeException' if a combination of draw images (FBO) used by this render call is unsupported by the graphics driver    
+render :: (MonadIO m, MonadException m) => Render os f () -> ContextT w os f m ()
+render (Render m) = do c <- ContextT ask
+                       eError <- liftIO $ contextDoSync (fst c) $ runReaderT (runErrorT m) (contextDoAsync (fst c), snd c)
+                       case eError of
+                        Left s -> liftIO $ throwIO $ GPipeException s
+                        _ -> return ()
+
+-- | Return the current size of the context frame buffer. This is needed to set viewport size and to get the aspect ratio to calculate projection matrices.  
+getContextBuffersSize :: MonadIO m => ContextT w os f m (V2 Int)
+getContextBuffersSize = ContextT $ do c <- asks fst
+                                      (x,y) <- liftIO $ contextDoSync c $ contextFrameBufferSize c
+                                      return $ V2 x y
+
+-- | Use the context window handle, which type is specific to the window system used. This handle shouldn't be returned from this function
+withContextWindow :: MonadIO m => (w -> IO a) -> ContextT w os f m a
+withContextWindow f= ContextT $ do c <- asks fst
+                                   liftIO $ contextDoSync c $ f (contextWindow c)
+
+getRenderContextFinalizerAdder  :: Render os f (IORef a -> IO () -> IO ())
+getRenderContextFinalizerAdder = do f <- Render (lift $ asks fst)
+                                    return $ \k m -> void $ mkWeakIORef k (f m)  
+
+-- | This kind of exception may be thrown from GPipe when a GPU hardware limit is reached (for instance, too many textures are drawn to from the same 'FragmentStream') 
+data GPipeException = GPipeException String
+     deriving (Show, Typeable)
+
+instance Exception GPipeException
+
+
+-- TODO Add async rules     
+{-# RULES
+"liftContextIO >>= liftContextIO >>= x"    forall m1 m2 x.  liftContextIO m1 >>= (\_ -> liftContextIO m2 >>= x) = liftContextIO (m1 >> m2) >>= x
+"liftContextIO >>= liftContextIO"          forall m1 m2.    liftContextIO m1 >>= (\_ -> liftContextIO m2) = liftContextIO (m1 >> m2)
+  #-}
+
+--------------------------
+
+type SharedContextDatas = MVar [ContextData]
+type ContextData = MVar (VAOCache, FBOCache)
+data VAOKey = VAOKey { vaoBname :: !GLuint, vaoCombBufferOffset :: !Int, vaoComponents :: !GLint, vaoNorm :: !Bool, vaoDiv :: !Int } deriving (Eq, Ord)
+data FBOKey = FBOKey { fboTname :: !GLuint, fboTlayerOrNegIfRendBuff :: !Int, fboTlevel :: !Int } deriving (Eq, Ord)
+data FBOKeys = FBOKeys { fboColors :: [FBOKey], fboDepth :: Maybe FBOKey, fboStencil :: Maybe FBOKey } deriving (Eq, Ord)  
+type VAOCache = Map.Map [VAOKey] (IORef GLuint)
+type FBOCache = Map.Map FBOKeys (IORef GLuint)
+
+getFBOKeys :: FBOKeys -> [FBOKey]
+getFBOKeys (FBOKeys xs d s) = xs ++ maybeToList d ++ maybeToList s
+
+newContextDatas :: IO (MVar [ContextData])
+newContextDatas = newMVar []
+
+addContextData :: SharedContextDatas -> IO ContextData
+addContextData r = do cd <- newMVar (Map.empty, Map.empty)  
+                      modifyMVar_ r $ return . (cd:)
+                      return cd
+
+removeContextData :: SharedContextDatas -> ContextData -> IO ()
+removeContextData r cd = modifyMVar_ r $ return . delete cd
+
+addCacheFinalizer :: MonadIO m => (GLuint -> (VAOCache, FBOCache) -> (VAOCache, FBOCache)) -> IORef GLuint -> ContextT w os f m ()
+addCacheFinalizer f r =  ContextT $ do cds <- asks (snd . snd)
+                                       liftIO $ do n <- readIORef r
+                                                   void $ mkWeakIORef r $ do cs' <- readMVar cds 
+                                                                             mapM_ (`modifyMVar_` (return . f n)) cs'
+
+addVAOBufferFinalizer :: MonadIO m => IORef GLuint -> ContextT w os f m ()
+addVAOBufferFinalizer = addCacheFinalizer deleteVAOBuf  
+    where deleteVAOBuf n (vao, fbo) = (Map.filterWithKey (\k _ -> all ((/=n) . vaoBname) k) vao, fbo)
+
+    
+addFBOTextureFinalizer :: MonadIO m => Bool -> IORef GLuint -> ContextT w os f m ()
+addFBOTextureFinalizer isRB = addCacheFinalizer deleteVBOBuf    
+    where deleteVBOBuf n (vao, fbo) = (vao, Map.filterWithKey
+                                          (\ k _ ->
+                                             all
+                                               (\ fk ->
+                                                  fboTname fk /= n || isRB /= (fboTlayerOrNegIfRendBuff fk < 0))
+                                               $ getFBOKeys k)
+                                          fbo)
+
+
+getContextData :: MonadIO m => ContextT w os f m ContextData
+getContextData = ContextT $ asks (fst . snd)
+
+getRenderContextData :: Render os f ContextData
+getRenderContextData = Render $ lift $ asks (fst . snd)
+
+getVAO :: ContextData -> [VAOKey] -> IO (Maybe (IORef GLuint))
+getVAO cd k = do (vaos, _) <- readMVar cd
+                 return (Map.lookup k vaos)    
+
+setVAO :: ContextData -> [VAOKey] -> IORef GLuint -> IO ()
+setVAO cd k v = modifyMVar_ cd $ \ (vaos, fbos) -> return (Map.insert k v vaos, fbos)  
+
+getFBO :: ContextData -> FBOKeys -> IO (Maybe (IORef GLuint))
+getFBO cd k = do (_, fbos) <- readMVar cd
+                 return (Map.lookup k fbos)
+
+setFBO :: ContextData -> FBOKeys -> IORef GLuint -> IO ()
+setFBO cd k v = modifyMVar_ cd $ \(vaos, fbos) -> return (vaos, Map.insert k v fbos)  

@@ -0,0 +1,1123 @@+{-# LANGUAGE GADTs, EmptyDataDecls, NoMonomorphismRestriction,
+  TypeFamilies, ScopedTypeVariables, FlexibleInstances, RankNTypes,
+  MultiParamTypeClasses, FlexibleContexts, OverloadedStrings #-}
+
+module Graphics.GPipe.Internal.Expr where
+
+import Prelude hiding ((.), id, (<*))
+import Data.Word
+import Control.Category
+import Control.Monad (void, when)
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Reader
+import Data.Monoid (mconcat, mappend)
+import qualified Control.Monad.Trans.Class as T (lift)
+import Data.SNMap
+import qualified Data.IntMap as Map
+import Data.Boolean
+import Data.List (intercalate)
+import Control.Applicative ((<$>))
+import Linear.V4
+import Linear.V3
+import Linear.V2
+import Linear.V1
+import Linear.V0
+import Linear.Affine
+import Linear.Metric
+import Linear.Matrix
+import Linear.Vector
+import Data.Foldable (toList, Foldable)
+
+type NextTempVar = Int
+type NextGlobal = Int
+
+data SType = STypeFloat | STypeInt | STypeBool | STypeUInt | STypeDyn String | STypeMat Int Int | STypeVec Int | STypeIVec Int | STypeUVec Int 
+
+stypeName :: SType -> String
+stypeName STypeFloat = "float"
+stypeName STypeInt = "int"
+stypeName STypeBool = "bool"
+stypeName STypeUInt = "uint"
+stypeName (STypeDyn s) = s
+stypeName (STypeMat r c) = "mat" ++ show c ++ 'x' : show r
+stypeName (STypeVec n) = "vec" ++ show n
+stypeName (STypeIVec n) = "ivec" ++ show n
+stypeName (STypeUVec n) = "uvec" ++ show n
+
+stypeSize :: SType -> Int
+stypeSize (STypeVec n) = n * 4
+stypeSize (STypeIVec n) = n * 4
+stypeSize (STypeUVec n) = n * 4
+stypeSize _ = 4
+
+type ExprM = SNMapReaderT [String] (StateT ExprState (WriterT String (StateT NextTempVar IO))) -- IO for stable names
+data ExprState = ExprState { 
+                shaderUsedUniformBlocks :: Map.IntMap (GlobDeclM ()), 
+                shaderUsedSamplers :: Map.IntMap (GlobDeclM ()),
+                shaderUsedInput :: Map.IntMap (GlobDeclM (), (ExprM (), GlobDeclM ())) -- For vertex shaders, the shaderM is always undefined and the int is the parameter name, for later shader stages it uses some name local to the transition instead    
+                 }
+                
+runExprM :: GlobDeclM () -> ExprM () -> IO (String, [Int], [Int], [Int], GlobDeclM (), ExprM ())
+runExprM d m = do
+               (st, body) <- evalStateT (runWriterT (execStateT (runSNMapReaderT (m :: ExprM ())) (ExprState Map.empty Map.empty Map.empty))) 0
+               let (unis, uniDecls) = unzip $ Map.toAscList (shaderUsedUniformBlocks st)
+                   (samps, sampDecls) = unzip $ Map.toAscList (shaderUsedSamplers st)
+                   (inps, inpDescs) = unzip $ Map.toAscList (shaderUsedInput st)
+                   (inpDecls, prevDesc) = unzip inpDescs
+                   (prevSs, prevDecls) = unzip prevDesc
+                   decls = do d
+                              sequence_ uniDecls 
+                              sequence_ sampDecls
+                              sequence_ inpDecls
+                   source = mconcat [
+                                "#version 330\n",
+                                execWriter decls,
+                                "void main() {\n",
+                                body,
+                                "}\n"]   
+               return (source, unis, samps, inps, sequence_ prevDecls, sequence_ prevSs)
+
+type GlobDeclM = Writer String
+
+newtype S x a = S { unS :: ExprM String } 
+
+scalarS :: SType -> ExprM RValue -> S c a
+scalarS typ = S . tellAssignment typ 
+
+vec2S :: SType -> ExprM RValue -> V2 (S c a)
+vec2S typ s = let V4 x y _z _w = vec4S typ s
+              in V2 x y
+vec3S :: SType -> ExprM RValue -> V3 (S c a)
+vec3S typ s = let V4 x y z _w = vec4S typ s
+              in V3 x y z
+vec4S :: SType -> ExprM RValue -> V4 (S c a)
+vec4S typ s = let m = tellAssignment typ s
+                  f p = S $ fmap (++ p) m
+              in V4 (f ".x") (f ".y") (f ".z") (f ".w")
+
+scalarS' :: RValue -> S c a
+scalarS' = S . return
+ 
+vec2S' :: RValue -> V2 (S c a)
+vec2S' = vec2S'' . S . return
+vec3S' :: RValue -> V3 (S c a)
+vec3S' = vec3S'' . S . return
+vec4S' :: RValue -> V4 (S c a)
+vec4S' = vec4S'' . S . return
+
+vec2S'' :: S c a -> V2 (S c a)
+vec2S'' s = let V4 x y _z _w = vec4S'' s
+            in V2 x y
+vec3S'' :: S c a -> V3 (S c a)
+vec3S'' s = let V4 x y z _w = vec4S'' s
+            in V3 x y z
+vec4S'' :: S c a -> V4 (S c a)
+vec4S'' s = let f p = S $ fmap (++ ('[': show (p :: Int) ++"]")) (unS s)
+            in V4 (f 0) (f 1) (f 2) (f 3)
+
+-- | Phantom type used as first argument in @'S' 'V' a@ that denotes that the shader value is a vertex value              
+data V
+--data P
+-- | Phantom type used as first argument in @'S' 'F' a@ that denotes that the shader value is a fragment value              
+data F
+
+type VFloat = S V Float
+type VInt = S V Int
+type VWord = S V Word
+type VBool = S V Bool
+
+type FFloat = S F Float
+type FInt = S F Int
+type FWord = S F Word
+type FBool = S F Bool
+
+useVInput :: SType -> Int -> ExprM String
+useVInput stype i = 
+             do s <- T.lift get
+                T.lift $ put $ s { shaderUsedInput = Map.insert i (gDeclInput, undefined) $ shaderUsedInput s }                
+                return $ "in" ++ show i
+    where
+        gDeclInput = do tellGlobal "in "
+                        tellGlobal $ stypeName stype          
+                        tellGlobal " in"
+                        tellGlobalLn $ show i
+
+useFInput :: String -> String -> SType -> Int -> ExprM String -> ExprM String
+useFInput qual prefix stype i v =
+             do s <- T.lift get
+                T.lift $ put $ s { shaderUsedInput = Map.insert i (gDecl (qual ++ " in "), (assignOutput, gDecl (qual ++ " out "))) $ shaderUsedInput s }                
+                return $ prefix ++ show i
+    where
+        assignOutput = do val <- v
+                          let name = prefix ++ show i
+                          tellAssignment' name val
+                    
+        gDecl s =    do tellGlobal s
+                        tellGlobal $ stypeName stype          
+                        tellGlobal $ ' ':prefix
+                        tellGlobalLn $ show i
+
+   
+useUniform :: GlobDeclM () -> Int -> Int -> ExprM String
+useUniform decls blockI offset = 
+             do T.lift $ modify $ \ s -> s { shaderUsedUniformBlocks = Map.insert blockI gDeclUniformBlock $ shaderUsedUniformBlocks s } 
+                return $ 'u':show blockI ++ '.':'u': show offset -- "u8.u4"
+    where
+        gDeclUniformBlock =
+            do  let blockStr = show blockI
+                tellGlobal "layout(std140) uniform uBlock"
+                tellGlobal blockStr
+                tellGlobal " {\n"
+                decls
+                tellGlobal "} u"
+                tellGlobalLn blockStr
+
+useSampler :: String -> String -> Int -> ExprM String
+useSampler prefix str name = 
+             do T.lift $ modify $ \ s -> s { shaderUsedSamplers = Map.insert name gDeclSampler $ shaderUsedSamplers s } 
+                return $ 's':show name
+    where
+        gDeclSampler = do tellGlobal "uniform "
+                          tellGlobal prefix 
+                          tellGlobal "sampler"
+                          tellGlobal str
+                          tellGlobal " s"
+                          tellGlobalLn $ show name 
+
+getNext :: Monad m => StateT Int m Int
+getNext = do
+    s <- get
+    put $ s + 1
+    return s
+       
+type RValue = String
+
+tellAssignment :: SType -> ExprM RValue -> ExprM String
+tellAssignment typ m = fmap head . memoizeM $ do
+                                 val <- m
+                                 var <- T.lift $ T.lift $ T.lift getNext
+                                 let name = 't' : show var
+                                 T.lift $ T.lift $ tell (stypeName typ ++ " ")
+                                 tellAssignment' name val
+                                 return [name]
+
+tellAssignment' :: String -> RValue -> ExprM ()
+tellAssignment' name string = T.lift $ T.lift $ tell $ mconcat [name, " = ", string, ";\n"]
+
+discard :: FBool -> ExprM ()
+discard (S m) = do b <- m
+                   when (b /= "true") $ T.lift $ T.lift $ tell $ mconcat ["if (!(", b, ")) discard;\n"]
+                                       
+--
+tellGlobalLn :: String -> GlobDeclM ()
+tellGlobalLn string = tell $ string `mappend` ";\n"
+--
+tellGlobal :: String -> GlobDeclM ()
+tellGlobal = tell
+
+-----------------------
+
+data ShaderBase a x where
+    ShaderBaseFloat :: S x Float -> ShaderBase (S x Float) x 
+    ShaderBaseInt :: S x Int -> ShaderBase (S x Int) x 
+    ShaderBaseWord :: S x Word -> ShaderBase (S x Word) x 
+    ShaderBaseBool :: S x Bool -> ShaderBase (S x Bool) x 
+    ShaderBaseUnit :: ShaderBase () x 
+    ShaderBaseProd :: ShaderBase a x -> ShaderBase b x -> ShaderBase (a,b) x 
+
+shaderbaseDeclare :: ShaderBase a x -> WriterT [String] ExprM (ShaderBase a x)
+shaderbaseAssign :: ShaderBase a x -> StateT [String] ExprM ()
+shaderbaseReturn :: ShaderBase a x -> ReaderT (ExprM [String]) (State Int) (ShaderBase a x)
+
+shaderbaseDeclare (ShaderBaseFloat _) = ShaderBaseFloat <$> shaderbaseDeclareDef STypeFloat
+shaderbaseDeclare (ShaderBaseInt _) = ShaderBaseInt <$> shaderbaseDeclareDef STypeInt
+shaderbaseDeclare (ShaderBaseWord _) = ShaderBaseWord <$> shaderbaseDeclareDef STypeUInt
+shaderbaseDeclare (ShaderBaseBool _) = ShaderBaseBool <$> shaderbaseDeclareDef STypeBool
+shaderbaseDeclare ShaderBaseUnit = return ShaderBaseUnit 
+shaderbaseDeclare (ShaderBaseProd a b) = do a' <- shaderbaseDeclare a
+                                            b' <- shaderbaseDeclare b
+                                            return $ ShaderBaseProd a' b'
+
+shaderbaseAssign (ShaderBaseFloat a) = shaderbaseAssignDef a
+shaderbaseAssign (ShaderBaseInt a) = shaderbaseAssignDef a
+shaderbaseAssign (ShaderBaseWord a) = shaderbaseAssignDef a
+shaderbaseAssign (ShaderBaseBool a) = shaderbaseAssignDef a
+shaderbaseAssign ShaderBaseUnit = return ()
+shaderbaseAssign (ShaderBaseProd a b) = do shaderbaseAssign a
+                                           shaderbaseAssign b
+
+shaderbaseReturn (ShaderBaseFloat _) = ShaderBaseFloat <$> shaderbaseReturnDef
+shaderbaseReturn (ShaderBaseInt _) = ShaderBaseInt <$> shaderbaseReturnDef
+shaderbaseReturn (ShaderBaseWord _) = ShaderBaseWord <$> shaderbaseReturnDef
+shaderbaseReturn (ShaderBaseBool _) = ShaderBaseBool <$> shaderbaseReturnDef
+shaderbaseReturn ShaderBaseUnit = return ShaderBaseUnit 
+shaderbaseReturn (ShaderBaseProd a b) = do a' <- shaderbaseReturn a
+                                           b' <- shaderbaseReturn b
+                                           return $ ShaderBaseProd a' b'
+
+shaderbaseDeclareDef :: SType -> WriterT [String] ExprM (S x a)
+shaderbaseDeclareDef styp = do var <- T.lift $ T.lift $ T.lift $ T.lift getNext
+                               let root = 't' : show var
+                               T.lift $ T.lift $ T.lift $ tell $ mconcat [stypeName styp, ' ':root, ";\n"]
+                               tell [root]
+                               return $ S $ return root
+
+shaderbaseAssignDef  (S shaderM) = do ul <- T.lift shaderM
+                                      x:xs <- get
+                                      put xs
+                                      T.lift $ tellAssignment' x ul
+                                      return ()
+shaderbaseReturnDef :: ReaderT (ExprM [String]) (State Int) (S x a)
+shaderbaseReturnDef = do i <- T.lift getNext
+                         m <- ask
+                         return $ S $ fmap (!!i) m
+
+    
+class ShaderType a x where
+    type ShaderBaseType a
+    toBase :: x -> a -> ShaderBase (ShaderBaseType a) x
+    fromBase :: x -> ShaderBase (ShaderBaseType a) x -> a
+    
+instance ShaderType (S x Float) x where
+    type ShaderBaseType (S x Float) = (S x Float)
+    toBase _ = ShaderBaseFloat
+    fromBase _ (ShaderBaseFloat a) = a
+
+instance ShaderType (S x Int) x where
+    type ShaderBaseType (S x Int) = (S x Int)
+    toBase _ = ShaderBaseInt
+    fromBase _ (ShaderBaseInt a) = a
+    
+instance ShaderType (S x Word) x where
+    type ShaderBaseType (S x Word) = (S x Word)
+    toBase _ = ShaderBaseWord
+    fromBase _ (ShaderBaseWord a) = a
+
+instance ShaderType (S x Bool) x where
+    type ShaderBaseType (S x Bool) = (S x Bool)
+    toBase _ = ShaderBaseBool
+    fromBase _ (ShaderBaseBool a) = a
+    
+instance ShaderType () x where
+    type ShaderBaseType () = ()
+    toBase _ () = ShaderBaseUnit
+    fromBase _ ShaderBaseUnit = ()
+
+instance ShaderType a x => ShaderType (V0 a) x where
+    type ShaderBaseType (V0 a) = ()
+    toBase _ V0 = ShaderBaseUnit
+    fromBase _ ShaderBaseUnit = V0
+instance ShaderType a x => ShaderType (V1 a) x where
+    type ShaderBaseType (V1 a) = ShaderBaseType a
+    toBase x ~(V1 a) = toBase x a
+    fromBase x a = V1 (fromBase x a)
+instance ShaderType a x => ShaderType (V2 a) x where
+    type ShaderBaseType (V2 a) = (ShaderBaseType a, ShaderBaseType a)
+    toBase x ~(V2 a b) = ShaderBaseProd (toBase x a) (toBase x b)
+    fromBase x (ShaderBaseProd a b) = V2 (fromBase x a) (fromBase x b)
+instance ShaderType a x => ShaderType (V3 a) x where
+    type ShaderBaseType (V3 a) = (ShaderBaseType a, (ShaderBaseType a, ShaderBaseType a))
+    toBase x ~(V3 a b c) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (toBase x c))
+    fromBase x (ShaderBaseProd a (ShaderBaseProd b c)) = V3 (fromBase x a) (fromBase x b) (fromBase x c)
+instance ShaderType a x => ShaderType (V4 a) x where
+    type ShaderBaseType (V4 a) = (ShaderBaseType a, (ShaderBaseType a, (ShaderBaseType a, ShaderBaseType a)))
+    toBase x ~(V4 a b c d) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (toBase x d)))
+    fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c d))) = V4 (fromBase x a) (fromBase x b) (fromBase x c) (fromBase x d)
+
+instance (ShaderType a x, ShaderType b x) => ShaderType (a,b) x where
+    type ShaderBaseType (a,b) = (ShaderBaseType a, ShaderBaseType b)
+    toBase x ~(a,b) = ShaderBaseProd (toBase x a) (toBase x b)
+    fromBase x (ShaderBaseProd a b) = (fromBase x a, fromBase x b)
+instance (ShaderType a x, ShaderType b x, ShaderType c x) => ShaderType (a,b,c) x where
+    type ShaderBaseType (a,b,c) = (ShaderBaseType a, (ShaderBaseType b, ShaderBaseType c))
+    toBase x ~(a,b,c) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (toBase x c))
+    fromBase x (ShaderBaseProd a (ShaderBaseProd b c)) = (fromBase x a, fromBase x b, fromBase x c)
+instance (ShaderType a x, ShaderType b x, ShaderType c x, ShaderType d x) => ShaderType (a,b,c,d) x where
+    type ShaderBaseType (a,b,c,d) = (ShaderBaseType a, (ShaderBaseType b, (ShaderBaseType c, ShaderBaseType d)))
+    toBase x ~(a,b,c,d) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (toBase x d)))
+    fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c d))) = (fromBase x a, fromBase x b, fromBase x c, fromBase x d)
+    
+ifThenElse' :: forall a x. (ShaderType a x) => S x Bool -> a -> a -> a
+ifThenElse' b t e = ifThenElse b (const t) (const e) ()
+
+ifThenElse :: forall a b x. (ShaderType a x, ShaderType b x) => S x Bool -> (a -> b) -> (a -> b) -> a -> b
+ifThenElse c t e i = fromBase x $ ifThenElse_ c (toBase x . t . fromBase x) (toBase x . e . fromBase x) (toBase x i)
+    where
+        x = undefined :: x
+        ifThenElse_ :: S x Bool -> (ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType b) x) -> (ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType b) x) -> ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType b) x
+        ifThenElse_ bool thn els a = 
+            let ifM = memoizeM $ do
+                           boolStr <- unS bool
+                           (lifted, aDecls) <- runWriterT $ shaderbaseDeclare (toBase x (undefined :: a))
+                           void $ evalStateT (shaderbaseAssign a) aDecls
+                           decls <- execWriterT $ shaderbaseDeclare (toBase x (undefined :: b))
+                           tellIf boolStr                
+                           void $ evalStateT (shaderbaseAssign $ thn lifted) decls                                    
+                           T.lift $ T.lift $ tell "} else {\n"                   
+                           void $ evalStateT (shaderbaseAssign $ els lifted) decls
+                           T.lift $ T.lift $ tell "}\n"                                                 
+                           return decls
+            in evalState (runReaderT (shaderbaseReturn (toBase x (undefined :: b))) ifM) 0
+
+ifThen :: forall a x. (ShaderType a x) => S x Bool -> (a -> a) -> a -> a
+ifThen c t i = fromBase x $ ifThen_ c (toBase x . t . fromBase x) (toBase x i)
+    where
+        x = undefined :: x
+        ifThen_ :: S x Bool -> (ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x) -> ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x
+        ifThen_ bool thn a = 
+            let ifM = memoizeM $ do
+                           boolStr <- unS bool
+                           (lifted, decls) <- runWriterT $ shaderbaseDeclare (toBase x (undefined :: a))
+                           void $ evalStateT (shaderbaseAssign a) decls
+                           tellIf boolStr
+                           void $ evalStateT (shaderbaseAssign $ thn lifted) decls                                    
+                           T.lift $ T.lift $ tell "}\n"
+                           return decls
+            in evalState (runReaderT (shaderbaseReturn (toBase x (undefined :: a))) ifM) 0
+    
+
+tellIf :: RValue -> ExprM ()
+tellIf boolStr = T.lift $ T.lift $ tell $ mconcat ["if(", boolStr, "){\n" ]
+while :: forall a x. (ShaderType a x) => (a -> S x Bool) -> (a -> a) -> a -> a
+while c f i = fromBase x $ while_ (c . fromBase x) (toBase x . f . fromBase x) (toBase x i)            
+    where
+        x = undefined :: x
+        while_ :: (ShaderBase (ShaderBaseType a) x -> S x Bool) -> (ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x) -> ShaderBase (ShaderBaseType a) x -> ShaderBase (ShaderBaseType a) x                                 
+        while_ bool loopF a = let whileM = memoizeM $ do
+                                           (lifted, decls) <- runWriterT $ shaderbaseDeclare (toBase x (undefined :: a))
+                                           void $ evalStateT (shaderbaseAssign a) decls
+                                           boolDecl <- tellAssignment STypeBool (unS $ bool a)
+                                           T.lift $ T.lift $ tell $ mconcat ["while(", boolDecl, "){\n" ]
+                                           let looped = loopF lifted                                
+                                           void $ evalStateT (shaderbaseAssign looped) decls 
+                                           loopedBoolStr <- unS $ bool looped
+                                           tellAssignment' boolDecl loopedBoolStr
+                                           T.lift $ T.lift $ tell "}\n"
+                                           return decls
+                             in evalState (runReaderT (shaderbaseReturn (toBase x (undefined :: a))) whileM) 0
+
+
+--------------------------------------------------------------------------------------------------------------------------------
+--------------------------------------------------------------------------------------------------------------------------------
+--------------------------------------------------------------------------------------------------------------------------------
+--------------------------------------------------------------------------------------------------------------------------------
+--------------------------------------------------------------------------------------------------------------------------------
+
+
+bin :: SType -> String -> S c x -> S c y -> S c z 
+bin typ o (S a) (S b) = S $ tellAssignment typ $ do a' <- a
+                                                    b' <- b
+                                                    return $ '(' : a' ++ o ++ b' ++ ")"
+
+fun1 :: SType -> String -> S c x -> S c y
+fun1 typ f (S a) = S $ tellAssignment typ $ do a' <- a
+                                               return $ f ++ '(' : a' ++ ")"
+
+fun2 :: SType -> String -> S c x -> S c y -> S c z
+fun2 typ f (S a) (S b) = S $ tellAssignment typ $ do a' <- a
+                                                     b' <- b
+                                                     return $ f ++ '(' : a' ++ ',' : b' ++ ")"
+
+fun3 :: SType -> String -> S c x -> S c y -> S c z -> S c w
+fun3 typ f (S a) (S b) (S c) = S $ tellAssignment typ $ do a' <- a
+                                                           b' <- b
+                                                           c' <- c
+                                                           return $ f ++ '(' : a' ++ ',' : b' ++ ',' : c' ++")"
+
+fun4 :: SType -> String -> S c x -> S c y -> S c z -> S c w -> S c r
+fun4 typ f (S a) (S b) (S c) (S d) = S $ tellAssignment typ $ do a' <- a
+                                                                 b' <- b
+                                                                 c' <- c
+                                                                 d' <- d
+                                                                 return $ f ++ '(' : a' ++ ',' : b' ++ ',' : c' ++ ',' : d' ++")"
+
+postop :: SType -> String -> S c x -> S c y
+postop typ f (S a) = S $ tellAssignment typ $ do a' <- a
+                                                 return $ '(' : a' ++ f ++ ")"
+                          
+preop :: SType -> String -> S c x -> S c y
+preop typ f (S a) = S $ tellAssignment typ $ do a' <- a
+                                                return $ '(' : f ++ a' ++ ")"
+
+binf :: String -> S c x -> S c y -> S c Float
+binf = bin STypeFloat
+fun1f :: String -> S c x -> S c Float
+fun1f = fun1 STypeFloat
+fun2f :: String -> S c x -> S c y -> S c Float
+fun2f = fun2 STypeFloat
+fun3f :: String -> S c x -> S c y -> S c z -> S c Float
+fun3f = fun3 STypeFloat
+preopf :: String -> S c x -> S c Float
+preopf = preop STypeFloat
+postopf :: String -> S c x -> S c Float
+postopf = postop STypeFloat
+
+bini :: String -> S c x -> S c y -> S c Int
+bini = bin STypeInt
+fun1i :: String -> S c x -> S c Int
+fun1i = fun1 STypeInt
+preopi :: String -> S c x -> S c Int
+preopi = preop STypeInt
+
+binu :: String -> S c x -> S c y -> S c Word
+binu = bin STypeUInt
+fun1u :: String -> S c x -> S c Word
+fun1u = fun1 STypeUInt
+preopu :: String -> S c x -> S c Word
+preopu = preop STypeUInt
+
+instance Num (S a Float) where
+    (+) = binf "+"
+    (-) = binf "-"
+    abs = fun1f "abs"
+    signum = fun1f "sign"
+    (*) = binf "*"
+    fromInteger = S . return . show
+    negate = preopf "-"
+
+instance Num (S a Int) where
+    (+) = bini "+"
+    (-) = bini "-"
+    abs = fun1i "abs"
+    signum = fun1i "sign"
+    (*) = bini "*"
+    fromInteger = S . return . show
+    negate = preopi "-"
+    
+instance Num (S a Word) where
+    (+) = binu "+"
+    (-) = binu "-"
+    abs = fun1u "abs"
+    signum = fun1u "sign"
+    (*) = binu "*"
+    fromInteger x = S $ return $ show x ++ "u"
+    negate = preopu "-"   
+
+instance Fractional (S a Float) where
+  (/)          = binf "/"
+  fromRational = S . return . show . (`asTypeOf` (undefined :: Float)) . fromRational
+
+class Integral' a where
+    div' :: a -> a -> a
+    mod' :: a -> a -> a
+
+instance Integral' Int where
+    div' = div
+    mod' = mod
+instance Integral' Word where
+    div' = div
+    mod' = mod
+instance Integral' (S a Int) where
+    div' = bini "/"
+    mod' = bini "%" 
+instance Integral' (S a Word) where
+    div' = binu "/"
+    mod' = binu "%" 
+
+instance Floating (S a Float) where
+  pi    = S $ return $ show (pi :: Float)
+  sqrt  = fun1f "sqrt"
+  exp   = fun1f "exp"
+  log   = fun1f "log"
+  (**)  = fun2f "pow"
+  sin   = fun1f "sin"
+  cos   = fun1f "cos"
+  tan   = fun1f "tan"
+  asin  = fun1f "asin"
+  acos  = fun1f "acos"
+  atan  = fun1f "atan"
+  sinh  = fun1f "sinh"
+  cosh  = fun1f "cosh"
+  asinh = fun1f "asinh"
+  atanh = fun1f "atanh"
+  acosh = fun1f "acosh"
+
+instance Boolean (S a Bool) where
+  true = S $ return "true"
+  false = S $ return "false"
+  notB  = preop STypeBool "!"
+  (&&*) = bin STypeBool "&&"
+  (||*) = bin STypeBool "||"
+
+type instance BooleanOf (S a x) = S a Bool
+
+type instance BooleanOf (V0 a) = BooleanOf a
+type instance BooleanOf (V1 a) = BooleanOf a
+type instance BooleanOf (V2 a) = BooleanOf a
+type instance BooleanOf (V3 a) = BooleanOf a
+type instance BooleanOf (V4 a) = BooleanOf a
+
+instance Eq x => EqB (S a x) where
+  (==*) = bin STypeBool "=="
+  (/=*) = bin STypeBool "!="
+
+instance EqB a => EqB (V0 a) where
+  V0 ==* V0 = true
+  V0 /=* V0 = false
+instance EqB a => EqB (V1 a) where
+  V1 a ==* V1 x = a ==* x
+  V1 a /=* V1 x = a /=* x
+instance EqB a => EqB (V2 a) where
+  V2 a b ==* V2 x y = a ==* x &&* b ==* y
+  V2 a b /=* V2 x y = a /=* x ||* b /=* y
+instance EqB a => EqB (V3 a) where
+  V3 a b c ==* V3 x y z = a ==* x &&* b ==* y &&* c ==* z
+  V3 a b c /=* V3 x y z = a /=* x ||* b /=* y ||* c /=* z
+instance EqB a => EqB (V4 a) where
+  V4 a b c d ==* V4 x y z w = a ==* x &&* b ==* y &&* c ==* z &&* d ==* w
+  V4 a b c d /=* V4 x y z w = a /=* x ||* b /=* y ||* c /=* z ||* d /=* w
+
+instance Ord x => OrdB (S a x) where
+  (<*) = bin STypeBool "<"
+  (<=*) = bin STypeBool "<="
+  (>=*) = bin STypeBool ">="
+  (>*) = bin STypeBool ">"
+
+instance IfB (S a x) where
+        ifB (S c) (S t) (S e) = S $ tellAssignment STypeBool $ do c' <- c
+                                                                  t' <- t
+                                                                  e' <- e
+                                                                  return $ '(' : c' ++ '?' : t' ++ ':' : e' ++")"
+
+instance IfB a => IfB (V0 a) where
+        ifB q _ _ = V0 
+instance IfB a => IfB (V1 a) where
+        ifB q (V1 a) (V1 x) = V1 (ifB q a x) 
+instance IfB a => IfB (V2 a) where
+        ifB q (V2 a b) (V2 x y) = V2 (ifB q a x) (ifB q b y) 
+instance IfB a => IfB (V3 a) where
+        ifB q (V3 a b c) (V3 x y z) = V3 (ifB q a x) (ifB q b y) (ifB q c z) 
+instance IfB a => IfB (V4 a) where
+        ifB q (V4 a b c d) (V4 x y z w) = V4 (ifB q a x) (ifB q b y) (ifB q c z) (ifB q d w) 
+                                       
+-- | This class provides the GPU functions either not found in Prelude's numerical classes, or that has wrong types.
+--   Instances are also provided for normal 'Float's and 'Double's.
+--   Minimal complete definition: 'floor'' or 'ceiling''.
+class (IfB a, OrdB a, Floating a) => Real' a where
+  rsqrt :: a -> a
+  exp2 :: a -> a
+  log2 :: a -> a
+  floor' :: a -> a
+  ceiling' :: a -> a
+  fract' :: a -> a
+  mod'' :: a -> a -> a
+  clamp :: a -> a -> a -> a
+  saturate :: a -> a
+  mix :: a -> a -> a-> a
+  step :: a -> a -> a
+  smoothstep :: a -> a -> a -> a
+
+  rsqrt = (1/) . sqrt
+  exp2 = (2**)
+  log2 = logBase 2
+  clamp x a = minB (maxB x a)
+  saturate x = clamp x 0 1
+  mix x y a = x*(1-a)+y*a
+  step a x = ifB (x <* a) 0 1
+  smoothstep a b x = let t = saturate ((x-a) / (b-a))
+                     in t*t*(3-2*t)
+  fract' x = x - floor' x
+  mod'' x y = x - y* floor' (x/y)
+  floor' x = -ceiling' (-x)
+  ceiling' x = -floor' (-x)
+  
+  {-# MINIMAL floor' | ceiling' #-}
+
+
+instance Real' Float where
+  clamp x a = min (max x a)
+  step a x | x < a     = 0
+           | otherwise = 1
+  floor' = fromIntegral . floor
+  ceiling' = fromIntegral . ceiling
+
+instance Real' Double where
+  clamp x a = min (max x a)
+  step a x | x < a     = 0
+           | otherwise = 1
+  floor' = fromIntegral . floor
+  ceiling' = fromIntegral . ceiling
+  
+instance Real' (S x Float) where
+  rsqrt = fun1f "inversesqrt"
+  exp2 = fun1f "exp2"
+  log2 = fun1f "log2"
+  floor' = fun1f "floor"
+  ceiling' = fun1f "ceil"
+  fract' = fun1f "fract"
+  mod'' = fun2f "mod"
+  clamp = fun3f "clamp"
+  mix = fun3f "mix"
+  step = fun2f "step"
+  smoothstep = fun3f "smoothstep"
+
+
+-- | Provides a common way to convert numeric types to integer and floating point representations.
+class Convert a where
+    type ConvertFloat a
+    type ConvertInt a
+    type ConvertWord a
+    -- | Convert to a floating point number.
+    toFloat :: a -> ConvertFloat a
+    -- | Convert to an integral number, using truncation if necessary.
+    toInt :: a -> ConvertInt a
+    -- | Convert to an unsigned integral number, using truncation if necessary.
+    toWord :: a -> ConvertWord a
+
+instance Convert Float where
+    type ConvertFloat Float = Float
+    type ConvertInt Float = Int
+    type ConvertWord Float = Word
+    toFloat = id
+    toInt = truncate
+    toWord = truncate
+instance Convert Int where
+    type ConvertFloat Int = Float
+    type ConvertInt Int = Int
+    type ConvertWord Int = Word
+    toFloat = fromIntegral
+    toInt = id
+    toWord = fromIntegral
+instance Convert Word where
+    type ConvertFloat Word = Float
+    type ConvertInt Word = Int
+    type ConvertWord Word = Word
+    toFloat = fromIntegral
+    toInt = fromIntegral
+    toWord = id
+instance Convert (S x Float) where
+    type ConvertFloat (S x Float) = S x Float
+    type ConvertInt (S x Float) = S x Int
+    type ConvertWord (S x Float) = S x Word
+    toFloat = id
+    toInt = fun1i "int"
+    toWord = fun1u "uint"
+instance Convert (S x Int) where
+    type ConvertFloat (S x Int) = S x Float
+    type ConvertInt (S x Int) = S x Int
+    type ConvertWord (S x Int) = S x Word
+    toFloat = fun1f "float"
+    toInt = id
+    toWord = fun1u "uint"
+instance Convert (S x Word) where
+    type ConvertFloat (S x Word) = S x Float
+    type ConvertInt (S x Word) = S x Int
+    type ConvertWord (S x Word) = S x Word
+    toFloat = fun1f "float"
+    toInt = fun1i "int"
+    toWord = id
+  
+-- | The derivative in x using local differencing of the rasterized value.
+dFdx :: FFloat -> FFloat
+-- | The derivative in y using local differencing of the rasterized value.
+dFdy :: FFloat -> FFloat
+-- | The sum of the absolute derivative in x and y using local differencing of the rasterized value.
+fwidth :: FFloat -> FFloat
+dFdx = fun1f "dFdx"
+dFdy = fun1f "dFdy"
+fwidth = fun1f "fwidth"
+
+---------------------------------
+fromV f s v = S $ do params <- mapM (unS . f) $ toList v
+                     return $ s ++ '(' : intercalate "," params ++ ")"  
+
+fromVec4 :: V4 (S x Float) -> S x (V4 Float)
+fromVec4 = fromV id "vec4"  
+fromVec3 :: V3 (S x Float) -> S x (V3 Float)
+fromVec3 = fromV id "vec3"  
+fromVec2 :: V2 (S x Float) -> S x (V2 Float)
+fromVec2 = fromV id "vec2"  
+
+-- FromMat will transpose to keep inner vectors packed 
+fromMat22 :: V2 (V2 (S x Float)) -> S x (V2 (V2 Float))
+fromMat22 = fromV fromVec2 "mat2x2"
+fromMat23 :: V2 (V3 (S x Float)) -> S x (V2 (V3 Float))
+fromMat23 = fromV fromVec3 "mat2x3"
+fromMat24 :: V2 (V4 (S x Float)) -> S x (V2 (V4 Float))
+fromMat24 = fromV fromVec4 "mat2x4"
+
+fromMat32 :: V3 (V2 (S x Float)) -> S x (V3 (V2 Float))
+fromMat32 = fromV fromVec2 "mat3x2"
+fromMat33 :: V3 (V3 (S x Float)) -> S x (V3 (V3 Float))
+fromMat33 = fromV fromVec3 "mat3x3"
+fromMat34 :: V3 (V4 (S x Float)) -> S x (V3 (V4 Float))
+fromMat34 = fromV fromVec4 "mat3x4"
+
+fromMat42 :: V4 (V2 (S x Float)) -> S x (V4 (V2 Float))
+fromMat42 = fromV fromVec2 "mat4x2"
+fromMat43 :: V4 (V3 (S x Float)) -> S x (V4 (V3 Float))
+fromMat43 = fromV fromVec3 "mat4x3"
+fromMat44 :: V4 (V4 (S x Float)) -> S x (V4 (V4 Float))
+fromMat44 = fromV fromVec4 "mat4x4"
+
+mulToV4 a b = vec4S'' $ bin (STypeVec 4) "*" a b
+mulToV3 a b = vec3S'' $ bin (STypeVec 3) "*" a b
+mulToV2 a b = vec2S'' $ bin (STypeVec 2) "*" a b
+
+mulToM (r,x) (c,y) a b = fmap y $ x $ bin (STypeMat c r) "*" a b
+
+d2 = (2,vec2S'')
+d3 = (3,vec3S'')
+d4 = (4,vec4S'')
+
+unV1 :: V1 t -> t
+unV1 (V1 x) = x
+
+outerToM (r,x) (c,y) a b = fmap y $ x $ fun2 (STypeMat c r) "outerProduct" a b
+
+------------------------------------------------------------------------------------------------------------------------------------
+------------------------------------------------------------------------------------------------------------------------------------
+-------------------------------------------------- Rewrite rules for linear types --------------------------------------------------  
+------------------------------------------------------------------------------------------------------------------------------------
+------------------------------------------------------------------------------------------------------------------------------------
+                              
+{-# RULES "norm/length4" norm = length4 #-}
+{-# RULES "norm/length3" norm = length3 #-}
+{-# RULES "norm/length2" norm = length2 #-}
+length4 :: V4 (S x Float) -> S x Float
+length4 = fun1f "length" . fromVec4
+length3 :: V3 (S x Float) -> S x Float
+length3 = fun1f "length" . fromVec3
+length2 :: V2 (S x Float) -> S x Float
+length2 = fun1f "length" . fromVec2
+
+{-# RULES "signorm/normalize4" signorm = normalize4 #-}
+{-# RULES "signorm/normalize3" signorm = normalize3 #-}
+{-# RULES "signorm/normalize2" signorm = normalize2 #-}
+normalize4 :: V4 (S x Float) -> V4 (S x Float) 
+normalize4 = vec4S'' . fun1 (STypeVec 4) "normalize" . fromVec4
+normalize3 :: V3 (S x Float) -> V3 (S x Float) 
+normalize3 = vec3S'' . fun1 (STypeVec 3) "normalize" . fromVec3
+normalize2 :: V2 (S x Float) -> V2 (S x Float)
+normalize2 = vec2S'' . fun1 (STypeVec 2) "normalize" . fromVec2
+
+{-# RULES "distanceA/dist4" distanceA = dist4 #-}
+{-# RULES "distanceA/dist3" distanceA = dist3 #-}
+{-# RULES "distanceA/dist2" distanceA = dist2 #-}
+{-# RULES "distance/dist4" distance = dist4 #-}
+{-# RULES "distance/dist3" distance = dist3 #-}
+{-# RULES "distance/dist2" distance = dist2 #-}
+dist4 :: V4 (S x Float) -> V4 (S x Float) -> S x Float
+dist4 a b = fun2f "distance" (fromVec4 a) (fromVec4 b)
+dist3 :: V3 (S x Float) -> V3 (S x Float) -> S x Float
+dist3 a b = fun2f "distance" (fromVec3 a) (fromVec3 b)
+dist2 :: V2 (S x Float) -> V2 (S x Float) -> S x Float
+dist2 a b = fun2f "distance" (fromVec2 a) (fromVec2 b)
+
+
+{-# RULES "cross/S" cross = crossS #-}
+crossS :: V3 (S x Float) -> V3 (S x Float) -> V3 (S x Float)
+crossS a b = vec3S'' $ fun2 (STypeVec 3) "cross" (fromVec3 a) (fromVec3 b)
+
+{-# RULES "minB/S" minB = minS #-}
+{-# RULES "maxB/S" maxB = maxS #-}
+minS :: S x Float -> S x Float -> S x Float 
+minS = binf "min"
+maxS :: S x Float -> S x Float -> S x Float 
+maxS = binf "max"
+
+--------------------------------------------------------------
+
+-- Matrix*Matrix, Vector*Matrix, Matrix*Vextor and outer Vector*Vector multiplications have operands in flipped order since glsl is column major
+-- inner products are not flipped since why bother :)
+
+-- Also, special verions when explicit V1 matrices are used (so eg 4 version of each dot function: v*v, v*m, m*v, m*m ) 
+
+-- No rules for scalar products with vectors or matrices (eg scalar * matrix), we hope the glsl compiler will manage to optimize that...
+
+{-# RULES "mul_12_21vv" dot = mul_12_21vv #-}
+{-# RULES "mul_13_31vv" dot = mul_13_31vv #-}
+{-# RULES "mul_14_41vv" dot = mul_14_41vv #-}
+mul_12_21vv :: V2 (S x Float) -> V2 (S x Float) -> S x Float
+mul_12_21vv a b = fun2f "dot" (fromVec2 a) (fromVec2 b)
+mul_13_31vv :: V3 (S x Float) -> V3 (S x Float) -> S x Float
+mul_13_31vv a b = fun2f "dot" (fromVec3 a) (fromVec3 b)
+mul_14_41vv :: V4 (S x Float) -> V4 (S x Float) -> S x Float
+mul_14_41vv a b = fun2f "dot" (fromVec4 a) (fromVec4 b)
+
+{-# RULES "mul_12_21vm" (*!) = mul_12_21vm #-}
+{-# RULES "mul_13_31vm" (*!) = mul_13_31vm #-}
+{-# RULES "mul_14_41vm" (*!) = mul_14_41vm #-}
+mul_12_21vm :: V2 (S x Float) -> V2 (V1 (S x Float)) -> V1 (S x Float)
+mul_12_21vm a b = V1 $ fun2f "dot" (fromVec2 a) (fromVec2 $ fmap unV1 b)
+mul_13_31vm :: V3 (S x Float) -> V3 (V1 (S x Float)) -> V1 (S x Float)
+mul_13_31vm a b = V1 $ fun2f "dot" (fromVec3 a) (fromVec3 $ fmap unV1 b)
+mul_14_41vm :: V4 (S x Float) -> V4 (V1 (S x Float)) -> V1 (S x Float)
+mul_14_41vm a b = V1 $ fun2f "dot" (fromVec4 a) (fromVec4 $ fmap unV1 b)
+
+{-# RULES "mul_12_21mv" (!*) = mul_12_21mv #-}
+{-# RULES "mul_13_31mv" (!*) = mul_13_31mv #-}
+{-# RULES "mul_14_41mv" (!*) = mul_14_41mv #-}
+mul_12_21mv :: V1 (V2 (S x Float)) -> V2 (S x Float) -> V1 (S x Float)
+mul_12_21mv a b = V1 $ fun2f "dot" (fromVec2 $ unV1 a) (fromVec2 b)
+mul_13_31mv :: V1 (V3 (S x Float)) -> V3 (S x Float) -> V1 (S x Float)
+mul_13_31mv a b = V1 $ fun2f "dot" (fromVec3 $ unV1 a) (fromVec3 b)
+mul_14_41mv :: V1 (V4 (S x Float)) -> V4 (S x Float) -> V1 (S x Float)
+mul_14_41mv a b = V1 $ fun2f "dot" (fromVec4 $ unV1 a) (fromVec4 b)
+
+{-# RULES "mul_12_21mm" (!*!) = mul_12_21mm #-}
+{-# RULES "mul_13_31mm" (!*!) = mul_13_31mm #-}
+{-# RULES "mul_14_41mm" (!*!) = mul_14_41mm #-}
+mul_12_21mm :: V1 (V2 (S x Float)) -> V2 (V1 (S x Float)) -> V1 (V1 (S x Float))
+mul_12_21mm a b = V1 $ V1 $ fun2f "dot" (fromVec2 $ unV1 a) (fromVec2 $ fmap unV1 b)
+mul_13_31mm :: V1 (V3 (S x Float)) -> V3 (V1 (S x Float)) -> V1 (V1 (S x Float))
+mul_13_31mm a b = V1 $ V1 $ fun2f "dot" (fromVec3 $ unV1 a) (fromVec3 $ fmap unV1 b)
+mul_14_41mm :: V1 (V4 (S x Float)) -> V4 (V1 (S x Float)) -> V1 (V1 (S x Float))
+mul_14_41mm a b = V1 $ V1 $ fun2f "dot" (fromVec4 $ unV1 a) (fromVec4 $ fmap unV1 b)
+
+
+{-# RULES "mul_21_12" outer = mul_21_12 #-}
+{-# RULES "mul_21_13" outer = mul_21_13 #-}
+{-# RULES "mul_21_14" outer = mul_21_14 #-}
+{-# RULES "mul_31_12" outer = mul_31_12 #-}
+{-# RULES "mul_31_13" outer = mul_31_13 #-}
+{-# RULES "mul_31_14" outer = mul_31_14 #-}
+{-# RULES "mul_41_12" outer = mul_41_12 #-}
+{-# RULES "mul_41_13" outer = mul_41_13 #-}
+{-# RULES "mul_41_14" outer = mul_41_14 #-}
+mul_21_12 :: V2 (S x Float) -> V2 (S x Float) -> V2 (V2 (S x Float))
+mul_21_12 a b = outerToM d2 d2 (fromVec2 b) (fromVec2 a)
+mul_21_13 :: V2 (S x Float) -> V3 (S x Float) -> V2 (V3 (S x Float))
+mul_21_13 a b = outerToM d2 d3 (fromVec3 b) (fromVec2 a)
+mul_21_14 :: V2 (S x Float) -> V4 (S x Float) -> V2 (V4 (S x Float))
+mul_21_14 a b = outerToM d2 d4 (fromVec4 b) (fromVec2 a)
+mul_31_12 :: V3 (S x Float) -> V2 (S x Float) -> V3 (V2 (S x Float))
+mul_31_12 a b = outerToM d3 d2 (fromVec2 b) (fromVec3 a)
+mul_31_13 :: V3 (S x Float) -> V3 (S x Float) -> V3 (V3 (S x Float))
+mul_31_13 a b = outerToM d3 d3 (fromVec3 b) (fromVec3 a)
+mul_31_14 :: V3 (S x Float) -> V4 (S x Float) -> V3 (V4 (S x Float))
+mul_31_14 a b = outerToM d3 d4 (fromVec4 b) (fromVec3 a)
+mul_41_12 :: V4 (S x Float) -> V2 (S x Float) -> V4 (V2 (S x Float))
+mul_41_12 a b = outerToM d4 d2 (fromVec2 b) (fromVec4 a)
+mul_41_13 :: V4 (S x Float) -> V3 (S x Float) -> V4 (V3 (S x Float))
+mul_41_13 a b = outerToM d4 d3 (fromVec3 b) (fromVec4 a)
+mul_41_14 :: V4 (S x Float) -> V4 (S x Float) -> V4 (V4 (S x Float))
+mul_41_14 a b = outerToM d4 d4 (fromVec4 b) (fromVec4 a)
+{-# RULES "mul_21_12m" (!*!) = mul_21_12m #-}
+{-# RULES "mul_21_13m" (!*!) = mul_21_13m #-}
+{-# RULES "mul_21_14m" (!*!) = mul_21_14m #-}
+{-# RULES "mul_31_12m" (!*!) = mul_31_12m #-}
+{-# RULES "mul_31_13m" (!*!) = mul_31_13m #-}
+{-# RULES "mul_31_14m" (!*!) = mul_31_14m #-}
+{-# RULES "mul_41_12m" (!*!) = mul_41_12m #-}
+{-# RULES "mul_41_13m" (!*!) = mul_41_13m #-}
+{-# RULES "mul_41_14m" (!*!) = mul_41_14m #-}
+mul_21_12m :: V2 (V1 (S x Float)) -> V1 (V2 (S x Float)) -> V2 (V2 (S x Float))
+mul_21_12m a b = outerToM d2 d2 (fromVec2 $ unV1 b) (fromVec2 $ fmap unV1 a)
+mul_21_13m :: V2 (V1 (S x Float)) -> V1 (V3 (S x Float)) -> V2 (V3 (S x Float))
+mul_21_13m a b = outerToM d2 d3 (fromVec3 $ unV1 b) (fromVec2 $ fmap unV1 a)
+mul_21_14m :: V2 (V1 (S x Float)) -> V1 (V4 (S x Float)) -> V2 (V4 (S x Float))
+mul_21_14m a b = outerToM d2 d4 (fromVec4 $ unV1 b) (fromVec2 $ fmap unV1 a)
+mul_31_12m :: V3 (V1 (S x Float)) -> V1 (V2 (S x Float)) -> V3 (V2 (S x Float))
+mul_31_12m a b = outerToM d3 d2 (fromVec2 $ unV1 b) (fromVec3 $ fmap unV1 a)
+mul_31_13m :: V3 (V1 (S x Float)) -> V1 (V3 (S x Float)) -> V3 (V3 (S x Float))
+mul_31_13m a b = outerToM d3 d3 (fromVec3 $ unV1 b) (fromVec3 $ fmap unV1 a)
+mul_31_14m :: V3 (V1 (S x Float)) -> V1 (V4 (S x Float)) -> V3 (V4 (S x Float))
+mul_31_14m a b = outerToM d3 d4 (fromVec4 $ unV1 b) (fromVec3 $ fmap unV1 a)
+mul_41_12m :: V4 (V1 (S x Float)) -> V1 (V2 (S x Float)) -> V4 (V2 (S x Float))
+mul_41_12m a b = outerToM d4 d2 (fromVec2 $ unV1 b) (fromVec4 $ fmap unV1 a)
+mul_41_13m :: V4 (V1 (S x Float)) -> V1 (V3 (S x Float)) -> V4 (V3 (S x Float))
+mul_41_13m a b = outerToM d4 d3 (fromVec3 $ unV1 b) (fromVec4 $ fmap unV1 a)
+mul_41_14m :: V4 (V1 (S x Float)) -> V1 (V4 (S x Float)) -> V4 (V4 (S x Float))
+mul_41_14m a b = outerToM d4 d4 (fromVec4 $ unV1 b) (fromVec4 $ fmap unV1 a)
+
+
+{-# RULES "mul_12_22" (*!) = mul_12_22 #-}
+{-# RULES "mul_13_32" (*!) = mul_13_32 #-}
+{-# RULES "mul_14_42" (*!) = mul_14_42 #-}
+{-# RULES "mul_12_23" (*!) = mul_12_23 #-}
+{-# RULES "mul_13_33" (*!) = mul_13_33 #-}
+{-# RULES "mul_14_43" (*!) = mul_14_43 #-}
+{-# RULES "mul_12_24" (*!) = mul_12_24 #-}
+{-# RULES "mul_13_34" (*!) = mul_13_34 #-}
+{-# RULES "mul_14_44" (*!) = mul_14_44 #-}
+mul_12_22 :: V2 (S x Float) -> V2 (V2 (S x Float)) -> V2 (S x Float)
+mul_12_22 v m = mulToV2 (fromMat22 m) (fromVec2 v)
+mul_13_32 :: V3 (S x Float) -> V3 (V2 (S x Float)) -> V2 (S x Float)
+mul_13_32 v m = mulToV2 (fromMat32 m) (fromVec3 v)
+mul_14_42 :: V4 (S x Float) -> V4 (V2 (S x Float)) -> V2 (S x Float)
+mul_14_42 v m = mulToV2 (fromMat42 m) (fromVec4 v)
+mul_12_23 :: V2 (S x Float) -> V2 (V3 (S x Float)) -> V3 (S x Float)
+mul_12_23 v m = mulToV3 (fromMat23 m) (fromVec2 v)
+mul_13_33 :: V3 (S x Float) -> V3 (V3 (S x Float)) -> V3 (S x Float)
+mul_13_33 v m = mulToV3 (fromMat33 m) (fromVec3 v)
+mul_14_43 :: V4 (S x Float) -> V4 (V3 (S x Float)) -> V3 (S x Float)
+mul_14_43 v m = mulToV3 (fromMat43 m) (fromVec4 v)
+mul_12_24 :: V2 (S x Float) -> V2 (V4 (S x Float)) -> V4 (S x Float)
+mul_12_24 v m = mulToV4 (fromMat24 m) (fromVec2 v)
+mul_13_34 :: V3 (S x Float) -> V3 (V4 (S x Float)) -> V4 (S x Float)
+mul_13_34 v m = mulToV4 (fromMat34 m) (fromVec3 v)
+mul_14_44 :: V4 (S x Float) -> V4 (V4 (S x Float)) -> V4 (S x Float)
+mul_14_44 v m = mulToV4 (fromMat44 m) (fromVec4 v)
+
+{-# RULES "mul_12_22m" (!*!) = mul_12_22m #-}
+{-# RULES "mul_13_32m" (!*!) = mul_13_32m #-}
+{-# RULES "mul_14_42m" (!*!) = mul_14_42m #-}
+{-# RULES "mul_12_23m" (!*!) = mul_12_23m #-}
+{-# RULES "mul_13_33m" (!*!) = mul_13_33m #-}
+{-# RULES "mul_14_43m" (!*!) = mul_14_43m #-}
+{-# RULES "mul_12_24m" (!*!) = mul_12_24m #-}
+{-# RULES "mul_13_34m" (!*!) = mul_13_34m #-}
+{-# RULES "mul_14_44m" (!*!) = mul_14_44m #-}
+mul_12_22m :: V1 (V2 (S x Float)) -> V2 (V2 (S x Float)) -> V1 (V2 (S x Float))
+mul_12_22m v m = V1 $ mulToV2 (fromMat22 m) (fromVec2 $ unV1 v)
+mul_13_32m :: V1 (V3 (S x Float)) -> V3 (V2 (S x Float)) -> V1 (V2 (S x Float))
+mul_13_32m v m = V1 $ mulToV2 (fromMat32 m) (fromVec3 $ unV1 v)
+mul_14_42m :: V1 (V4 (S x Float)) -> V4 (V2 (S x Float)) -> V1 (V2 (S x Float))
+mul_14_42m v m = V1 $ mulToV2 (fromMat42 m) (fromVec4 $ unV1 v)
+mul_12_23m :: V1 (V2 (S x Float)) -> V2 (V3 (S x Float)) -> V1 (V3 (S x Float))
+mul_12_23m v m = V1 $ mulToV3 (fromMat23 m) (fromVec2 $ unV1 v)
+mul_13_33m :: V1 (V3 (S x Float)) -> V3 (V3 (S x Float)) -> V1 (V3 (S x Float))
+mul_13_33m v m = V1 $ mulToV3 (fromMat33 m) (fromVec3 $ unV1 v)
+mul_14_43m :: V1 (V4 (S x Float)) -> V4 (V3 (S x Float)) -> V1 (V3 (S x Float))
+mul_14_43m v m = V1 $ mulToV3 (fromMat43 m) (fromVec4 $ unV1 v)
+mul_12_24m :: V1 (V2 (S x Float)) -> V2 (V4 (S x Float)) -> V1 (V4 (S x Float))
+mul_12_24m v m = V1 $ mulToV4 (fromMat24 m) (fromVec2 $ unV1 v)
+mul_13_34m :: V1 (V3 (S x Float)) -> V3 (V4 (S x Float)) -> V1 (V4 (S x Float))
+mul_13_34m v m = V1 $ mulToV4 (fromMat34 m) (fromVec3 $ unV1 v)
+mul_14_44m :: V1 (V4 (S x Float)) -> V4 (V4 (S x Float)) -> V1 (V4 (S x Float))
+mul_14_44m v m = V1 $ mulToV4 (fromMat44 m) (fromVec4 $ unV1 v)
+
+{-# RULES "mul_22_21" (!*) = mul_22_21 #-}
+{-# RULES "mul_23_31" (!*) = mul_23_31 #-}
+{-# RULES "mul_24_41" (!*) = mul_24_41 #-}
+{-# RULES "mul_32_21" (!*) = mul_32_21 #-}
+{-# RULES "mul_33_31" (!*) = mul_33_31 #-}
+{-# RULES "mul_34_41" (!*) = mul_34_41 #-}
+{-# RULES "mul_42_21" (!*) = mul_42_21 #-}
+{-# RULES "mul_43_31" (!*) = mul_43_31 #-}
+{-# RULES "mul_44_41" (!*) = mul_44_41 #-}
+mul_22_21 :: V2 (V2 (S x Float)) -> V2 (S x Float) -> V2 (S x Float)
+mul_22_21 m v = mulToV2 (fromVec2 v) (fromMat22 m) 
+mul_23_31 :: V2 (V3 (S x Float)) -> V3 (S x Float) -> V2 (S x Float)
+mul_23_31 m v = mulToV2 (fromVec3 v) (fromMat23 m) 
+mul_24_41 :: V2 (V4 (S x Float)) -> V4 (S x Float) -> V2 (S x Float)
+mul_24_41 m v = mulToV2 (fromVec4 v) (fromMat24 m) 
+mul_32_21 :: V3 (V2 (S x Float)) -> V2 (S x Float) -> V3 (S x Float)
+mul_32_21 m v = mulToV3 (fromVec2 v) (fromMat32 m) 
+mul_33_31 :: V3 (V3 (S x Float)) -> V3 (S x Float) -> V3 (S x Float)
+mul_33_31 m v = mulToV3 (fromVec3 v) (fromMat33 m) 
+mul_34_41 :: V3 (V4 (S x Float)) -> V4 (S x Float) -> V3 (S x Float)
+mul_34_41 m v = mulToV3 (fromVec4 v) (fromMat34 m) 
+mul_42_21 :: V4 (V2 (S x Float)) -> V2 (S x Float) -> V4 (S x Float)
+mul_42_21 m v = mulToV4 (fromVec2 v) (fromMat42 m) 
+mul_43_31 :: V4 (V3 (S x Float)) -> V3 (S x Float) -> V4 (S x Float)
+mul_43_31 m v = mulToV4 (fromVec3 v) (fromMat43 m) 
+mul_44_41 :: V4 (V4 (S x Float)) -> V4 (S x Float) -> V4 (S x Float)
+mul_44_41 m v = mulToV4 (fromVec4 v) (fromMat44 m) 
+
+{-# RULES "mul_22_21m" (!*!) = mul_22_21m #-}
+{-# RULES "mul_23_31m" (!*!) = mul_23_31m #-}
+{-# RULES "mul_24_41m" (!*!) = mul_24_41m #-}
+{-# RULES "mul_32_21m" (!*!) = mul_32_21m #-}
+{-# RULES "mul_33_31m" (!*!) = mul_33_31m #-}
+{-# RULES "mul_34_41m" (!*!) = mul_34_41m #-}
+{-# RULES "mul_42_21m" (!*!) = mul_42_21m #-}
+{-# RULES "mul_43_31m" (!*!) = mul_43_31m #-}
+{-# RULES "mul_44_41m" (!*!) = mul_44_41m #-}
+mul_22_21m :: V2 (V2 (S x Float)) -> V2 (V1 (S x Float)) -> V2 (V1 (S x Float))
+mul_22_21m m v = V1 <$> mulToV2 (fromVec2 $ fmap unV1 v) (fromMat22 m) 
+mul_23_31m :: V2 (V3 (S x Float)) -> V3 (V1 (S x Float)) -> V2 (V1 (S x Float))
+mul_23_31m m v = V1 <$> mulToV2 (fromVec3 $ fmap unV1 v) (fromMat23 m) 
+mul_24_41m :: V2 (V4 (S x Float)) -> V4 (V1 (S x Float)) -> V2 (V1 (S x Float))
+mul_24_41m m v = V1 <$> mulToV2 (fromVec4 $ fmap unV1 v) (fromMat24 m) 
+mul_32_21m :: V3 (V2 (S x Float)) -> V2 (V1 (S x Float)) -> V3 (V1 (S x Float))
+mul_32_21m m v = V1 <$> mulToV3 (fromVec2 $ fmap unV1 v) (fromMat32 m) 
+mul_33_31m :: V3 (V3 (S x Float)) -> V3 (V1 (S x Float)) -> V3 (V1 (S x Float))
+mul_33_31m m v = V1 <$> mulToV3 (fromVec3 $ fmap unV1 v) (fromMat33 m) 
+mul_34_41m :: V3 (V4 (S x Float)) -> V4 (V1 (S x Float)) -> V3 (V1 (S x Float))
+mul_34_41m m v = V1 <$> mulToV3 (fromVec4 $ fmap unV1 v) (fromMat34 m) 
+mul_42_21m :: V4 (V2 (S x Float)) -> V2 (V1 (S x Float)) -> V4 (V1 (S x Float))
+mul_42_21m m v = V1 <$> mulToV4 (fromVec2 $ fmap unV1 v) (fromMat42 m) 
+mul_43_31m :: V4 (V3 (S x Float)) -> V3 (V1 (S x Float)) -> V4 (V1 (S x Float))
+mul_43_31m m v = V1 <$> mulToV4 (fromVec3 $ fmap unV1 v) (fromMat43 m) 
+mul_44_41m :: V4 (V4 (S x Float)) -> V4 (V1 (S x Float)) -> V4 (V1 (S x Float))
+mul_44_41m m v = V1 <$> mulToV4 (fromVec4 $ fmap unV1 v) (fromMat44 m) 
+-----------------------
+
+{-# RULES "mul_22_22" (!*!) = mul_22_22 #-}
+{-# RULES "mul_23_32" (!*!) = mul_23_32 #-}
+{-# RULES "mul_24_42" (!*!) = mul_24_42 #-}
+{-# RULES "mul_22_23" (!*!) = mul_22_23 #-}
+{-# RULES "mul_23_33" (!*!) = mul_23_33 #-}
+{-# RULES "mul_24_43" (!*!) = mul_24_43 #-}
+{-# RULES "mul_22_24" (!*!) = mul_22_24 #-}
+{-# RULES "mul_23_34" (!*!) = mul_23_34 #-}
+{-# RULES "mul_24_44" (!*!) = mul_24_44 #-}
+mul_22_22 :: V2 (V2 (S x Float)) -> V2 (V2 (S x Float)) -> V2 (V2 (S x Float))
+mul_22_22 a b = mulToM d2 d2 (fromMat22 b) (fromMat22 a)
+mul_23_32 :: V2 (V3 (S x Float)) -> V3 (V2 (S x Float)) -> V2 (V2 (S x Float))
+mul_23_32 a b = mulToM d2 d2 (fromMat32 b) (fromMat23 a)
+mul_24_42 :: V2 (V4 (S x Float)) -> V4 (V2 (S x Float)) -> V2 (V2 (S x Float))
+mul_24_42 a b = mulToM d2 d2 (fromMat42 b) (fromMat24 a)
+mul_22_23 :: V2 (V2 (S x Float)) -> V2 (V3 (S x Float)) -> V2 (V3 (S x Float))
+mul_22_23 a b = mulToM d2 d3 (fromMat23 b) (fromMat22 a)
+mul_23_33 :: V2 (V3 (S x Float)) -> V3 (V3 (S x Float)) -> V2 (V3 (S x Float))
+mul_23_33 a b = mulToM d2 d3 (fromMat33 b) (fromMat23 a)
+mul_24_43 :: V2 (V4 (S x Float)) -> V4 (V3 (S x Float)) -> V2 (V3 (S x Float))
+mul_24_43 a b = mulToM d2 d3 (fromMat43 b) (fromMat24 a)
+mul_22_24 :: V2 (V2 (S x Float)) -> V2 (V4 (S x Float)) -> V2 (V4 (S x Float))
+mul_22_24 a b = mulToM d2 d4 (fromMat24 b) (fromMat22 a)
+mul_23_34 :: V2 (V3 (S x Float)) -> V3 (V4 (S x Float)) -> V2 (V4 (S x Float))
+mul_23_34 a b = mulToM d2 d4 (fromMat34 b) (fromMat23 a)
+mul_24_44 :: V2 (V4 (S x Float)) -> V4 (V4 (S x Float)) -> V2 (V4 (S x Float))
+mul_24_44 a b = mulToM d2 d4 (fromMat44 b) (fromMat24 a)
+
+
+{-# RULES "mul_32_22" (!*!) = mul_32_22 #-}
+{-# RULES "mul_33_32" (!*!) = mul_33_32 #-}
+{-# RULES "mul_34_42" (!*!) = mul_34_42 #-}
+{-# RULES "mul_32_23" (!*!) = mul_32_23 #-}
+{-# RULES "mul_33_33" (!*!) = mul_33_33 #-}
+{-# RULES "mul_34_43" (!*!) = mul_34_43 #-}
+{-# RULES "mul_32_24" (!*!) = mul_32_24 #-}
+{-# RULES "mul_33_34" (!*!) = mul_33_34 #-}
+{-# RULES "mul_34_44" (!*!) = mul_34_44 #-}
+mul_32_22 :: V3 (V2 (S x Float)) -> V2 (V2 (S x Float)) -> V3 (V2 (S x Float))
+mul_32_22 a b = mulToM d3 d2 (fromMat22 b) (fromMat32 a)
+mul_33_32 :: V3 (V3 (S x Float)) -> V3 (V2 (S x Float)) -> V3 (V2 (S x Float))
+mul_33_32 a b = mulToM d3 d2 (fromMat32 b) (fromMat33 a)
+mul_34_42 :: V3 (V4 (S x Float)) -> V4 (V2 (S x Float)) -> V3 (V2 (S x Float))
+mul_34_42 a b = mulToM d3 d2 (fromMat42 b) (fromMat34 a)
+mul_32_23 :: V3 (V2 (S x Float)) -> V2 (V3 (S x Float)) -> V3 (V3 (S x Float))
+mul_32_23 a b = mulToM d3 d3 (fromMat23 b) (fromMat32 a)
+mul_33_33 :: V3 (V3 (S x Float)) -> V3 (V3 (S x Float)) -> V3 (V3 (S x Float))
+mul_33_33 a b = mulToM d3 d3 (fromMat33 b) (fromMat33 a)
+mul_34_43 :: V3 (V4 (S x Float)) -> V4 (V3 (S x Float)) -> V3 (V3 (S x Float))
+mul_34_43 a b = mulToM d3 d3 (fromMat43 b) (fromMat34 a)
+mul_32_24 :: V3 (V2 (S x Float)) -> V2 (V4 (S x Float)) -> V3 (V4 (S x Float))
+mul_32_24 a b = mulToM d3 d4 (fromMat24 b) (fromMat32 a)
+mul_33_34 :: V3 (V3 (S x Float)) -> V3 (V4 (S x Float)) -> V3 (V4 (S x Float))
+mul_33_34 a b = mulToM d3 d4 (fromMat34 b) (fromMat33 a)
+mul_34_44 :: V3 (V4 (S x Float)) -> V4 (V4 (S x Float)) -> V3 (V4 (S x Float))
+mul_34_44 a b = mulToM d3 d4 (fromMat44 b) (fromMat34 a)
+
+
+{-# RULES "mul_42_22" (!*!) = mul_42_22 #-}
+{-# RULES "mul_43_32" (!*!) = mul_43_32 #-}
+{-# RULES "mul_44_42" (!*!) = mul_44_42 #-}
+{-# RULES "mul_42_23" (!*!) = mul_42_23 #-}
+{-# RULES "mul_43_33" (!*!) = mul_43_33 #-}
+{-# RULES "mul_44_43" (!*!) = mul_44_43 #-}
+{-# RULES "mul_42_24" (!*!) = mul_42_24 #-}
+{-# RULES "mul_43_34" (!*!) = mul_43_34 #-}
+{-# RULES "mul_44_44" (!*!) = mul_44_44 #-}
+mul_42_22 :: V4 (V2 (S x Float)) -> V2 (V2 (S x Float)) -> V4 (V2 (S x Float))
+mul_42_22 a b = mulToM d4 d2 (fromMat22 b) (fromMat42 a)
+mul_43_32 :: V4 (V3 (S x Float)) -> V3 (V2 (S x Float)) -> V4 (V2 (S x Float))
+mul_43_32 a b = mulToM d4 d2 (fromMat32 b) (fromMat43 a)
+mul_44_42 :: V4 (V4 (S x Float)) -> V4 (V2 (S x Float)) -> V4 (V2 (S x Float))
+mul_44_42 a b = mulToM d4 d2 (fromMat42 b) (fromMat44 a)
+mul_42_23 :: V4 (V2 (S x Float)) -> V2 (V3 (S x Float)) -> V4 (V3 (S x Float))
+mul_42_23 a b = mulToM d4 d3 (fromMat23 b) (fromMat42 a)
+mul_43_33 :: V4 (V3 (S x Float)) -> V3 (V3 (S x Float)) -> V4 (V3 (S x Float))
+mul_43_33 a b = mulToM d4 d3 (fromMat33 b) (fromMat43 a)
+mul_44_43 :: V4 (V4 (S x Float)) -> V4 (V3 (S x Float)) -> V4 (V3 (S x Float))
+mul_44_43 a b = mulToM d4 d3 (fromMat43 b) (fromMat44 a)
+mul_42_24 :: V4 (V2 (S x Float)) -> V2 (V4 (S x Float)) -> V4 (V4 (S x Float))
+mul_42_24 a b = mulToM d4 d4 (fromMat24 b) (fromMat42 a)
+mul_43_34 :: V4 (V3 (S x Float)) -> V3 (V4 (S x Float)) -> V4 (V4 (S x Float))
+mul_43_34 a b = mulToM d4 d4 (fromMat34 b) (fromMat43 a)
+mul_44_44 :: V4 (V4 (S x Float)) -> V4 (V4 (S x Float)) -> V4 (V4 (S x Float))
+mul_44_44 a b = mulToM d4 d4 (fromMat44 b) (fromMat44 a)

@@ -0,0 +1,523 @@+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeSynonymInstances, EmptyDataDecls #-}
+
+module Graphics.GPipe.Internal.Format where
+
+import Data.Word
+import Graphics.GL.Core33
+import Graphics.GL.Types
+import Foreign.Marshal.Array (withArray)
+import Linear.V4
+import Linear.V3
+import Linear.V2
+
+data RFloat 
+data RInt
+data RWord 
+data RGFloat 
+data RGInt 
+data RGWord 
+data RGBFloat 
+data RGBInt 
+data RGBWord 
+data RGBAFloat 
+data RGBAInt 
+data RGBAWord 
+data Depth 
+data Stencil 
+data DepthStencil 
+ 
+data Format a where
+    R8 :: Format RFloat 
+    R8S :: Format RFloat
+    R16 :: Format RFloat
+    R16S :: Format RFloat
+    R16F :: Format RFloat
+    R32F :: Format RFloat
+    R8I :: Format RInt
+    R16I :: Format RInt
+    R32I :: Format RInt
+    R8UI :: Format RWord
+    R16UI :: Format RWord
+    R32UI :: Format RWord
+    RG8 :: Format RGFloat
+    RG8S :: Format RGFloat 
+    RG16 :: Format RGFloat 
+    RG16S :: Format RGFloat 
+    RG16F :: Format RGFloat 
+    RG32F :: Format RGFloat 
+    RG8I :: Format RGInt
+    RG16I :: Format RGInt
+    RG32I :: Format RGInt
+    RG8UI :: Format RGWord
+    RG16UI :: Format RGWord
+    RG32UI :: Format RGWord
+    R3G3B2 :: Format RGBFloat
+    RGB4 :: Format RGBFloat
+    RGB5 :: Format RGBFloat
+    RGB8 :: Format RGBFloat
+    RGB8S :: Format RGBFloat
+    RGB10 :: Format RGBFloat
+    RGB12 :: Format RGBFloat
+    RGB16 :: Format RGBFloat
+    RGB16S :: Format RGBFloat
+    RGB16F :: Format RGBFloat
+    RGB32F :: Format RGBFloat
+    R11FG11FB10F :: Format RGBFloat
+    RGB9E5 :: Format RGBFloat
+    SRGB8 :: Format RGBFloat
+    RGB8I :: Format RGBInt
+    RGB16I :: Format RGBInt
+    RGB32I :: Format RGBInt
+    RGBWord :: Format RGBWord
+    RGB8UI :: Format RGBWord
+    RGB16UI :: Format RGBWord
+    RGB32UI :: Format RGBWord
+    RGBA2 :: Format RGBAFloat
+    RGBA4 :: Format RGBAFloat
+    RGB5A1 :: Format RGBAFloat
+    RGBA8 :: Format RGBAFloat
+    RGBA8S :: Format RGBAFloat
+    RGB10A2 :: Format RGBAFloat
+    RGBA12 :: Format RGBAFloat
+    RGBA16 :: Format RGBAFloat
+    RGBA16S :: Format RGBAFloat
+    RGBA16F :: Format RGBAFloat
+    RGBA32F :: Format RGBAFloat
+    SRGB8A8 :: Format RGBAFloat
+    RGBA8I :: Format RGBAInt
+    RGBA16I :: Format RGBAInt
+    RGBA32I :: Format RGBAInt
+    RGBA8UI :: Format RGBAWord
+    RGBA16UI :: Format RGBAWord
+    RGBA32UI :: Format RGBAWord
+
+    Depth16 :: Format Depth
+    Depth24 :: Format Depth
+    Depth32 :: Format Depth
+    Depth32F :: Format Depth
+    Stencil1 :: Format Stencil
+    Stencil4 :: Format Stencil
+    Stencil8 :: Format Stencil
+    Stencil16 :: Format Stencil
+    Depth24Stencil8  :: Format DepthStencil
+    Depth32FStencil8 :: Format DepthStencil
+
+getGlInternalFormat :: Format f -> GLenum
+getGlInternalFormat R8 = GL_R8 
+getGlInternalFormat R8S = GL_R8_SNORM
+getGlInternalFormat R16 = GL_R16
+getGlInternalFormat R16S = GL_R16_SNORM
+getGlInternalFormat R16F = GL_R16F
+getGlInternalFormat R32F = GL_R32F
+getGlInternalFormat R8I = GL_R8I 
+getGlInternalFormat R16I = GL_R16I
+getGlInternalFormat R32I = GL_R32I
+getGlInternalFormat R8UI = GL_R8UI 
+getGlInternalFormat R16UI = GL_R16UI
+getGlInternalFormat R32UI = GL_R32UI
+getGlInternalFormat RG8 = GL_RG8 
+getGlInternalFormat RG8S = GL_RG8_SNORM
+getGlInternalFormat RG16 = GL_RG16
+getGlInternalFormat RG16S = GL_RG16_SNORM
+getGlInternalFormat RG16F = GL_RG16F
+getGlInternalFormat RG32F = GL_RG32F
+getGlInternalFormat RG8I = GL_RG8I 
+getGlInternalFormat RG16I = GL_RG16I
+getGlInternalFormat RG32I = GL_RG32I
+getGlInternalFormat RG8UI = GL_RG8UI
+getGlInternalFormat RG16UI = GL_RG16UI    
+getGlInternalFormat RG32UI = GL_RG32UI
+getGlInternalFormat R3G3B2 = GL_R3_G3_B2
+getGlInternalFormat RGB4 = GL_RGB4
+getGlInternalFormat RGB5 = GL_RGB5
+getGlInternalFormat RGB8 = GL_RGB8
+getGlInternalFormat RGB8S = GL_RGB8_SNORM
+getGlInternalFormat RGB10 = GL_RGB10
+getGlInternalFormat RGB12 = GL_RGB12
+getGlInternalFormat RGB16 = GL_RGB16
+getGlInternalFormat RGB16S = GL_RGB16_SNORM
+getGlInternalFormat RGB16F = GL_RGB16F
+getGlInternalFormat RGB32F = GL_RGB32F
+getGlInternalFormat R11FG11FB10F = GL_R11F_G11F_B10F
+getGlInternalFormat RGB9E5 = GL_RGB9_E5
+getGlInternalFormat SRGB8 = GL_SRGB8
+getGlInternalFormat RGB8I = GL_RGB8I
+getGlInternalFormat RGB16I = GL_RGB16I
+getGlInternalFormat RGB32I = GL_RGB32I
+getGlInternalFormat RGB8UI = GL_RGB8UI
+getGlInternalFormat RGB16UI = GL_RGB16UI
+getGlInternalFormat RGB32UI = GL_RGB32UI
+getGlInternalFormat RGBA2 = GL_RGBA2 
+getGlInternalFormat RGBA4 = GL_RGBA4 
+getGlInternalFormat RGB5A1 = GL_RGB5_A1 
+getGlInternalFormat RGBA8 = GL_RGBA8 
+getGlInternalFormat RGBA8S = GL_RGBA8_SNORM 
+getGlInternalFormat RGB10A2 = GL_RGB10_A2 
+getGlInternalFormat RGBA12 = GL_RGBA12 
+getGlInternalFormat RGBA16 = GL_RGBA16 
+getGlInternalFormat RGBA16S = GL_RGBA16_SNORM 
+getGlInternalFormat RGBA16F = GL_RGBA16F 
+getGlInternalFormat RGBA32F = GL_RGBA32F 
+getGlInternalFormat SRGB8A8 = GL_SRGB8_ALPHA8 
+getGlInternalFormat RGBA8I = GL_RGBA8I 
+getGlInternalFormat RGBA16I = GL_RGBA16I 
+getGlInternalFormat RGBA32I = GL_RGBA32I
+getGlInternalFormat RGBA8UI = GL_RGBA8UI 
+getGlInternalFormat RGBA16UI = GL_RGBA16UI 
+getGlInternalFormat RGBA32UI = GL_RGBA32UI
+getGlInternalFormat Depth16 = GL_DEPTH_COMPONENT16
+getGlInternalFormat Depth24 = GL_DEPTH_COMPONENT24
+getGlInternalFormat Depth32 = GL_DEPTH_COMPONENT32
+getGlInternalFormat Depth32F = GL_DEPTH_COMPONENT32F
+getGlInternalFormat Stencil1 = GL_STENCIL_INDEX1
+getGlInternalFormat Stencil4 = GL_STENCIL_INDEX4
+getGlInternalFormat Stencil8 = GL_STENCIL_INDEX8
+getGlInternalFormat Stencil16 = GL_STENCIL_INDEX16
+getGlInternalFormat Depth24Stencil8 = GL_DEPTH24_STENCIL8
+getGlInternalFormat Depth32FStencil8 = GL_DEPTH32F_STENCIL8
+
+class TextureFormat f where
+    getGlFormat  :: f -> GLenum
+    getGlFormat = error "You cannot create your own instances of TextureFormat"
+
+instance TextureFormat RFloat where
+    getGlFormat _ = GL_RED
+instance TextureFormat RInt where
+    getGlFormat _ = GL_RED_INTEGER
+instance TextureFormat RWord where
+    getGlFormat _ = GL_RED_INTEGER
+
+instance TextureFormat RGFloat where
+    getGlFormat _ = GL_RG
+instance TextureFormat RGInt where
+    getGlFormat _ = GL_RG_INTEGER
+instance TextureFormat RGWord where
+    getGlFormat _ = GL_RG_INTEGER
+
+instance TextureFormat RGBFloat where
+    getGlFormat _ = GL_RGB
+instance TextureFormat RGBInt where
+    getGlFormat _ = GL_RGB_INTEGER
+instance TextureFormat RGBWord where
+    getGlFormat _ = GL_RGB_INTEGER
+
+instance TextureFormat RGBAFloat where
+    getGlFormat _ = GL_RGBA
+instance TextureFormat RGBAInt where
+    getGlFormat _ = GL_RGBA_INTEGER
+instance TextureFormat RGBAWord where
+    getGlFormat _ = GL_RGBA_INTEGER
+
+instance TextureFormat Depth where
+    getGlFormat _ = GL_DEPTH_COMPONENT
+instance TextureFormat Stencil where
+    getGlFormat _ = GL_STENCIL_INDEX
+instance TextureFormat DepthStencil where
+    getGlFormat _ = GL_DEPTH_STENCIL
+
+class TextureFormat f => ColorSampleable f where
+    type Color f a
+    type ColorElement f :: *
+    typeStr :: f -> String
+    typeStr4 :: f -> String
+    toColor :: f -> V4 x -> Color f x
+    fromColor :: f -> Color f x -> [x]
+    setBorderColor :: f -> GLenum -> Color f (ColorElement f) -> IO ()
+    samplerPrefix :: f -> String
+    typeStr = error "You cannot create your own instances of ColorSampleable"
+    typeStr4 = error "You cannot create your own instances of ColorSampleable"
+    toColor = error "You cannot create your own instances of ColorSampleable"
+    fromColor = error "You cannot create your own instances of ColorSampleable"
+    setBorderColor = error "You cannot create your own instances of ColorSampleable"
+    samplerPrefix _ = ""
+
+instance ColorSampleable RFloat where
+    type Color RFloat a = a
+    type ColorElement RFloat = Float
+    typeStr _ = "float"
+    typeStr4 _ = "vec4"
+    toColor _ (V4 r _ _ _) = r
+    fromColor _ r = [r]
+    setBorderColor _ t r = withArray [realToFrac r, 0,0,0] (glTexParameterfv t GL_TEXTURE_BORDER_COLOR)      
+instance ColorSampleable RInt where
+    type Color RInt a = a
+    type ColorElement RInt = Int
+    typeStr _ = "int"
+    typeStr4 _ = "ivec4"
+    toColor _ (V4 r _ _ _) = r
+    fromColor _ r = [r]
+    setBorderColor _ t r = withArray [fromIntegral r, 0,0,0] (glTexParameterIiv t GL_TEXTURE_BORDER_COLOR)
+    samplerPrefix _ = "i"
+instance ColorSampleable RWord where
+    type Color RWord a = a
+    type ColorElement RWord = Word
+    typeStr _ = "uint"
+    typeStr4 _ = "uvec4"
+    toColor _ (V4 r _ _ _) = r
+    fromColor _ r = [r]
+    setBorderColor _ t r = withArray [fromIntegral r, 0,0,0] (glTexParameterIuiv t GL_TEXTURE_BORDER_COLOR)
+    samplerPrefix _ = "u"
+
+instance ColorSampleable RGFloat where
+    type Color RGFloat a = V2 a
+    type ColorElement RGFloat = Float
+    typeStr _ = "vec2"
+    typeStr4 _ = "vec4"
+    toColor _ (V4 r g _ _) = V2 r g
+    fromColor _ (V2 r g) = [r,g]
+    setBorderColor _ t (V2 r g) = withArray [realToFrac r, realToFrac g,0,0] (glTexParameterfv t GL_TEXTURE_BORDER_COLOR)
+instance ColorSampleable RGInt where
+    type Color RGInt a = V2 a
+    type ColorElement RGInt = Int
+    typeStr _ = "ivec2"
+    typeStr4 _ = "ivec4"
+    toColor _ (V4 r g _ _) = V2 r g
+    fromColor _ (V2 r g) = [r,g]
+    setBorderColor _ t (V2 r g) = withArray [fromIntegral r, fromIntegral g,0,0] (glTexParameterIiv t GL_TEXTURE_BORDER_COLOR)
+    samplerPrefix _ = "i"
+instance ColorSampleable RGWord where
+    type Color RGWord a = V2 a
+    type ColorElement RGWord = Word
+    typeStr _ = "uvec2"
+    typeStr4 _ = "uvec4"
+    toColor _ (V4 r g _ _) = V2 r g
+    fromColor _ (V2 r g) = [r,g]
+    setBorderColor _ t (V2 r g) = withArray [fromIntegral r, fromIntegral g,0,0] (glTexParameterIuiv t GL_TEXTURE_BORDER_COLOR)
+    samplerPrefix _ = "u"
+    
+instance ColorSampleable RGBFloat where
+    type Color RGBFloat a = V3 a
+    type ColorElement RGBFloat = Float
+    typeStr _ = "vec3"
+    typeStr4 _ = "vec4"
+    toColor _ (V4 r g b _) = V3 r g b
+    fromColor _ (V3 r g b) = [r,g,b]
+    setBorderColor _ t (V3 r g b) = withArray [realToFrac r, realToFrac g, realToFrac b,0] (glTexParameterfv t GL_TEXTURE_BORDER_COLOR)
+instance ColorSampleable RGBInt where
+    type Color RGBInt a = V3 a
+    type ColorElement RGBInt = Int
+    typeStr _ = "ivec3"
+    typeStr4 _ = "ivec4"
+    toColor _ (V4 r g b _) = V3 r g b
+    fromColor _ (V3 r g b) = [r,g,b]
+    setBorderColor _ t (V3 r g b) = withArray [fromIntegral r, fromIntegral g, fromIntegral b,0] (glTexParameterIiv t GL_TEXTURE_BORDER_COLOR)
+    samplerPrefix _ = "i"
+instance ColorSampleable RGBWord where
+    type Color RGBWord a = V3 a
+    type ColorElement RGBWord = Word
+    typeStr _ = "uvec3"
+    typeStr4 _ = "uvec4"
+    toColor _ (V4 r g b _) = V3 r g b
+    fromColor _ (V3 r g b) = [r,g,b]
+    setBorderColor _ t (V3 r g b) = withArray [fromIntegral r, fromIntegral g, fromIntegral b,0] (glTexParameterIuiv t GL_TEXTURE_BORDER_COLOR)
+    samplerPrefix _ = "u"
+
+instance ColorSampleable RGBAFloat where
+    type Color RGBAFloat a = V4 a
+    type ColorElement RGBAFloat = Float
+    typeStr _ = "vec4"
+    typeStr4 _ = "vec4"
+    toColor _ = id
+    fromColor _ (V4 r g b a) = [r,g,b,a]
+    setBorderColor _ t (V4 r g b a) = withArray [realToFrac r, realToFrac g, realToFrac b, realToFrac a] (glTexParameterfv t GL_TEXTURE_BORDER_COLOR)
+instance ColorSampleable RGBAInt where
+    type Color RGBAInt a = V4 a
+    type ColorElement RGBAInt = Int
+    typeStr _ = "ivec4"
+    typeStr4 _ = "ivec4"
+    toColor _ = id
+    fromColor _ (V4 r g b a) = [r,g,b,a]
+    setBorderColor _ t (V4 r g b a) = withArray [fromIntegral r, fromIntegral g, fromIntegral b, fromIntegral a] (glTexParameterIiv t GL_TEXTURE_BORDER_COLOR)
+    samplerPrefix _ = "i"
+instance ColorSampleable RGBAWord where
+    type Color RGBAWord a = V4 a
+    type ColorElement RGBAWord = Word
+    typeStr _ = "uvec4"
+    typeStr4 _ = "uvec4"
+    toColor _ = id
+    fromColor _ (V4 r g b a) = [r,g,b,a]
+    setBorderColor _ t (V4 r g b a) = withArray [fromIntegral r, fromIntegral g, fromIntegral b, fromIntegral a] (glTexParameterIuiv t GL_TEXTURE_BORDER_COLOR)
+    samplerPrefix _ = "u"
+
+instance ColorSampleable Depth where
+    type Color Depth a = a
+    type ColorElement Depth = Float
+    typeStr _ = "float"
+    typeStr4 _ = "vec4"
+    toColor _ (V4 r _ _ _) = r
+    fromColor _ r = [r]
+    setBorderColor _ t r = withArray [realToFrac r, 0,0,0] (glTexParameterfv t GL_TEXTURE_BORDER_COLOR)      
+instance ColorSampleable DepthStencil where
+    type Color DepthStencil a = a
+    type ColorElement DepthStencil = Float
+    typeStr _ = "float"
+    typeStr4 _ = "vec4"
+    toColor _ (V4 r _ _ _) = r
+    fromColor _ r = [r]
+    setBorderColor _ t r = withArray [realToFrac r, 0,0,0] (glTexParameterfv t GL_TEXTURE_BORDER_COLOR)      
+
+class ColorSampleable c => ColorRenderable c where
+    isSrgb :: Format c -> Bool
+    isSrgb _ = False
+    clearColor :: c -> Color c (ColorElement c) -> IO ()
+    clearColor = error "You cannot create your own instances of ColorRenderable"
+class ColorSampleable f => DepthRenderable f
+class TextureFormat f => StencilRenderable f
+
+instance ColorRenderable RFloat where
+    clearColor _ r = withArray [realToFrac r, 0,0,0] (glClearBufferfv GL_COLOR 0)
+instance ColorRenderable RInt where
+    clearColor _ r = withArray [fromIntegral r, 0,0,0] (glClearBufferiv GL_COLOR 0)
+instance ColorRenderable RWord where
+    clearColor _ r = withArray [fromIntegral r, 0,0,0] (glClearBufferuiv GL_COLOR 0)
+instance ColorRenderable RGFloat where
+    clearColor _ (V2 r g) = withArray [realToFrac r, realToFrac g,0,0] (glClearBufferfv GL_COLOR 0)
+instance ColorRenderable RGInt where
+    clearColor _ (V2 r g) = withArray [fromIntegral r, fromIntegral g,0,0] (glClearBufferiv GL_COLOR 0)
+instance ColorRenderable RGWord where
+    clearColor _ (V2 r g) = withArray [fromIntegral r, fromIntegral g,0,0] (glClearBufferuiv GL_COLOR 0)
+instance ColorRenderable RGBFloat where
+    isSrgb SRGB8 = True
+    isSrgb _ = False
+    clearColor _ (V3 r g b) = withArray [realToFrac r, realToFrac g, realToFrac b,0] (glClearBufferfv GL_COLOR 0)
+instance ColorRenderable RGBInt where
+    clearColor _ (V3 r g b) = withArray [fromIntegral r, fromIntegral g, fromIntegral b,0] (glClearBufferiv GL_COLOR 0)
+instance ColorRenderable RGBWord where
+    clearColor _ (V3 r g b) = withArray [fromIntegral r, fromIntegral g, fromIntegral b,0] (glClearBufferuiv GL_COLOR 0)
+instance ColorRenderable RGBAFloat where
+    isSrgb SRGB8A8 = True
+    isSrgb _ = False
+    clearColor _ (V4 r g b a) = withArray [realToFrac r, realToFrac g, realToFrac b, realToFrac a] (glClearBufferfv GL_COLOR 0)
+instance ColorRenderable RGBAInt where
+    clearColor _ (V4 r g b a) = withArray [fromIntegral r, fromIntegral g, fromIntegral b, fromIntegral a] (glClearBufferiv GL_COLOR 0)
+instance ColorRenderable RGBAWord where
+    clearColor _ (V4 r g b a) = withArray [fromIntegral r, fromIntegral g, fromIntegral b, fromIntegral a] (glClearBufferuiv GL_COLOR 0)
+
+instance DepthRenderable Depth
+instance DepthRenderable DepthStencil
+
+instance StencilRenderable Stencil
+instance StencilRenderable DepthStencil
+
+
+class ColorRenderable c => ContextColorFormat c where
+    redBits :: Format c -> Int
+    greenBits :: Format c -> Int
+    blueBits :: Format c -> Int
+    alphaBits :: Format c -> Int
+    redBits = error "You cannot create your own instances of ContextColorFormat"
+    greenBits = error "You cannot create your own instances of ContextColorFormat"
+    blueBits = error "You cannot create your own instances of ContextColorFormat"
+    alphaBits = error "You cannot create your own instances of ContextColorFormat"
+
+instance ContextColorFormat RFloat where
+    redBits R8 = 8
+    redBits R8S = 8
+    redBits R16 = 16
+    redBits R16S = 16
+    redBits R16F = 16
+    redBits R32F = 32
+    greenBits _ = 0
+    blueBits _ = 0
+    alphaBits _ = 0
+
+instance ContextColorFormat RGFloat where
+    redBits RG8 = 8
+    redBits RG8S = 8
+    redBits RG16 = 16
+    redBits RG16S = 16
+    redBits RG16F = 16
+    redBits RG32F = 32
+    greenBits = redBits
+    blueBits _ = 0
+    alphaBits _ = 0
+
+instance ContextColorFormat RGBFloat where
+    redBits R3G3B2 = 3
+    redBits RGB4 = 4
+    redBits RGB5 = 5
+    redBits RGB8 = 8
+    redBits RGB8S = 8
+    redBits RGB10 = 10
+    redBits RGB12 = 12
+    redBits RGB16 = 16
+    redBits RGB16S = 16
+    redBits RGB16F = 16
+    redBits RGB32F = 32
+    redBits R11FG11FB10F = 11
+    redBits RGB9E5 = 14 -- hmm...
+    redBits SRGB8 = 8
+    greenBits = redBits
+    blueBits R3G3B2 = 2
+    blueBits R11FG11FB10F = 10
+    blueBits x = redBits x
+    alphaBits _ = 0
+
+instance ContextColorFormat RGBAFloat where
+    redBits RGBA2 = 2
+    redBits RGBA4 = 4
+    redBits RGB5A1 = 5
+    redBits RGBA8 = 8
+    redBits RGBA8S = 8
+    redBits RGB10A2 = 10
+    redBits RGBA12 = 12
+    redBits RGBA16 = 16
+    redBits RGBA16S = 16
+    redBits RGBA16F = 16
+    redBits RGBA32F = 32
+    redBits SRGB8A8 = 8   
+    greenBits = redBits
+    blueBits = redBits
+    alphaBits RGB5A1 = 1
+    alphaBits RGB10A2 = 2
+    alphaBits x = redBits x
+    
+--------------------------------------------------------------------------
+
+colorBits :: ContextColorFormat c => Format c -> (Int, Int, Int, Int, Bool)
+colorBits f = (redBits f, greenBits f, blueBits f, alphaBits f, isSrgb f)
+
+depthBits :: Format Depth  -> Int
+depthBits Depth16 = 16
+depthBits Depth24 = 24
+depthBits Depth32 = 32
+depthBits Depth32F = 32
+
+stencilBits :: Format Stencil -> Int
+stencilBits Stencil1 = 1
+stencilBits Stencil4 = 4
+stencilBits Stencil8 = 8
+stencilBits Stencil16 = 16
+
+depthStencilBits :: Format DepthStencil -> (Int, Int)
+depthStencilBits Depth32FStencil8 = (32, 8)
+depthStencilBits Depth24Stencil8 = (24, 8)
+
+data ContextFormat c ds where
+    ContextFormatNone :: ContextFormat () ()
+    ContextFormatColor :: ContextColorFormat c => Format c -> ContextFormat c ()
+    ContextFormatColorDepth :: ContextColorFormat c => Format c -> Format Depth -> ContextFormat c Depth
+    ContextFormatColorStencil :: ContextColorFormat c => Format c -> Format Stencil -> ContextFormat c Stencil
+    ContextFormatColorDepthStencilSeparate :: ContextColorFormat c => Format c -> Format Depth -> Format Stencil -> ContextFormat c DepthStencil
+    ContextFormatColorDepthStencilCombined :: ContextColorFormat c => Format c -> Format DepthStencil -> ContextFormat c DepthStencil
+    ContextFormatDepth :: Format Depth -> ContextFormat () Depth
+    ContextFormatStencil :: Format Stencil -> ContextFormat () Stencil
+    ContextFormatDepthStencilSeparate :: Format Depth -> Format Stencil -> ContextFormat () DepthStencil
+    ContextFormatDepthStencilCombined :: Format DepthStencil -> ContextFormat () DepthStencil
+
+contextBits :: ContextFormat c ds -> ((Int,Int,Int,Int,Bool),Int,Int)
+contextBits ContextFormatNone = ((0,0,0,0, False),0,0)
+contextBits (ContextFormatColor c) = (colorBits c, 0, 0)
+contextBits (ContextFormatColorDepth c d) = (colorBits c, depthBits d, 0)
+contextBits (ContextFormatColorStencil c s) = (colorBits c, 0, stencilBits s)
+contextBits (ContextFormatColorDepthStencilSeparate c d s) = (colorBits c, depthBits d, stencilBits s)
+contextBits (ContextFormatColorDepthStencilCombined c ds) = let (d,s) = depthStencilBits ds in (colorBits c, d, s)
+contextBits (ContextFormatDepth d) = ((0,0,0,0, False), depthBits d, 0)
+contextBits (ContextFormatStencil s) = ((0,0,0,0, False), 0, stencilBits s)
+contextBits (ContextFormatDepthStencilSeparate d s) = ((0,0,0,0, False), depthBits d, stencilBits s)
+contextBits (ContextFormatDepthStencilCombined ds) = let (d,s) = depthStencilBits ds in ((0,0,0,0, False), d, s)

@@ -0,0 +1,196 @@+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, Arrows  #-}
+module Graphics.GPipe.Internal.FragmentStream where
+
+import Control.Category hiding ((.))
+import Control.Arrow 
+import Graphics.GPipe.Internal.Expr
+import Graphics.GPipe.Internal.Shader
+import Graphics.GPipe.Internal.Compiler
+import Graphics.GPipe.Internal.PrimitiveStream
+import Graphics.GPipe.Internal.PrimitiveArray
+import Control.Monad.Trans.State.Lazy
+import Data.Monoid (Monoid)
+import Data.Boolean
+import Data.IntMap.Lazy (insert)
+import Linear.V4
+import Linear.V3
+import Linear.V2
+import Linear.V1
+import Linear.V0
+
+import Graphics.GL.Core33
+
+type VPos = V4 VFloat
+
+type ExprPos = ExprM ()
+type RasterizationName = Int
+data FragmentStreamData = FragmentStreamData RasterizationName ExprPos PrimitiveStreamData FBool
+
+-- | A @'FragmentStream' a @ is a stream of fragments of type @a@. You may append 'FragmentStream's using the 'Monoid' instance, and you
+--   can operate a stream's values using the 'Functor' instance (this will result in a shader running on the GPU).    
+newtype FragmentStream a = FragmentStream [(a, FragmentStreamData)] deriving Monoid
+
+instance Functor FragmentStream where
+        fmap f (FragmentStream xs) = FragmentStream $ map (first f) xs
+ 
+-- | The arrow type for 'toFragment'.
+newtype ToFragment a b = ToFragment (Kleisli (State Int) a b) deriving (Category, Arrow)
+
+-- | This class constraints which vertex types can be turned into fragment values, and what type those values have.  
+class FragmentInput a where
+    -- | The type the vertex value will be turned into once it becomes a fragment value.
+    type FragmentFormat a
+    -- | An arrow action that turns a value from it's vertex representation to it's fragment representation. Use 'toFragment' from
+    --   the GPipe provided instances to operate in this arrow. Also note that this arrow needs to be able to return a value
+    --   lazily, so ensure you use
+    -- 
+    --  @proc ~pattern -> do ...@. 
+    toFragment :: ToFragment a (FragmentFormat a)  
+
+-- | Rasterize a stream of primitives into fragments, using a 'Side', 'Viewport' and 'DepthRange' from the shader environment.
+--   Primitives will be transformed from canonical view space, i.e. [(-1,-1,-1),(1,1,1)], to the 2D space defined by the 'ViewPort' parameter and the depth range
+--   defined by the 'DepthRange' parameter.
+rasterize:: forall p a s os f. FragmentInput a
+          => (s -> (Side, ViewPort, DepthRange))
+          -> PrimitiveStream p (VPos, a)
+          -> Shader os f s (FragmentStream (FragmentFormat a)) 
+rasterize sf (PrimitiveStream xs) = Shader $ do
+        n <- getName
+        modifyRenderIO (\s -> s { rasterizationNameToRenderIO = insert n io (rasterizationNameToRenderIO s) } )
+        return (FragmentStream $ map (f n) xs) 
+    where        
+        ToFragment (Kleisli m) = toFragment :: ToFragment a (FragmentFormat a)
+        f n ((p, x),s) = (evalState (m x) 0, FragmentStreamData n (makePos p) s true)
+        makePos (V4 (S x) (S y) (S z) (S w)) = do
+                                       x' <- x
+                                       y' <- y
+                                       z' <- z
+                                       w' <- w
+                                       tellAssignment' "gl_Position" $ "vec4("++x'++',':y'++',':z'++',':w'++")"
+        io s = let (side, ViewPort (V2 x y) (V2 w h), DepthRange dmin dmax) = sf s in if w < 0 || h < 0 
+                                                                                        then error "ViewPort, negative size"
+                                                                                        else do setGlCullFace side
+                                                                                                glScissor (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
+                                                                                                glViewport (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) 
+                                                                                                glDepthRange (realToFrac dmin) (realToFrac dmax)
+
+        setGlCullFace Front = glEnable GL_CULL_FACE >> glCullFace GL_BACK -- Back is culled when front is rasterized
+        setGlCullFace Back = glEnable GL_CULL_FACE >> glCullFace GL_FRONT
+        setGlCullFace _ = glDisable GL_CULL_FACE
+
+-- | Defines which side to rasterize. Non triangle primitives only has a front side.
+data Side = Front | Back | FrontAndBack
+-- | The viewport in pixel coordinates (where (0,0) is the lower left corner) in to which the canonical view volume [(-1,-1,-1),(1,1,1)] is transformed and clipped/scissored.
+data ViewPort = ViewPort { viewPortLowerLeft :: V2 Int, viewPortSize :: V2 Int }
+-- | The fragment depth range to map the canonical view volume's z-coordinate to. Depth values are clamped to [0,1], so @DepthRange 0 1@ gives maximum depth resolution. 
+data DepthRange = DepthRange { minDepth :: Float, maxDepth :: Float }
+ 
+-- | Filter out fragments from the stream where the predicate in the first argument evaluates to 'true', and discard all other fragments.
+filterFragments :: (a -> FBool) -> FragmentStream a -> FragmentStream a 
+filterFragments f (FragmentStream xs) = FragmentStream $ map g xs
+    where g (a,FragmentStreamData x y z w) = (a,FragmentStreamData x y z (w &&* f a))  
+
+data RasterizedInfo = RasterizedInfo {
+        rasterizedFragCoord :: V4 FFloat,
+        rasterizedFrontFacing :: FBool,
+        rasterizedPointCoord :: V2 FFloat
+    }       
+
+-- | Like 'fmap', but where various auto generated information from the rasterization is provided for each vertex. 
+withRasterizedInfo :: (a -> RasterizedInfo -> b) -> FragmentStream a -> FragmentStream b
+withRasterizedInfo f = fmap (\a -> f a (RasterizedInfo (vec4S' "gl_FragCoord") (scalarS' "gl_FrontFacing") (vec2S' "gl_PointCoord")))
+
+-- | A float value that is not interpolated (like integers), and all fragments will instead get the value of the primitive's last vertex 
+data FlatVFloat = Flat VFloat
+-- | A float value that doesn't get divided by the interpolated position's w-component during interpolation. 
+data NoPerspectiveVFloat = NoPerspective VFloat
+
+makeFragment :: String -> SType -> (a -> ExprM String) -> ToFragment a (S c a1)
+makeFragment qual styp f = ToFragment $ Kleisli $ \ x -> do n <- get
+                                                            put (n+1)
+                                                            return $ S $ useFInput qual "vf" styp n $ f x
+unFlat :: FlatVFloat -> VFloat
+unFlat (Flat s) = s
+unNPersp :: NoPerspectiveVFloat -> VFloat
+unNPersp (NoPerspective s) = s
+
+instance FragmentInput () where
+    type FragmentFormat () = ()
+    toFragment = arr (const ())
+
+instance FragmentInput VFloat where
+        type FragmentFormat VFloat = FFloat
+        toFragment = makeFragment "" STypeFloat unS
+         
+instance FragmentInput FlatVFloat where
+        type FragmentFormat FlatVFloat = FFloat
+        toFragment = makeFragment "flat" STypeFloat (unS . unFlat)
+
+instance FragmentInput NoPerspectiveVFloat where
+        type FragmentFormat NoPerspectiveVFloat = FFloat
+        toFragment = makeFragment "noperspective" STypeFloat (unS . unNPersp)
+              
+instance FragmentInput VInt where
+        type FragmentFormat VInt = FInt
+        toFragment = makeFragment "flat" STypeInt unS
+
+instance FragmentInput VWord where
+        type FragmentFormat VWord = FWord
+        toFragment = makeFragment "flat" STypeUInt unS
+
+instance FragmentInput VBool where
+        type FragmentFormat VBool = FBool
+        toFragment = proc b -> do i <- toFragment -< ifB b 1 0 :: VInt
+                                  returnA -< i ==* 1
+        
+instance (FragmentInput a) => FragmentInput (V0 a) where
+    type FragmentFormat (V0 a) = V0 (FragmentFormat a)
+    toFragment = arr (const V0)
+
+instance (FragmentInput a) => FragmentInput (V1 a) where
+    type FragmentFormat (V1 a) = V1 (FragmentFormat a)
+    toFragment = proc ~(V1 a) -> do a' <- toFragment -< a
+                                    returnA -< V1 a'
+
+instance (FragmentInput a) => FragmentInput (V2 a) where
+    type FragmentFormat (V2 a) = V2 (FragmentFormat a)
+    toFragment = proc ~(V2 a b) -> do a' <- toFragment -< a
+                                      b' <- toFragment -< b
+                                      returnA -< V2 a' b'
+
+instance (FragmentInput a) => FragmentInput (V3 a) where
+    type FragmentFormat (V3 a) = V3 (FragmentFormat a)
+    toFragment = proc ~(V3 a b c) -> do a' <- toFragment -< a
+                                        b' <- toFragment -< b
+                                        c' <- toFragment -< c
+                                        returnA -< V3 a' b' c'
+
+instance (FragmentInput a) => FragmentInput (V4 a) where
+    type FragmentFormat (V4 a) = V4 (FragmentFormat a)
+    toFragment = proc ~(V4 a b c d) -> do a' <- toFragment -< a
+                                          b' <- toFragment -< b
+                                          c' <- toFragment -< c
+                                          d' <- toFragment -< d
+                                          returnA -< V4 a' b' c' d'
+                                           
+instance (FragmentInput a, FragmentInput b) => FragmentInput (a,b) where
+    type FragmentFormat (a,b) = (FragmentFormat a, FragmentFormat b)
+    toFragment = proc ~(a,b) -> do a' <- toFragment -< a
+                                   b' <- toFragment -< b
+                                   returnA -< (a', b')
+
+instance (FragmentInput a, FragmentInput b, FragmentInput c) => FragmentInput (a,b,c) where
+    type FragmentFormat (a,b,c) = (FragmentFormat a, FragmentFormat b, FragmentFormat c)
+    toFragment = proc ~(a,b,c) -> do a' <- toFragment -< a
+                                     b' <- toFragment -< b
+                                     c' <- toFragment -< c
+                                     returnA -< (a', b', c')
+
+instance (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d) => FragmentInput (a,b,c,d) where
+    type FragmentFormat (a,b,c,d) = (FragmentFormat a, FragmentFormat b, FragmentFormat c, FragmentFormat d)
+    toFragment = proc ~(a,b,c,d) -> do a' <- toFragment -< a
+                                       b' <- toFragment -< b
+                                       c' <- toFragment -< c
+                                       d' <- toFragment -< d
+                                       returnA -< (a', b', c', d')
+

@@ -0,0 +1,516 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TupleSections              #-}
+module Graphics.GPipe.Internal.FrameBuffer where
+
+import           Control.Applicative
+import           Control.Monad                           (when, void)
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.State.Lazy
+import           Control.Monad.Trans.Writer.Lazy
+import           Data.List                               (intercalate)
+import           Graphics.GPipe.Internal.Compiler
+import           Graphics.GPipe.Internal.Context
+import           Graphics.GPipe.Internal.Expr
+import           Graphics.GPipe.Internal.Format
+import           Graphics.GPipe.Internal.FragmentStream
+import           Graphics.GPipe.Internal.PrimitiveStream
+import           Graphics.GPipe.Internal.Shader
+import           Graphics.GPipe.Internal.Texture
+
+import           Data.Word                               (Word)
+import           Foreign.Marshal.Utils
+import Graphics.GL.Core33
+import Graphics.GL.Types
+import Data.IORef
+import Foreign.Marshal.Alloc
+import Foreign.Storable (peek)
+import Foreign.Marshal.Array (withArray)
+import Foreign.Ptr (nullPtr)
+import Linear.V4
+
+-- | A monad in which individual color images can be drawn. 
+newtype DrawColors os s a = DrawColors (StateT Int (Writer [Int -> (ExprM (), GlobDeclM (), s -> (IO FBOKey, IO (), IO ()))]) a) deriving (Functor, Applicative, Monad)
+
+runDrawColors :: DrawColors os s a -> (ExprM (), GlobDeclM (), s -> (IO [FBOKey], IO (), IO ()))
+runDrawColors (DrawColors m) = foldl sf (return (), return (), const (return [], return (), return ())) $ zip [0..] $ execWriter (runStateT m 0)
+    where sf (ms, mg, mio) (n, f) = let (sh, g, io) = f n in (ms >> sh, mg >> g, sf' mio io )
+          sf' mio io s = let (a,b,c) = mio s
+                             (x,y,z) = io s
+                         in (do ns <- a
+                                n <- x
+                                return $ ns ++ [n]
+                            , b >> y, c >> z)
+
+-- | Draw color values into a color renderable texture image.                            
+drawColor :: forall c s os. ColorRenderable c => (s -> (Image (Format c), ColorMask c, UseBlending)) -> FragColor c -> DrawColors os s ()
+drawColor sf c = DrawColors $ do n <- get
+                                 put $ n+1
+                                 lift $ tell [\ix -> make3  (setColor cf ix c) $ \s -> let (i, mask, o) = sf s
+                                                                                           n' = fromIntegral n
+                                                                                           useblend = if o then glEnablei GL_BLEND n' else glDisablei GL_BLEND n'
+                                                                                       in (getImageFBOKey i,
+                                                                                           getImageBinding i (GL_COLOR_ATTACHMENT0 + n'),
+                                                                                            do
+                                                                                             useblend
+                                                                                             setGlColorMask cf n' mask)
+                                                                                       ]
+    where cf = undefined :: c
+
+-- | Draw all fragments in a 'FragmentStream' using the provided function that passes each fragment value into a 'DrawColors' monad. The first argument is a function
+--   that retrieves a 'Blending' setting from the shader environment, which will be used for all 'drawColor' actions in the 'DrawColors' monad where 'UseBlending' is 'True'.
+--   (OpenGl 3.3 unfortunately doesn't support having different blending settings for different color targets.) 
+draw :: forall a os f s. (s -> Blending) -> FragmentStream a -> (a -> DrawColors os s ()) -> Shader os f s ()
+-- | Like 'draw', but performs a depth test on each fragment first. The 'DrawColors' monad is then only run for fragments where the depth test passes. 
+drawDepth :: forall a os f s d. DepthRenderable d => (s -> (Blending, Image (Format d), DepthOption)) -> FragmentStream (a, FragDepth) -> (a -> DrawColors os s ()) -> Shader os f s ()
+-- | Like 'draw', but performs a stencil test on each fragment first. The 'DrawColors' monad is then only run for fragments where the stencil test passes. 
+drawStencil :: forall a os f s st. StencilRenderable st => (s -> (Blending, Image (Format st), StencilOptions)) -> FragmentStream a -> (a -> DrawColors os s ()) -> Shader os f s ()
+-- | Like 'draw', but performs a stencil test and a depth test (in that order) on each fragment first. The 'DrawColors' monad is then only run for fragments where the stencil and depth test passes. 
+drawDepthStencil :: forall a os f s d st. (DepthRenderable d, StencilRenderable st) => (s -> (Blending, Image (Format d), Image (Format st), DepthStencilOption)) -> FragmentStream (a, FragDepth) -> (a -> DrawColors os s ()) -> Shader os f s ()
+
+makeFBOKeys :: IO [FBOKey] -> IO (Maybe FBOKey) -> IO (Maybe FBOKey) -> IO FBOKeys
+makeFBOKeys c d s = do c' <- c
+                       d' <- d
+                       s' <- s
+                       return $ FBOKeys c' d' s'
+
+draw sf fs m = Shader $ tellDrawcalls fs $ \c -> let (sh,g,ioc) = runDrawColors (m c) in (sh, g, f ioc)
+    where f ioc s = let (fbokeyio, fboio, io) = ioc s
+                        b = sf s
+                    in (Just (makeFBOKeys fbokeyio (return Nothing) (return Nothing), fboio)
+                       , io >> glDisable GL_DEPTH_TEST >> glDisable GL_STENCIL_TEST >> setGlBlend b)
+
+drawDepth sf fs m = Shader $ tellDrawcalls fs $ \(c,d) -> let (sh,g,ioc) = runDrawColors (m c) in (sh >> setDepth d, g, f ioc)
+    where f ioc s = let (fbokeyio, fboio, io) = ioc s
+                        (b, di, o) = sf s
+                    in (Just (makeFBOKeys fbokeyio (Just <$> getImageFBOKey di) (return Nothing)
+                             , fboio >> getImageBinding di GL_DEPTH_ATTACHMENT)
+                       , io >> glDisable GL_STENCIL_TEST >> setGlBlend b >> setGlDepthOptions o)
+
+drawStencil sf fs m = Shader $ tellDrawcalls fs $ \c -> let (sh,g,ioc) = runDrawColors (m c) in (sh, g, f ioc )
+    where f ioc s = let (fbokeyio, fboio, io) = ioc s
+                        (b, si, o) = sf s
+                    in (Just (makeFBOKeys fbokeyio (return Nothing) (Just <$> getImageFBOKey si)
+                             , fboio >> getImageBinding si GL_STENCIL_ATTACHMENT)
+                       , io >> glDisable GL_DEPTH_TEST >> setGlBlend b >> setGlStencilOptions o OpZero OpZero)
+
+drawDepthStencil sf fs m = Shader $ tellDrawcalls fs $ \(c,d) -> let (sh,g,ioc) = runDrawColors (m c) in (sh >> setDepth d, g, f ioc )
+    where f ioc s = let (fbokeyio, fboio, io) = ioc s
+                        (b, di, si, o) = sf s
+                    in (Just (makeFBOKeys fbokeyio (Just <$> getImageFBOKey di) (Just <$> getImageFBOKey si)
+                             , fboio >> getCombinedBinding di si)
+                       , io >> setGlBlend b >> setGlDepthStencilOptions o)
+          getCombinedBinding di si | imageEquals di si = getImageBinding di GL_DEPTH_STENCIL_ATTACHMENT
+                                   | otherwise = getImageBinding di GL_DEPTH_ATTACHMENT >> getImageBinding si GL_STENCIL_ATTACHMENT
+
+-- | Draw color values from a 'FragmentStream' into the context window.
+drawContextColor :: forall os s c ds. ContextColorFormat c => (s -> ContextColorOption c) -> FragmentStream (FragColor c) -> Shader os (ContextFormat c ds) s ()
+-- | Perform a depth test for each fragment from a 'FragmentStream' in the context window. This doesn't draw any color values and only affects the depth buffer.
+drawContextDepth :: forall os s c ds. DepthRenderable ds => (s -> DepthOption) -> FragmentStream FragDepth -> Shader os (ContextFormat c ds) s ()
+-- | Perform a depth test for each fragment from a 'FragmentStream' and write a color value from each fragment that passes the test into the context window.
+drawContextColorDepth :: forall os s c ds. (ContextColorFormat c, DepthRenderable ds) => (s -> (ContextColorOption c, DepthOption)) -> FragmentStream (FragColor c, FragDepth) -> Shader os (ContextFormat c ds) s ()
+-- | Perform a stencil test for each fragment from a 'FragmentStream' in the context window. This doesn't draw any color values and only affects the stencil buffer.
+drawContextStencil :: forall os s c ds. StencilRenderable ds => (s -> StencilOptions) -> FragmentStream () -> Shader os (ContextFormat c ds) s ()
+-- | Perform a stencil test for each fragment from a 'FragmentStream' and write a color value from each fragment that passes the test into the context window.
+drawContextColorStencil :: forall os s c ds. (ContextColorFormat c, StencilRenderable ds) => (s -> (ContextColorOption c, StencilOptions)) -> FragmentStream (FragColor c) -> Shader os (ContextFormat c ds) s ()
+-- | Perform a stencil test and depth test (in that order) for each fragment from a 'FragmentStream' in the context window. This doesnt draw any color values and only affects the depth and stencil buffer.
+drawContextDepthStencil :: forall os s c ds. (DepthRenderable ds, StencilRenderable ds) => (s -> DepthStencilOption) -> FragmentStream FragDepth -> Shader os (ContextFormat c ds) s ()
+-- | Perform a stencil test and depth test (in that order) for each fragment from a 'FragmentStream' and write a color value from each fragment that passes the tests into the context window.
+drawContextColorDepthStencil :: forall os s c ds. (ContextColorFormat c, DepthRenderable ds, StencilRenderable ds) => (s -> (ContextColorOption c, DepthStencilOption)) -> FragmentStream (FragColor c, FragDepth) -> Shader os (ContextFormat c ds) s ()
+
+drawContextColor sf fs = Shader $ tellDrawcalls fs $ \ a -> make3 (setColor cf 0 a) io
+                            where io s = (Nothing, glDisable GL_DEPTH_TEST >> glDisable GL_STENCIL_TEST >> setGlContextColorOptions cf (sf s))
+                                  cf = undefined :: c
+
+drawContextDepth sf fs = Shader $ tellDrawcalls fs $ \ a-> (setDepth a, return(), io)
+                            where io s = (Nothing, glDisable GL_STENCIL_TEST >> setGlDepthOptions (sf s))
+
+drawContextColorDepth sf fs = Shader $ tellDrawcalls fs $ \(c,d) -> let (s, g) = setColor cf 0 c in (s >> setDepth d, g, io)
+                                where io s = let (cop, dop) = sf s in (Nothing, glDisable GL_STENCIL_TEST >> setGlContextColorOptions cf cop >> setGlDepthOptions dop)
+                                      cf = undefined :: c
+
+drawContextStencil sf fs = Shader $ tellDrawcalls fs $ const (return (), return (), io)
+                                where io s = (Nothing, glDisable GL_DEPTH_TEST >> setGlStencilOptions (sf s) OpZero OpZero)
+
+drawContextColorStencil sf fs = Shader $ tellDrawcalls fs $ \ a -> make3 (setColor cf 0 a) io
+                                    where io s = let (cop, dop) = sf s in (Nothing, glDisable GL_DEPTH_TEST >> setGlContextColorOptions cf cop >> setGlStencilOptions dop OpZero OpZero)
+                                          cf = undefined :: c
+
+drawContextDepthStencil sf fs = Shader $ tellDrawcalls fs $ \ a-> (setDepth a, return(), io)
+                                    where io s = (Nothing, setGlDepthStencilOptions (sf s))
+
+drawContextColorDepthStencil sf fs = Shader $ tellDrawcalls fs $ \ (c,d) -> let (s, g) = setColor cf 0 c in (s >> setDepth d, g, io)
+                                        where io s = let (cop, dop) = sf s in (Nothing, setGlContextColorOptions cf cop >> setGlDepthStencilOptions dop)
+                                              cf = undefined :: c
+
+tellDrawcalls :: FragmentStream a -> (a -> (ExprM (), GlobDeclM (), s -> (Maybe (IO FBOKeys, IO ()), IO ()))) -> ShaderM s ()
+tellDrawcalls (FragmentStream xs) f = do
+                               let g (x, fd) = tellDrawcall $ makeDrawcall (f x) fd
+                               mapM_ g xs
+
+makeDrawcall :: (ExprM (), GlobDeclM (), s -> (Maybe (IO FBOKeys, IO ()), IO ())) -> FragmentStreamData -> IO (Drawcall s)
+makeDrawcall (sh, shd, io) (FragmentStreamData rastN shaderpos (PrimitiveStreamData primN) keep) =
+       do (fsource, funis, fsamps, _, prevDecls, prevS) <- runExprM shd (discard keep >> sh)
+          (vsource, vunis, vsamps, vinps, _, _) <- runExprM prevDecls (prevS >> shaderpos)
+          return $ Drawcall io primN rastN vsource fsource vinps vunis vsamps funis fsamps
+
+setColor :: forall c. ColorSampleable c => c -> Int -> FragColor c -> (ExprM (), GlobDeclM ())
+setColor ct n c = let    name = "out" ++ show n
+                         typeS = typeStr ct
+                  in (do xs <- mapM unS (fromColor ct c :: [S F (ColorElement c)])
+                         tellAssignment' name (typeS ++ "(" ++ intercalate "," xs ++ ")")
+                         ,
+                      do tellGlobal "layout(location = "
+                         tellGlobal $ show n
+                         tellGlobal ") out "
+                         tellGlobal typeS
+                         tellGlobal " "
+                         tellGlobalLn name)
+
+setDepth :: FFloat -> ExprM ()
+setDepth (S d) = do d' <- d
+                    when (d' /= "gl_FragDepth") $
+                        tellAssignment' "gl_FragDepth" d'
+
+make3 :: (t, t1) -> t2 -> (t, t1, t2)
+make3 (a,b) c = (a,b,c)
+
+type FragColor c = Color c (S F (ColorElement c))
+type FragDepth = FFloat
+
+setGlColorMask :: ColorSampleable f => f -> GLuint -> Color f Bool -> IO ()
+setGlColorMask c i mask = glColorMaski i x y z w
+    where [x,y,z,w] = map fromBool $ take 4 $ fromColor c mask ++ [False, False, False]
+
+setGlContextColorOptions :: ColorSampleable f => f -> ContextColorOption f -> IO ()
+setGlContextColorOptions c (ContextColorOption blend mask) = do
+        setGlColorMask c 0 mask
+        setGlBlend blend
+        case blend of
+            NoBlending -> glDisable GL_BLEND
+            LogicOp _ -> glDisable GL_BLEND
+            _ -> glEnable GL_BLEND
+
+setGlBlend :: Blending -> IO ()
+setGlBlend NoBlending = return ()
+setGlBlend (BlendRgbAlpha (e, ea) (BlendingFactors sf df, BlendingFactors sfa dfa) (V4 r g b a)) = do
+                            glBlendEquationSeparate (getGlBlendEquation e) (getGlBlendEquation ea)
+                            glBlendFuncSeparate (getGlBlendFunc sf) (getGlBlendFunc df) (getGlBlendFunc sfa) (getGlBlendFunc dfa)
+                            when (usesConstantColor sf || usesConstantColor df || usesConstantColor sfa || usesConstantColor dfa) $
+                                glBlendColor (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)
+setGlBlend (LogicOp op) = glEnable GL_COLOR_LOGIC_OP >> glLogicOp (getGlLogicOp op)
+
+
+setGlDepthOptions :: DepthOption -> IO ()
+setGlDepthOptions (DepthOption df dm) = do glEnable GL_DEPTH_TEST
+                                           glDepthFunc (getGlCompFunc df)
+                                           glDepthMask $ fromBool dm
+
+setGlStencilOptions :: FrontBack StencilOption -> StencilOp -> StencilOp -> IO ()
+setGlStencilOptions (FrontBack (StencilOption ft fr ff fp frm fwm) (StencilOption bt br bf bp brm bwm)) fdf bdf = do
+    glEnable GL_STENCIL_TEST
+    glStencilFuncSeparate GL_FRONT (getGlCompFunc ft) (fromIntegral fr) (fromIntegral frm)
+    glStencilOpSeparate GL_FRONT (getGlStencilOp ff) (getGlStencilOp fdf) (getGlStencilOp fp)
+    glStencilMaskSeparate GL_FRONT (fromIntegral fwm)
+    glStencilFuncSeparate GL_BACK (getGlCompFunc bt) (fromIntegral br) (fromIntegral brm)
+    glStencilOpSeparate GL_BACK (getGlStencilOp bf) (getGlStencilOp bdf) (getGlStencilOp bp)
+    glStencilMaskSeparate GL_BACK (fromIntegral bwm)
+
+setGlDepthStencilOptions :: DepthStencilOption -> IO ()
+setGlDepthStencilOptions (DepthStencilOption sop dop (FrontBack fdf bdf)) = do
+    setGlDepthOptions dop
+    setGlStencilOptions sop fdf bdf
+
+data ContextColorOption f = ContextColorOption Blending (ColorMask f)
+
+data DepthOption = DepthOption DepthFunction DepthMask
+type StencilOptions = FrontBack StencilOption
+data StencilOption = StencilOption {
+                            stencilTest         :: ComparisonFunction,
+                            stencilReference    :: Int,
+                            opWhenStencilFail   :: StencilOp,
+                            opWhenStencilPass   :: StencilOp,
+                            stencilReadBitMask  :: Word,
+                            stencilWriteBitMask :: Word
+                            }
+data DepthStencilOption = DepthStencilOption {
+                            dsStencilOptions              :: StencilOptions,
+                            dsDepthOption                 :: DepthOption ,
+                            opWhenStencilPassButDepthFail :: FrontBack StencilOp
+                            }
+
+data FrontBack a = FrontBack { front :: a, back :: a }
+
+-- | 'True' for each color component that should be written to the target.
+type ColorMask f = Color f Bool
+-- | 'True' if the depth component should be written to the target.
+type DepthMask = Bool
+-- | The function used to compare the fragment's depth and the depth buffers depth with. E.g. 'Less' means "where fragment's depth is less than the buffers current depth".
+type DepthFunction = ComparisonFunction
+
+-- | Indicates whether this color draw should use the 'Blending' setting given to the draw action. If this is 'False', the fragment's color value will simply replace the
+--   target value.
+type UseBlending = Bool
+
+-- | Denotes how each fragment's color value should be blended with the target value. 
+data Blending =
+      -- | The fragment's color will simply replace the target value.
+      NoBlending
+      -- | The fragment's color will be blended using an equation and a set of factors for the RGB components, and a separate equation and set of factors for the Alpha component (if present), and a 'ConstantColor' that may be referenced from the 'BlendingFactors'. The 'ConstantColor' may be 'undefined' if none of the 'BlendingFactors' needs it.
+      --   This kind of blending will only be made on colors with a 'Float' representation (e.g. 'RGB8' or 'RGB32F', but not 'RGB8I'), integer colors will simply replace the target value.
+    | BlendRgbAlpha (BlendEquation, BlendEquation) (BlendingFactors, BlendingFactors) ConstantColor
+      -- | A logical operation that will be done on the bits of the fragment color and the target color. This kind of blending is only done on colors that has a
+      --   integral /internal/ representation (e.g. 'RGB8' or 'RGB8I', but not 'RGB32F'; note the difference with @BlendRgbAlpha@ restriction). For targets with an internal floating point representation, the fragment value will simply replace the target value.
+    | LogicOp LogicOp
+
+type ConstantColor = V4 Float
+
+-- | A set of blending factors used for the source (fragment) and the destination (target).
+data BlendingFactors = BlendingFactors { blendFactorSrc :: BlendingFactor, blendFactorDst :: BlendingFactor }
+
+-- | The equation used to combine the source (fragment) and the destination (target) after they have been multiplied with their respective 'BlendingFactor's.
+data BlendEquation =
+     FuncAdd
+   | FuncSubtract
+   | FuncReverseSubtract
+   | Min
+   | Max
+
+-- | A factor that the source (fragment) or the destination (target) will be multiplied with before combined with the other in the 'BlendEquation'.
+data BlendingFactor =
+     Zero
+   | One
+   | SrcColor
+   | OneMinusSrcColor
+   | DstColor
+   | OneMinusDstColor
+   | SrcAlpha
+   | OneMinusSrcAlpha
+   | DstAlpha
+   | OneMinusDstAlpha
+   | ConstantColor
+   | OneMinusConstantColor
+   | ConstantAlpha
+   | OneMinusConstantAlpha
+   | SrcAlphaSaturate
+
+usesConstantColor ConstantColor = True
+usesConstantColor OneMinusConstantColor = True
+usesConstantColor ConstantAlpha = True
+usesConstantColor OneMinusConstantAlpha = True
+usesConstantColor _ = False 
+
+-- | A bitwise logical operation that will be used to combine colors that has an integral internal representation.
+data LogicOp =
+     Clear
+   | And
+   | AndReverse
+   | Copy
+   | AndInverted
+   | Noop
+   | Xor
+   | Or
+   | Nor
+   | Equiv
+   | Invert
+   | OrReverse
+   | CopyInverted
+   | OrInverted
+   | Nand
+   | Set
+
+-- | Denotes the operation that will be performed on the target's stencil value
+data StencilOp =
+     OpZero
+   | OpKeep
+   | OpReplace
+   | OpIncr
+   | OpIncrWrap
+   | OpDecr
+   | OpDecrWrap
+   | OpInvert
+
+-----------
+
+-- | Fill a color image with a constant color value
+clearColorImage :: forall c os f. ColorRenderable c => Image c -> Color c (ColorElement c) -> Render os f ()
+clearColorImage i c = do cd <- getRenderContextData
+                         key <- Render $ lift $ lift $ getImageFBOKey i
+                         let fbokey = FBOKeys [key] Nothing Nothing
+                         mfbo <- Render $ lift $ lift $ getFBO cd fbokey
+                         case mfbo of
+                                Just fbo -> Render $ lift $ lift $ do fbo' <- readIORef fbo
+                                                                      glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                Nothing -> do fAdd <- getRenderContextFinalizerAdder
+                                              Render $ throwFromMaybe $ lift $ lift $ do 
+                                                  fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)
+                                                  fbo <- newIORef fbo'
+                                                  void $ fAdd fbo $ with fbo' (glDeleteFramebuffers 1)
+                                                  setFBO cd fbokey fbo
+                                                  glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                                  glEnable GL_FRAMEBUFFER_SRGB
+                                                  getImageBinding i GL_COLOR_ATTACHMENT0
+                                                  withArray [GL_COLOR_ATTACHMENT0] $ glDrawBuffers 1
+                                                  getFBOerror
+                                              
+                         Render $ lift $ lift $ do glDisable GL_SCISSOR_TEST
+                                                   clearColor (undefined :: c) c
+                                                   glEnable GL_SCISSOR_TEST
+
+-- | Fill a depth image with a constant depth value (in the range [0,1])
+clearDepthImage :: DepthRenderable d => Image d -> Float -> Render os f ()
+clearDepthImage i d = do cd <- getRenderContextData
+                         key <- Render $ lift $ lift $ getImageFBOKey i
+                         let fbokey = FBOKeys [] (Just key) Nothing
+                         mfbo <- Render $ lift $ lift $ getFBO cd fbokey
+                         case mfbo of
+                                Just fbo -> Render $ lift $ lift $ do fbo' <- readIORef fbo
+                                                                      glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                Nothing -> do fAdd <- getRenderContextFinalizerAdder
+                                              Render $ throwFromMaybe $ lift $ lift $ do 
+                                                  fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)
+                                                  fbo <- newIORef fbo'
+                                                  void $ fAdd fbo $ with fbo' (glDeleteFramebuffers 1)
+                                                  setFBO cd fbokey fbo
+                                                  glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                                  glEnable GL_FRAMEBUFFER_SRGB
+                                                  getImageBinding i GL_DEPTH_ATTACHMENT
+                                                  glDrawBuffers 0 nullPtr
+                                                  getFBOerror
+                         Render $ lift $ lift $ do glDisable GL_SCISSOR_TEST
+                                                   with (realToFrac d) $ glClearBufferfv GL_DEPTH 0
+                                                   glEnable GL_SCISSOR_TEST
+
+-- | Fill a depth image with a constant stencil value
+clearStencilImage :: StencilRenderable s => Image s -> Int -> Render os f ()
+clearStencilImage i s = do cd <- getRenderContextData
+                           key <- Render $ lift $ lift $ getImageFBOKey i
+                           let fbokey = FBOKeys [] Nothing (Just key)
+                           mfbo <- Render $ lift $ lift $ getFBO cd fbokey
+                           case mfbo of
+                                Just fbo -> Render $ lift $ lift $ do fbo' <- readIORef fbo
+                                                                      glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                Nothing -> do fAdd <- getRenderContextFinalizerAdder
+                                              Render $ throwFromMaybe $ lift $ lift $ do 
+                                                  fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)
+                                                  fbo <- newIORef fbo'
+                                                  void $ fAdd fbo $ with fbo' (glDeleteFramebuffers 1)
+                                                  setFBO cd fbokey fbo
+                                                  glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                                  glEnable GL_FRAMEBUFFER_SRGB
+                                                  getImageBinding i GL_STENCIL_ATTACHMENT
+                                                  glDrawBuffers 0 nullPtr
+                                                  getFBOerror
+                           Render $ lift $ lift $ do glDisable GL_SCISSOR_TEST 
+                                                     with (fromIntegral s) $ glClearBufferiv GL_STENCIL 0
+                                                     glEnable GL_SCISSOR_TEST
+
+-- | Fill a combined depth stencil image with a constant depth value (in the range [0,1]) and a constant stencil value
+clearDepthStencilImage :: Image DepthStencil -> Float -> Int -> Render os f ()
+clearDepthStencilImage i d s = do
+                           cd <- getRenderContextData
+                           key <- Render $ lift $ lift $ getImageFBOKey i
+                           let fbokey = FBOKeys [] Nothing (Just key)
+                           mfbo <- Render $ lift $ lift $ getFBO cd fbokey
+                           case mfbo of
+                                Just fbo -> Render $ lift $ lift $ do fbo' <- readIORef fbo
+                                                                      glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                Nothing -> do fAdd <- getRenderContextFinalizerAdder
+                                              Render $ throwFromMaybe $ lift $ lift $ do 
+                                                  fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)
+                                                  fbo <- newIORef fbo'
+                                                  void $ fAdd fbo $ with fbo' (glDeleteFramebuffers 1)
+                                                  setFBO cd fbokey fbo
+                                                  glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'
+                                                  glEnable GL_FRAMEBUFFER_SRGB
+                                                  getImageBinding i GL_DEPTH_STENCIL_ATTACHMENT
+                                                  glDrawBuffers 0 nullPtr
+                                                  getFBOerror
+                           Render $ lift $ lift $ do glDisable GL_SCISSOR_TEST 
+                                                     glClearBufferfi GL_DEPTH_STENCIL 0 (realToFrac d) (fromIntegral s)
+                                                     glEnable GL_SCISSOR_TEST 
+
+-- | Fill the context window's back buffer with a constant color value
+clearContextColor :: forall os c ds. ContextColorFormat c => Color c Float -> Render os (ContextFormat c ds) ()
+clearContextColor c = Render $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0
+                                                glDisable GL_SCISSOR_TEST 
+                                                withArray (map realToFrac (fromColor (undefined :: c) c ++ replicate 3 0 :: [Float])) $ glClearBufferfv GL_COLOR 0
+                                                glEnable GL_SCISSOR_TEST 
+
+-- | Fill the context window's back depth buffer with a constant depth value (in the range [0,1]) 
+clearContextDepth :: DepthRenderable ds => Float -> Render os (ContextFormat c ds) ()
+clearContextDepth d = Render $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0
+                                                glDisable GL_SCISSOR_TEST 
+                                                with (realToFrac d) $ glClearBufferfv GL_DEPTH 0
+                                                glEnable GL_SCISSOR_TEST 
+
+-- | Fill the context window's back stencil buffer with a constant stencil value
+clearContextStencil :: StencilRenderable ds => Int -> Render os (ContextFormat c ds) ()
+clearContextStencil s = Render $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0
+                                                  glDisable GL_SCISSOR_TEST 
+                                                  with (fromIntegral s) $ glClearBufferiv GL_STENCIL 0
+                                                  glEnable GL_SCISSOR_TEST
+
+-- | Fill the context window's back depth and stencil buffers with a constant depth value (in the range [0,1]) and a constant stencil value
+clearContextDepthStencil :: Float -> Int -> Render os (ContextFormat c DepthStencil) ()
+clearContextDepthStencil d s = Render $ lift $ lift $ do glBindFramebuffer GL_DRAW_FRAMEBUFFER 0
+                                                         glDisable GL_SCISSOR_TEST 
+                                                         glClearBufferfi GL_DEPTH_STENCIL 0 (realToFrac d) (fromIntegral s)
+                                                         glEnable GL_SCISSOR_TEST
+
+---------------
+
+
+getGlBlendEquation :: BlendEquation -> GLenum
+getGlBlendEquation FuncAdd = GL_FUNC_ADD
+getGlBlendEquation FuncSubtract = GL_FUNC_SUBTRACT
+getGlBlendEquation FuncReverseSubtract = GL_FUNC_REVERSE_SUBTRACT
+getGlBlendEquation Min = GL_MIN
+getGlBlendEquation Max = GL_MAX
+
+getGlBlendFunc :: BlendingFactor -> GLenum
+getGlBlendFunc Zero = GL_ZERO
+getGlBlendFunc One = GL_ONE
+getGlBlendFunc SrcColor = GL_SRC_COLOR
+getGlBlendFunc OneMinusSrcColor = GL_ONE_MINUS_SRC_COLOR
+getGlBlendFunc DstColor = GL_DST_COLOR
+getGlBlendFunc OneMinusDstColor = GL_ONE_MINUS_DST_COLOR
+getGlBlendFunc SrcAlpha = GL_SRC_ALPHA
+getGlBlendFunc OneMinusSrcAlpha = GL_ONE_MINUS_SRC_ALPHA
+getGlBlendFunc DstAlpha = GL_DST_ALPHA
+getGlBlendFunc OneMinusDstAlpha = GL_ONE_MINUS_DST_ALPHA
+getGlBlendFunc ConstantColor = GL_CONSTANT_COLOR
+getGlBlendFunc OneMinusConstantColor = GL_ONE_MINUS_CONSTANT_COLOR
+getGlBlendFunc ConstantAlpha = GL_CONSTANT_ALPHA
+getGlBlendFunc OneMinusConstantAlpha = GL_ONE_MINUS_CONSTANT_ALPHA
+getGlBlendFunc SrcAlphaSaturate = GL_SRC_ALPHA_SATURATE
+
+getGlLogicOp :: LogicOp -> GLenum
+getGlLogicOp Clear = GL_CLEAR
+getGlLogicOp And = GL_AND
+getGlLogicOp AndReverse = GL_AND_REVERSE
+getGlLogicOp Copy = GL_COPY
+getGlLogicOp AndInverted = GL_AND_INVERTED
+getGlLogicOp Noop = GL_NOOP
+getGlLogicOp Xor = GL_XOR
+getGlLogicOp Or = GL_OR
+getGlLogicOp Nor = GL_NOR
+getGlLogicOp Equiv = GL_EQUIV
+getGlLogicOp Invert = GL_INVERT
+getGlLogicOp OrReverse = GL_OR_REVERSE
+getGlLogicOp CopyInverted = GL_COPY_INVERTED
+getGlLogicOp OrInverted = GL_OR_INVERTED
+getGlLogicOp Nand = GL_NAND
+getGlLogicOp Set = GL_SET
+
+getGlStencilOp :: StencilOp -> GLenum
+getGlStencilOp OpZero = GL_ZERO
+getGlStencilOp OpKeep = GL_KEEP
+getGlStencilOp OpReplace = GL_REPLACE
+getGlStencilOp OpIncr = GL_INCR
+getGlStencilOp OpIncrWrap = GL_INCR_WRAP
+getGlStencilOp OpDecr = GL_DECR
+getGlStencilOp OpDecrWrap = GL_DECR_WRAP
+getGlStencilOp OpInvert = GL_INVERT
+
+   --------------------

@@ -0,0 +1,154 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, EmptyDataDecls, TypeFamilies, GADTs #-}
+module Graphics.GPipe.Internal.PrimitiveArray where
+
+import Graphics.GPipe.Internal.Buffer
+import Graphics.GPipe.Internal.Shader
+import Data.Monoid
+import Data.IORef
+
+import Data.Word
+
+import           Graphics.GL.Core33
+import           Graphics.GL.Types
+
+-- | A vertex array is the basic building block for a primitive array. It is created from the contents of a 'Buffer', but unlike a 'Buffer',
+--   it may be truncated, zipped with other vertex arrays, and even morphed into arrays of a different type with the provided 'Functor' instance.
+--   A @VertexArray t a@ has elements of type @a@, and @t@ indicates whether the vertex array may be used as instances or not.   
+data VertexArray t a = VertexArray  { 
+    -- | Retrieve the number of elements in a 'VertexArray'.
+    vertexArrayLength :: Int, 
+    bArrBFunc:: BInput -> a 
+    }
+
+-- | A phantom type to indicate that a 'VertexArray' may only be used for instances (in 'toPrimitiveArrayInstanced' and 'toPrimitiveArrayIndexedInstanced'). 
+data Instances
+
+-- | Create a 'VertexArray' from a 'Buffer'. The vertex array will have the same number of elements as the buffer, use 'takeVertices' and 'dropVertices' to make it smaller. 
+newVertexArray :: Buffer os a -> Render os f (VertexArray t a)
+newVertexArray buffer = Render $ return $ VertexArray (bufferLength buffer) $ bufBElement buffer
+
+instance Functor (VertexArray t) where
+    fmap f (VertexArray n g) = VertexArray n (f . g)
+
+-- | Zip two 'VertexArray's using the function given as first argument. If either of the argument 'VertexArray's are restriced to 'Instances' only, then so will the resulting
+--   array be, as depicted by the 'Combine' type family.
+zipVertices :: (a -> b -> c) -> VertexArray t a -> VertexArray t' b -> VertexArray (Combine t t') c 
+zipVertices h (VertexArray n f) (VertexArray m g) = VertexArray (min n m) (\x -> h (f x) (g x))
+
+type family Combine t t' where
+    Combine () Instances = Instances 
+    Combine Instances () = Instances 
+    Combine Instances Instances = Instances 
+    Combine () () = () 
+
+-- | @takeVertices n a@ creates a shorter vertex array by taking the @n@ first elements of the array @a@.
+takeVertices :: Int -> VertexArray t a -> VertexArray t a
+takeVertices n (VertexArray m f) = VertexArray (min n m) f
+
+-- | @dropVertices n a@ creates a shorter vertex array by dropping the @n@ first elements of the array @a@. The argument array @a@ must not be
+--   constrained to only 'Instances'.
+dropVertices :: Int -> VertexArray () a -> VertexArray t a
+dropVertices n (VertexArray m f) = VertexArray n' g
+        where
+            n' = max (m - n) 0
+            g bIn = f $ bIn { bInSkipElems = bInSkipElems bIn + n'}
+
+-- | @replicateEach n a@ will create a longer vertex array, only to be used for instances, by replicating each element of the array @a@ @n@ times. E.g.
+--   @replicateEach 3 {ABCD...}@ will yield @{AAABBBCCCDDD...}@. This is particulary useful before zipping the array with another that has a different replication rate.  
+replicateEach :: Int -> VertexArray t a -> VertexArray Instances a
+replicateEach n (VertexArray m f) = VertexArray (n*m) (\x -> f $ x {bInInstanceDiv = bInInstanceDiv x * n})
+
+type family IndexFormat a where
+    IndexFormat (B Word32) = Word32 
+    IndexFormat (BPacked Word16) = Word16 
+    IndexFormat (BPacked Word8) = Word8 
+
+-- | An index array is like a vertex array, but contains only integer indices. These indices must come from a tightly packed 'Buffer', hence the lack of
+--   a 'Functor' instance and no conversion from 'VertexArray's.
+data IndexArray = IndexArray { 
+    iArrName :: IORef GLuint, 
+    -- | Numer of indices in an 'IndexArray'.
+    indexArrayLength:: Int, 
+    offset:: Int, 
+    restart:: Maybe Int, 
+    indexType :: GLuint 
+    } 
+
+-- | Create an 'IndexArray' from a 'Buffer' of unsigned integers (as constrained by the closed 'IndexFormat' type family instances). The index array will have the same number of elements as the buffer, use 'takeIndices' and 'dropIndices' to make it smaller.
+--   The @Maybe a@ argument is used to optionally denote a primitive restart index. 
+newIndexArray :: forall os f b a. (BufferFormat b, Integral a, IndexFormat b ~ a) => Buffer os b -> Maybe a -> Render os f IndexArray
+newIndexArray buf r = let a = undefined :: b in Render $ return $ IndexArray (bufName buf) (bufferLength buf) 0 (fmap fromIntegral r) (getGlType a) 
+ 
+-- | @takeIndices n a@ creates a shorter index array by taking the @n@ first indices of the array @a@.
+takeIndices :: Int -> IndexArray -> IndexArray
+takeIndices n i = i { indexArrayLength = min n (indexArrayLength i) }
+
+-- | @dropIndices n a@ creates a shorter index array by dropping the @n@ first indices of the array @a@.
+dropIndices :: Int -> IndexArray -> IndexArray
+dropIndices n i = i { indexArrayLength = max (l - n) 0, offset = offset i + n } where l = indexArrayLength i
+
+data Triangles
+data Lines
+data Points
+
+data PrimitiveTopology p where
+    TriangleList :: PrimitiveTopology Triangles
+    TriangleStrip :: PrimitiveTopology Triangles
+    TriangleFan :: PrimitiveTopology Triangles
+    LineList :: PrimitiveTopology Lines
+    LineStrip :: PrimitiveTopology Lines
+    LineLoop :: PrimitiveTopology Lines
+    PointList :: PrimitiveTopology Points
+    
+toGLtopology :: PrimitiveTopology p -> GLuint
+toGLtopology TriangleList = GL_TRIANGLES
+toGLtopology TriangleStrip = GL_TRIANGLE_STRIP
+toGLtopology TriangleFan = GL_TRIANGLE_FAN
+toGLtopology LineList = GL_LINES
+toGLtopology LineStrip = GL_LINE_STRIP
+toGLtopology LineLoop = GL_LINE_LOOP
+toGLtopology PointList = GL_POINTS
+  
+
+{-
+Some day:
+
+instance PrimitiveTopology TrianglesWithAdjacency where
+    toGLtopology TriangleStripWithAdjacency = 0
+    data Geometry TrianglesWithAdjacency a = TriangleWithAdjacency a a a a a a
+
+instance PrimitiveTopology LinesWithAdjacency where
+    toGLtopology LinesWithAdjacencyList = 0
+    toGLtopology LinesWithAdjacencyStrip = 1
+    data Geometry LinesWithAdjacency a = LineWithAdjacency a a a a
+-}
+
+type InstanceCount = Int
+
+data PrimitiveArrayInt p a = PrimitiveArraySimple (PrimitiveTopology p) Int a 
+                           | PrimitiveArrayIndexed (PrimitiveTopology p) IndexArray a 
+                           | PrimitiveArrayInstanced (PrimitiveTopology p) InstanceCount Int a 
+                           | PrimitiveArrayIndexedInstanced (PrimitiveTopology p) IndexArray InstanceCount a 
+
+-- | An array of primitives
+newtype PrimitiveArray p a = PrimitiveArray {getPrimitiveArray :: [PrimitiveArrayInt p a]}
+
+instance Monoid (PrimitiveArray p a) where
+    mempty = PrimitiveArray []
+    mappend (PrimitiveArray a) (PrimitiveArray b) = PrimitiveArray (a ++ b)
+
+instance Functor (PrimitiveArray p) where
+    fmap f (PrimitiveArray xs) = PrimitiveArray  $ fmap g xs
+        where g (PrimitiveArraySimple p l a) = PrimitiveArraySimple p l (f a)
+              g (PrimitiveArrayIndexed p i a) = PrimitiveArrayIndexed p i (f a)
+              g (PrimitiveArrayInstanced p il l a) = PrimitiveArrayInstanced p il l (f a)
+              g (PrimitiveArrayIndexedInstanced p i il a) = PrimitiveArrayIndexedInstanced p i il (f a)
+              
+toPrimitiveArray :: PrimitiveTopology p -> VertexArray () a -> PrimitiveArray p a
+toPrimitiveArray p va = PrimitiveArray [PrimitiveArraySimple p (vertexArrayLength va) (bArrBFunc va (BInput 0 0))]
+toPrimitiveArrayIndexed :: PrimitiveTopology p -> IndexArray -> VertexArray () a -> PrimitiveArray p a
+toPrimitiveArrayIndexed p ia va = PrimitiveArray [PrimitiveArrayIndexed p ia (bArrBFunc va (BInput 0 0))]
+toPrimitiveArrayInstanced :: PrimitiveTopology p -> (a -> b -> c) -> VertexArray () a -> VertexArray t b -> PrimitiveArray p c
+toPrimitiveArrayInstanced p f va ina = PrimitiveArray [PrimitiveArrayInstanced p (vertexArrayLength ina) (vertexArrayLength va) (f (bArrBFunc va $ BInput 0 0) (bArrBFunc ina $ BInput 0 1))]
+toPrimitiveArrayIndexedInstanced :: PrimitiveTopology p -> IndexArray -> (a -> b -> c) -> VertexArray () a -> VertexArray t b -> PrimitiveArray p c
+toPrimitiveArrayIndexedInstanced p ia f va ina = PrimitiveArray [PrimitiveArrayIndexedInstanced p ia (vertexArrayLength ina) (f (bArrBFunc va $ BInput 0 0) (bArrBFunc ina $ BInput 0 1))]

@@ -0,0 +1,320 @@+{-# LANGUAGE TypeFamilies, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, Arrows, GeneralizedNewtypeDeriving #-}
+
+module Graphics.GPipe.Internal.PrimitiveStream where
+
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Writer.Lazy
+import Control.Monad.Trans.State.Lazy
+import Prelude hiding (length, id, (.))
+import Graphics.GPipe.Internal.Buffer
+import Graphics.GPipe.Internal.Expr
+import Graphics.GPipe.Internal.Shader
+import Graphics.GPipe.Internal.Compiler
+import Graphics.GPipe.Internal.PrimitiveArray
+import Graphics.GPipe.Internal.Context
+import Control.Category
+import Control.Arrow
+import Data.Monoid (Monoid(..))
+import Data.IntMap.Lazy (insert)
+import Data.Word
+import Data.Int
+
+import Graphics.GL.Core33
+import Foreign.Marshal.Utils
+import Foreign.Ptr (intPtrToPtr)
+import Data.IORef
+import Linear.V4
+import Linear.V3
+import Linear.V2
+import Linear.V1
+import Linear.V0
+
+type DrawCallName = Int
+data PrimitiveStreamData = PrimitiveStreamData DrawCallName
+
+-- | A @'PrimitiveStream' t a @ is a stream of primitives of type @t@ where the vertices are values of type @a@. You
+--   can operate a stream's vertex values using the 'Functor' instance (this will result in a shader running on the GPU).
+--   You may also append 'PrimitiveStream's using the 'Monoid' instance, but if possible append the origin 'PrimitiveArray's instead, as this will create more optimized
+--   draw calls. 
+newtype PrimitiveStream t a = PrimitiveStream [(a, PrimitiveStreamData)] deriving Monoid
+
+instance Functor (PrimitiveStream t) where
+        fmap f (PrimitiveStream xs) = PrimitiveStream $ map (first f) xs
+
+-- | This class constraints which buffer types can be turned into vertex values, and what type those values have.  
+class BufferFormat a => VertexInput a where
+    -- | The type the buffer value will be turned into once it becomes a vertex value.
+    type VertexFormat a
+    -- | An arrow action that turns a value from it's buffer representation to it's vertex representation. Use 'toVertex' from
+    --   the GPipe provided instances to operate in this arrow. Also note that this arrow needs to be able to return a value
+    --   lazily, so ensure you use
+    -- 
+    --  @proc ~pattern -> do ...@. 
+    toVertex :: ToVertex a (VertexFormat a)  
+
+-- | The arrow type for 'toVertex'.
+newtype ToVertex a b = ToVertex (Kleisli (StateT Int (Writer [Binding -> (IO VAOKey, IO ())])) a b) deriving (Category, Arrow)
+
+
+-- | Create a primitive stream from a primitive array provided from the shader environment. 
+toPrimitiveStream :: forall os f s a p. VertexInput a => (s -> PrimitiveArray p a) -> Shader os f s (PrimitiveStream p (VertexFormat a))   
+toPrimitiveStream sf = Shader $ do n <- getName
+                                   uniAl <- askUniformAlignment
+                                   let sampleBuffer = makeBuffer undefined undefined uniAl :: Buffer os a
+                                       x = fst $ runWriter (evalStateT (mf $ bufBElement sampleBuffer $ BInput 0 0) 0)
+                                   doForInputArray n (map drawcall . getPrimitiveArray . sf)
+                                   return $ PrimitiveStream [(x, PrimitiveStreamData n)] 
+    where 
+        ToVertex (Kleisli mf) = toVertex :: ToVertex a (VertexFormat a)
+        drawcall (PrimitiveArraySimple p l a) binds = (attribs a binds, glDrawArrays (toGLtopology p) 0 (fromIntegral l)) 
+        drawcall (PrimitiveArrayIndexed p i a) binds = (attribs a binds, do
+                                                    bindIndexBuffer i
+                                                    glDrawElements (toGLtopology p) (fromIntegral $ indexArrayLength i) (indexType i) (intPtrToPtr $ fromIntegral $ offset i))
+        drawcall (PrimitiveArrayInstanced p il l a) binds = (attribs a binds, glDrawArraysInstanced (toGLtopology p) 0 (fromIntegral l) (fromIntegral il))
+        drawcall (PrimitiveArrayIndexedInstanced p i il a) binds = (attribs a binds, do
+                                                      bindIndexBuffer i
+                                                      glDrawElementsInstanced (toGLtopology p) (fromIntegral $ indexArrayLength i) (indexType i) (intPtrToPtr $ fromIntegral $ offset i) (fromIntegral il))
+        bindIndexBuffer i = do case restart i of Just x -> do glEnable GL_PRIMITIVE_RESTART 
+                                                              glPrimitiveRestartIndex (fromIntegral x)
+                                                 Nothing -> glDisable GL_PRIMITIVE_RESTART
+                               bname <- readIORef (iArrName i)
+                               glBindBuffer GL_ELEMENT_ARRAY_BUFFER bname 
+
+        assignIxs :: Int -> Binding -> [Int] -> [Binding -> (IO VAOKey, IO ())] -> [(IO VAOKey, IO ())] 
+        assignIxs n ix xxs@(x:xs) (f:fs) | x == n    = f ix : assignIxs (n+1) (ix+1) xs fs
+                                         | otherwise = assignIxs (n+1) ix xxs fs
+        assignIxs _ _ _ [] = []                                          
+        assignIxs _ _ _ _ = error "Too few attributes generated in toPrimitiveStream"
+                
+        attribs a binds = first sequence $ second sequence_ $ unzip $ assignIxs 0 0 binds $ execWriter (runStateT (mf a) 0)
+
+        doForInputArray :: Int -> (s -> [[Binding] -> ((IO [VAOKey], IO ()), IO ())]) -> ShaderM s ()
+        doForInputArray n io = modifyRenderIO (\s -> s { inputArrayToRenderIOs = insert n io (inputArrayToRenderIOs s) } )
+
+data InputIndices = InputIndices {
+        inputVertexID :: VInt,
+        inputInstanceID :: VInt
+    }
+
+-- | Like 'fmap', but where the vertex and instance IDs are provided as arguments as well. 
+withInputIndices :: (a -> InputIndices -> b) -> PrimitiveStream p a -> PrimitiveStream p b  
+withInputIndices f = fmap (\a -> f a (InputIndices (scalarS' "gl_VertexID") (scalarS' "gl_InstanceID")))
+
+makeVertexFx norm x f styp typ b = do 
+                             n <- get
+                             put $ n + 1
+                             let combOffset = bStride b * bSkipElems b + bOffset b
+                             lift $ tell [\ix -> ( do bn <- readIORef $ bName b
+                                                      return $ VAOKey bn combOffset x norm (bInstanceDiv b)
+                                                 , do bn <- readIORef $ bName b
+                                                      let ix' = fromIntegral ix
+                                                      glEnableVertexAttribArray ix'
+                                                      glBindBuffer GL_ARRAY_BUFFER bn  
+                                                      glVertexAttribDivisor ix' (fromIntegral $ bInstanceDiv b)
+                                                      glVertexAttribPointer ix' x typ (fromBool norm) (fromIntegral $ bStride b) (intPtrToPtr $ fromIntegral combOffset))]
+                             return (f styp $ useVInput styp n)
+
+makeVertexFnorm = makeVertexFx True 
+makeVertexF = makeVertexFx False
+
+makeVertexI x f styp typ b = do 
+                             n <- get
+                             put $ n + 1
+                             let combOffset = bStride b * bSkipElems b + bOffset b
+                             lift $ tell [\ix -> ( do bn <- readIORef $ bName b
+                                                      return $ VAOKey bn combOffset x False (bInstanceDiv b)
+                                                 , do bn <- readIORef $ bName b
+                                                      let ix' = fromIntegral ix
+                                                      glEnableVertexAttribArray ix'
+                                                      glBindBuffer GL_ARRAY_BUFFER bn
+                                                      glVertexAttribDivisor ix' (fromIntegral $ bInstanceDiv b) 
+                                                      glVertexAttribIPointer ix' x typ (fromIntegral $ bStride b) (intPtrToPtr $ fromIntegral combOffset))]
+                             return (f styp $ useVInput styp n) 
+
+-- scalars
+
+unBnorm :: Normalized t -> t
+unBnorm (Normalized a) = a
+
+instance VertexInput (B Float) where
+    type VertexFormat (B Float) = VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexF 1 (const S) STypeFloat GL_FLOAT
+instance VertexInput (Normalized (B Int32)) where
+    type VertexFormat (Normalized (B Int32)) = VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 1 (const S) STypeFloat GL_INT . unBnorm
+instance VertexInput (Normalized (B Word32)) where
+    type VertexFormat (Normalized (B Word32)) = VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 1 (const S) STypeFloat GL_UNSIGNED_INT . unBnorm
+instance VertexInput (B Int32) where
+    type VertexFormat (B Int32) = VInt
+    toVertex = ToVertex $ Kleisli $ makeVertexI 1 (const S) STypeInt GL_INT
+instance VertexInput (B Word32) where
+    type VertexFormat (B Word32) = VWord
+    toVertex = ToVertex $ Kleisli $ makeVertexI 1 (const S) STypeUInt GL_UNSIGNED_INT
+
+       
+-- B2
+
+instance VertexInput (B2 Float) where
+    type VertexFormat (B2 Float) = V2 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexF 2 vec2S (STypeVec 2) GL_FLOAT . unB2
+instance VertexInput (Normalized (B2 Int32)) where
+    type VertexFormat (Normalized (B2 Int32)) = V2 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 2 vec2S (STypeVec 2) GL_INT . unB2 . unBnorm
+instance VertexInput (Normalized (B2 Int16)) where
+    type VertexFormat (Normalized (B2 Int16)) = V2 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 2 vec2S (STypeVec 2) GL_SHORT . unB2 . unBnorm
+instance VertexInput (Normalized (B2 Word32)) where
+    type VertexFormat (Normalized (B2 Word32)) = V2 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 2 vec2S (STypeVec 2) GL_UNSIGNED_INT . unB2 . unBnorm
+instance VertexInput (Normalized (B2 Word16)) where
+    type VertexFormat (Normalized (B2 Word16)) = V2 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 2 vec2S (STypeVec 2) GL_UNSIGNED_SHORT . unB2 . unBnorm
+instance VertexInput (B2 Int32) where
+    type VertexFormat (B2 Int32) = V2 VInt
+    toVertex = ToVertex $ Kleisli $ makeVertexI 2 vec2S (STypeIVec 2) GL_INT . unB2
+instance VertexInput (B2 Int16) where
+    type VertexFormat (B2 Int16) = V2 VInt
+    toVertex = ToVertex $ Kleisli $ makeVertexI 2 vec2S (STypeIVec 2) GL_SHORT . unB2
+instance VertexInput (B2 Word32) where
+    type VertexFormat (B2 Word32) = V2 VWord
+    toVertex = ToVertex $ Kleisli $ makeVertexI 2 vec2S (STypeUVec 2) GL_UNSIGNED_INT . unB2
+instance VertexInput (B2 Word16) where
+    type VertexFormat (B2 Word16) = V2 VWord
+    toVertex = ToVertex $ Kleisli $ makeVertexI 2 vec2S (STypeUVec 2) GL_UNSIGNED_SHORT . unB2
+
+-- B3
+
+instance VertexInput (B3 Float) where
+    type VertexFormat (B3 Float) = V3 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexF 3 vec3S (STypeVec 3) GL_FLOAT . unB3
+instance VertexInput (Normalized (B3 Int32)) where
+    type VertexFormat (Normalized (B3 Int32)) = V3 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_INT . unB3 . unBnorm
+instance VertexInput (Normalized (B3 Int16)) where
+    type VertexFormat (Normalized (B3 Int16)) = V3 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_SHORT . unB3 . unBnorm
+instance VertexInput (Normalized (B3 Int8)) where
+    type VertexFormat (Normalized (B3 Int8)) = V3 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_BYTE . unB3 . unBnorm
+instance VertexInput (Normalized (B3 Word32)) where
+    type VertexFormat (Normalized (B3 Word32)) = V3 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_UNSIGNED_INT . unB3 . unBnorm
+instance VertexInput (Normalized (B3 Word16)) where
+    type VertexFormat (Normalized (B3 Word16)) = V3 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_UNSIGNED_SHORT . unB3 . unBnorm
+instance VertexInput (Normalized (B3 Word8)) where
+    type VertexFormat (Normalized (B3 Word8)) = V3 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 3 vec3S (STypeVec 3) GL_UNSIGNED_BYTE . unB3 . unBnorm
+instance VertexInput (B3 Int32) where
+    type VertexFormat (B3 Int32) = V3 VInt
+    toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) GL_INT . unB3
+instance VertexInput (B3 Int16) where
+    type VertexFormat (B3 Int16) = V3 VInt
+    toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) GL_SHORT . unB3
+instance VertexInput (B3 Int8) where
+    type VertexFormat (B3 Int8) = V3 VInt
+    toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) GL_BYTE . unB3
+instance VertexInput (B3 Word32) where
+    type VertexFormat (B3 Word32) = V3 VWord
+    toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) GL_UNSIGNED_INT . unB3
+instance VertexInput (B3 Word16) where
+    type VertexFormat (B3 Word16) = V3 VWord
+    toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) GL_UNSIGNED_SHORT . unB3
+instance VertexInput (B3 Word8) where
+    type VertexFormat (B3 Word8) = V3 VWord
+    toVertex = ToVertex $ Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) GL_UNSIGNED_BYTE . unB3
+
+-- B4
+
+instance VertexInput (B4 Float) where
+    type VertexFormat (B4 Float) = V4 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexF 4 vec4S (STypeVec 4) GL_FLOAT . unB4
+instance VertexInput (Normalized (B4 Int32)) where
+    type VertexFormat (Normalized (B4 Int32)) = V4 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_INT . unB4 . unBnorm
+instance VertexInput (Normalized (B4 Int16)) where
+    type VertexFormat (Normalized (B4 Int16)) = V4 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_SHORT . unB4 . unBnorm
+instance VertexInput (Normalized (B4 Int8)) where
+    type VertexFormat (Normalized (B4 Int8)) = V4 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_BYTE . unB4 . unBnorm
+instance VertexInput (Normalized (B4 Word32)) where
+    type VertexFormat (Normalized (B4 Word32)) = V4 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_UNSIGNED_INT . unB4 . unBnorm
+instance VertexInput (Normalized (B4 Word16)) where
+    type VertexFormat (Normalized (B4 Word16)) = V4 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_UNSIGNED_SHORT . unB4 . unBnorm
+instance VertexInput (Normalized (B4 Word8)) where
+    type VertexFormat (Normalized (B4 Word8)) = V4 VFloat
+    toVertex = ToVertex $ Kleisli $ makeVertexFnorm 4 vec4S (STypeVec 4) GL_UNSIGNED_BYTE . unB4 . unBnorm
+instance VertexInput (B4 Int32) where
+    type VertexFormat (B4 Int32) = V4 VInt
+    toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) GL_INT . unB4
+instance VertexInput (B4 Int16) where
+    type VertexFormat (B4 Int16) = V4 VInt
+    toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) GL_SHORT . unB4
+instance VertexInput (B4 Int8) where
+    type VertexFormat (B4 Int8) = V4 VInt
+    toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) GL_BYTE . unB4
+instance VertexInput (B4 Word32) where
+    type VertexFormat (B4 Word32) = V4 VWord
+    toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) GL_UNSIGNED_INT . unB4
+instance VertexInput (B4 Word16) where
+    type VertexFormat (B4 Word16) = V4 VWord
+    toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) GL_UNSIGNED_SHORT . unB4
+instance VertexInput (B4 Word8) where
+    type VertexFormat (B4 Word8) = V4 VWord
+    toVertex = ToVertex $ Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) GL_UNSIGNED_BYTE . unB4
+
+                                             
+instance (VertexInput a, VertexInput b) => VertexInput (a,b) where
+    type VertexFormat (a,b) = (VertexFormat a, VertexFormat b)
+    toVertex = proc ~(a,b) -> do a' <- toVertex -< a
+                                 b' <- toVertex -< b
+                                 returnA -< (a', b')
+
+instance (VertexInput a, VertexInput b, VertexInput c) => VertexInput (a,b,c) where
+    type VertexFormat (a,b,c) = (VertexFormat a, VertexFormat b, VertexFormat c)
+    toVertex = proc ~(a,b,c) -> do a' <- toVertex -< a
+                                   b' <- toVertex -< b
+                                   c' <- toVertex -< c
+                                   returnA -< (a', b', c')
+
+instance (VertexInput a, VertexInput b, VertexInput c, VertexInput d) => VertexInput (a,b,c,d) where
+    type VertexFormat (a,b,c,d) = (VertexFormat a, VertexFormat b, VertexFormat c, VertexFormat d)
+    toVertex = proc ~(a,b,c,d) -> do a' <- toVertex -< a
+                                     b' <- toVertex -< b
+                                     c' <- toVertex -< c
+                                     d' <- toVertex -< d
+                                     returnA -< (a', b', c', d')
+
+instance VertexInput a => VertexInput (V0 a) where
+    type VertexFormat (V0 a) = V0 (VertexFormat a)
+    toVertex = arr (const V0)
+
+instance VertexInput a => VertexInput (V1 a) where
+    type VertexFormat (V1 a) = V1 (VertexFormat a)
+    toVertex = proc ~(V1 a) -> do a' <- toVertex -< a
+                                  returnA -< V1 a'
+
+instance VertexInput a => VertexInput (V2 a) where
+    type VertexFormat (V2 a) = V2 (VertexFormat a)
+    toVertex = proc ~(V2 a b) -> do a' <- toVertex -< a
+                                    b' <- toVertex -< b
+                                    returnA -< V2 a' b'
+
+instance VertexInput a => VertexInput (V3 a) where
+    type VertexFormat (V3 a) = V3 (VertexFormat a)
+    toVertex = proc ~(V3 a b c) -> do a' <- toVertex -< a
+                                      b' <- toVertex -< b
+                                      c' <- toVertex -< c
+                                      returnA -< V3 a' b' c'
+
+instance VertexInput a => VertexInput (V4 a) where
+    type VertexFormat (V4 a) = V4 (VertexFormat a)
+    toVertex = proc ~(V4 a b c d) -> do a' <- toVertex -< a
+                                        b' <- toVertex -< b
+                                        c' <- toVertex -< c
+                                        d' <- toVertex -< d
+                                        returnA -< V4 a' b' c' d'

@@ -0,0 +1,132 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts,
+  RankNTypes, ExistentialQuantification, GeneralizedNewtypeDeriving,
+  FlexibleInstances, GADTs #-}
+
+module Graphics.GPipe.Internal.Shader (
+    Shader(..),
+    ShaderM(..),
+    ShaderState(..),
+    CompiledShader, 
+    Render(..),
+    getName,
+    tellDrawcall,
+    askUniformAlignment,
+    modifyRenderIO,
+    compileShader,
+    withoutContext,
+    mapShader,
+    guard',
+    maybeShader,
+    chooseShader,
+    silenceShader,
+    throwFromMaybe
+) where
+
+
+import Graphics.GPipe.Internal.Compiler
+import Graphics.GPipe.Internal.Context
+import Graphics.GPipe.Internal.Buffer
+import Control.Monad.Trans.State 
+import Control.Monad.IO.Class
+
+import Control.Monad.Trans.Writer.Lazy (tell, WriterT(..), runWriterT)
+import Control.Monad.Exception (MonadException)
+import Control.Applicative (Applicative, Alternative, (<|>))
+import Control.Monad.Trans.Class (lift)
+import Data.Maybe (fromJust, isJust, isNothing)
+import Control.Monad (MonadPlus)
+import Control.Monad.Trans.List (ListT(..))
+import Data.Monoid (All(..), mempty)
+import Data.Either
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Error (throwError)
+
+data ShaderState s = ShaderState Int (RenderIOState s)
+
+newShaderState :: ShaderState s
+newShaderState = ShaderState 0 newRenderIOState
+
+getName :: ShaderM s Int
+getName = do ShaderState n r <- ShaderM $ lift $ lift $ lift get
+             ShaderM $ lift $ lift $ lift $ put $ ShaderState (n+1) r
+             return n
+
+askUniformAlignment = ShaderM ask 
+
+modifyRenderIO :: (RenderIOState s -> RenderIOState s) -> ShaderM s ()
+modifyRenderIO f = ShaderM $ lift $ lift $ lift $ modify (\(ShaderState a s) -> ShaderState a (f s))
+
+tellDrawcall :: IO (Drawcall s) -> ShaderM s ()
+tellDrawcall dc = ShaderM $ lift $ tell ([dc], mempty) 
+
+mapDrawcall :: (s -> s') -> Drawcall s' -> Drawcall s
+mapDrawcall f (Drawcall a b c d e g h i j k) = Drawcall (a . f) b c d e g h i j k 
+
+newtype ShaderM s a = ShaderM (ReaderT UniformAlignment (WriterT ([IO (Drawcall s)], s -> All) (ListT (State (ShaderState s)))) a) deriving (MonadPlus, Monad, Alternative, Applicative, Functor)
+
+-- | The monad in which all GPU computations are done. 'Shader os f s a' lives in an object space 'os' and a context with format 'f', closing over an environent of type 's'.  
+newtype Shader os f s a = Shader (ShaderM s a)  deriving (MonadPlus, Monad, Alternative, Applicative, Functor)
+
+-- | Map the environment to a different environment and run a Shader in that sub environment, returning it's result. 
+mapShader :: (s -> s') -> Shader os f s' a -> Shader os f s a
+mapShader f (Shader (ShaderM m)) = Shader $ ShaderM $ do
+        uniAl <- ask
+        lift $ WriterT $ ListT $ do
+            ShaderState x s <- get
+            let (adcs, ShaderState x' s') = runState (runListT (runWriterT (runReaderT m uniAl))) (ShaderState x newRenderIOState)
+            put $ ShaderState x' (mapRenderIOState f s' s) 
+            return $ map (\(a,(dcs, disc)) -> (a, (map (>>= (return . mapDrawcall f)) dcs, disc . f))) adcs
+
+-- | Conditionally run the effects of a shader when a 'Maybe' value is 'Just' something.   
+maybeShader :: (s -> Maybe s') -> Shader os f s' () -> Shader os f s ()
+maybeShader f m = (guard' (isJust . f) >> mapShader (fromJust . f) m) <|> guard' (isNothing . f) 
+
+-- | Like 'guard', but dependent on the 'Shaders' environment value. Since this will be evaluated at shader run time, as opposed to shader compile time for 'guard',
+--   using this to do recursion will make 'compileShader' diverge. You can break that divergence by combining it with a normal 'guard' and a maximum loop count.
+guard' :: (s -> Bool) -> Shader os f s ()
+guard' f = Shader $ ShaderM $ lift $ tell (mempty, All . f) 
+
+-- | Select one of two 'Shader' actions based on whether an 'Either' value is 'Left' or 'Right'.
+chooseShader :: (s -> Either s' s'') -> Shader os f s' a -> Shader os f s'' a -> Shader os f s a
+chooseShader f a b = (guard' (isLeft . f) >> mapShader (fromLeft . f) a) <|> (guard' (isRight . f) >> mapShader (fromRight . f) b) 
+    where fromLeft (Left x) = x
+          fromRight (Right x) = x        
+
+-- | Discard all effects of a 'Shader' action (i.e., dont draw anything) and just return the resulting value. This makes it possible to use a 'Shader' written for a different context format. 
+silenceShader :: Shader os f' s a -> Shader os f s a
+silenceShader (Shader (ShaderM m)) = Shader $ ShaderM $ do
+        uniAl <- ask
+        lift $ WriterT $ ListT $ do
+            s <- get
+            let (adcs, s') = runState (runListT (runWriterT (runReaderT m uniAl))) s
+            put s'
+            return $ map (\ (a, (_, disc)) -> (a, ([], disc))) adcs
+
+-- | A compiled shader is just a function that takes an environment and returns a 'Render' action 
+type CompiledShader os f s = s -> Render os f ()
+
+-- | Compiles a shader into a 'CompiledShader'. This action will usually take a second or more, so put it during a loading sequence or something.   
+--
+--   May throw a 'GPipeException' if the graphics driver doesn't support something in this shader (e.g. too many interpolated floats sent between a vertex and a fragment shader),
+--   or if shader evaluates to 'mzero'.
+compileShader :: (MonadIO m, MonadException m) => Shader os f x () -> ContextT w os f' m (CompiledShader os f x)
+compileShader (Shader (ShaderM m)) = do
+        uniAl <- liftContextIO getUniformAlignment
+        let (adcs, ShaderState _ s) = runState (runListT (runWriterT (runReaderT m uniAl))) newShaderState
+            f ((disc, runF):ys) e@(cd, env) = if getAll (disc env) then runF cd env else f ys e
+            f  [] _               = error "render: Shader evaluated to mzero\n"
+        xs <- mapM (\(_,(dcs, disc)) -> do 
+                                runF <- compile dcs s
+                                return (disc, runF)) adcs
+        return $ \ s -> Render $ do cd <- lift $ asks $ fst . snd
+                                    throwFromMaybe $ lift $ lift $ f xs (cd, s)
+
+throwFromMaybe m = do mErr <- m
+                      case mErr of
+                          Just err -> throwError err
+                          Nothing -> return ()
+                         
+
+-- | Use this to run a shader that doesn't reference the context frame buffer, allowing the same shader to be run in another context with a different context format (but still with same object space).
+withoutContext :: Render os () () -> Render os f ()
+withoutContext (Render m) = Render m

@@ -0,0 +1,1192 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, ScopedTypeVariables, AllowAmbiguousTypes, EmptyDataDecls #-}
+module Graphics.GPipe.Internal.Texture where
+
+import Graphics.GPipe.Internal.Format
+import Graphics.GPipe.Internal.Expr
+import Graphics.GPipe.Internal.Context
+import Graphics.GPipe.Internal.Shader
+import Graphics.GPipe.Internal.Compiler
+import Graphics.GPipe.Internal.Buffer
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.IntMap.Lazy (insert)
+
+import Graphics.GL.Core33
+import Graphics.GL.Types
+import Graphics.GL.Ext.EXT.TextureFilterAnisotropic
+
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils
+import Control.Monad
+import Data.IORef
+import Control.Applicative
+import Control.Monad.Exception (bracket, MonadAsyncException)
+import Linear.V4
+import Linear.V3
+import Linear.V2
+import Control.Exception (throwIO)
+
+data Texture1D os a = Texture1D TexName Size1 MaxLevels
+data Texture1DArray os a = Texture1DArray TexName Size2 MaxLevels
+data Texture2D os a = Texture2D TexName Size2 MaxLevels 
+                    | RenderBuffer2D TexName Size2
+data Texture2DArray os a = Texture2DArray TexName Size3 MaxLevels
+data Texture3D os a = Texture3D TexName Size3 MaxLevels
+data TextureCube os a = TextureCube TexName Size1 MaxLevels
+
+type MaxLevels = Int
+
+type Size1 = Int
+type Size2 = V2 Int
+type Size3 = V3 Int
+
+newTexture1D :: forall w os f c m. (ColorSampleable c, MonadIO m) => Format c -> Size1 -> MaxLevels -> ContextT w os f m (Texture1D os (Format c))
+newTexture1DArray :: forall w os f c m. (ColorSampleable c, MonadIO m) => Format c -> Size2 -> MaxLevels -> ContextT w os f m (Texture1DArray os (Format c))
+newTexture2D :: forall w os f c m. (TextureFormat c, MonadIO m) => Format c -> Size2 -> MaxLevels -> ContextT w os f m (Texture2D os (Format c))
+newTexture2DArray :: forall w os f c m. (ColorSampleable c, MonadIO m) => Format c -> Size3 -> MaxLevels -> ContextT w os f m (Texture2DArray os (Format c))
+newTexture3D :: forall w os f c m. (ColorRenderable c, MonadIO m) => Format c -> Size3 -> MaxLevels -> ContextT w os f m (Texture3D os (Format c))
+newTextureCube :: forall w os f c m. (ColorSampleable c, MonadIO m) => Format c -> Size1 -> MaxLevels -> ContextT w os f m (TextureCube os (Format c))
+
+newTexture1D f s mx | s < 0 = error "newTexture1D, negative size" 
+                    | mx <= 0 = error "newTexture1D, non-positive MaxLevels"
+                    | otherwise = do
+                        mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
+                        if s > mxSize 
+                          then liftIO $ throwIO $ GPipeException "newTexture1D, size larger then maximum supported by graphics driver"
+                          else do
+                            t <- makeTex
+                            let glintf = fromIntegral $ getGlInternalFormat f
+                                glf = getGlFormat (undefined :: c)
+                                ls = min mx (calcMaxLevels s)
+                                tex = Texture1D t s ls
+                            liftContextIOAsync $ do
+                                useTexSync t GL_TEXTURE_1D
+                                forM_ (zip (texture1DSizes tex) [0..]) $ \(lw, l) ->
+                                    glTexImage1D GL_TEXTURE_1D l glintf (fromIntegral lw) 0 glf GL_BYTE nullPtr
+                                setDefaultTexParams GL_TEXTURE_1D (ls-1)                                    
+                            return tex  
+newTexture1DArray f s@(V2 w sl) mx 
+                    | w < 0 || sl < 0 = error "newTexture1DArray, negative size" 
+                    | mx <= 0 = error "newTexture1DArray, non-positive MaxLevels"
+                    | otherwise = do
+                            mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
+                            if w > mxSize || sl > mxSize 
+                              then liftIO $ throwIO $ GPipeException "newTexture1DArray, size larger then maximum supported by graphics driver"
+                              else do
+                                t <- makeTex
+                                let glintf = fromIntegral $ getGlInternalFormat f
+                                    glf = getGlFormat (undefined :: c)
+                                    ls = min mx (calcMaxLevels w)
+                                    tex = Texture1DArray t s ls
+                                liftContextIOAsync $ do
+                                    useTexSync t GL_TEXTURE_1D_ARRAY
+                                    forM_ (zip (texture1DArraySizes tex) [0..]) $ \(V2 lw _, l) ->
+                                        glTexImage2D GL_TEXTURE_1D_ARRAY l glintf (fromIntegral lw) (fromIntegral sl) 0 glf GL_BYTE nullPtr
+                                    setDefaultTexParams GL_TEXTURE_1D_ARRAY (ls-1)                                    
+                                return tex
+newTexture2D f s@(V2 w h) mx | w < 0 || h < 0 = error "newTexture2D, negative size" 
+                             | mx <= 0 = error "newTexture2D, non-positive MaxLevels"
+                             | getGlFormat (undefined :: c) == GL_STENCIL_INDEX = do 
+                                mxSize <- getGlValue GL_MAX_RENDERBUFFER_SIZE
+                                if w > mxSize || h > mxSize 
+                                  then liftIO $ throwIO $ GPipeException "newTexture2D, size larger then maximum supported by graphics driver"
+                                  else do
+                                    t <- makeRenderBuff
+                                    liftContextIOAsync $ 
+                                       glRenderbufferStorage GL_RENDERBUFFER (getGlInternalFormat f) (fromIntegral w) (fromIntegral h)
+                                    return $ RenderBuffer2D t s
+                             | otherwise = do
+                                mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
+                                if w > mxSize || h > mxSize 
+                                  then liftIO $ throwIO $ GPipeException "newTexture2D, size larger then maximum supported by graphics driver"
+                                  else do
+                                    t <- makeTex
+                                    let glintf = fromIntegral $ getGlInternalFormat f
+                                        glf = getGlFormat (undefined :: c)
+                                        ls = min mx (calcMaxLevels (max w h))
+                                        tex = Texture2D t s ls
+                                    liftContextIOAsync $ do
+                                        useTexSync t GL_TEXTURE_2D
+                                        forM_ (zip (texture2DSizes tex) [0..]) $ \(V2 lw lh, l) ->
+                                            glTexImage2D GL_TEXTURE_2D l glintf (fromIntegral lw) (fromIntegral lh) 0 glf GL_BYTE nullPtr
+                                        setDefaultTexParams GL_TEXTURE_2D (ls-1)                                    
+                                    return tex
+
+newTexture2DArray f s@(V3 w h sl) mx 
+                                | w < 0 || h < 0 || sl < 0 = error "newTexture2DArray, negative size" 
+                                | mx <= 0 = error "newTexture2DArray, non-positive MaxLevels"
+                                | otherwise = do
+                    mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
+                    if w > mxSize || h > mxSize || sl > mxSize 
+                      then liftIO $ throwIO $ GPipeException "newTexture2DArray, size larger then maximum supported by graphics driver"
+                      else do
+                        t <- makeTex
+                        let glintf = fromIntegral $ getGlInternalFormat f
+                            glf = getGlFormat (undefined :: c)
+                            ls = min mx (calcMaxLevels (max w h))
+                            tex = Texture2DArray t s ls
+                        liftContextIOAsync $ do
+                            useTexSync t GL_TEXTURE_2D_ARRAY
+                            forM_ (zip (texture2DArraySizes tex) [0..]) $ \(V3 lw lh _, l) ->
+                                glTexImage3D GL_TEXTURE_2D_ARRAY l glintf (fromIntegral lw) (fromIntegral lh) (fromIntegral sl) 0 glf GL_BYTE nullPtr
+                            setDefaultTexParams GL_TEXTURE_2D_ARRAY (ls-1)                                    
+                        return tex  
+
+newTexture3D f s@(V3 w h d) mx | w < 0 || h < 0 || d < 0 = error "newTexture3D, negative size" 
+                               | mx <= 0 = error "newTexture3D, non-positive MaxLevels"
+                               | otherwise = do
+                    mxSize <- getGlValue GL_MAX_TEXTURE_SIZE
+                    if w > mxSize || h > mxSize || d > mxSize 
+                      then liftIO $ throwIO $ GPipeException "newTexture3D, size larger then maximum supported by graphics driver"
+                      else do
+                        t <- makeTex
+                        let glintf = fromIntegral $ getGlInternalFormat f
+                            glf = getGlFormat (undefined :: c)
+                            ls = min mx (calcMaxLevels (max w (max h d)))
+                            tex = Texture3D t s ls
+                        liftContextIOAsync $ do
+                            useTexSync t GL_TEXTURE_3D
+                            forM_ (zip (texture3DSizes tex) [0..]) $ \(V3 lw lh ld, l) ->
+                                glTexImage3D GL_TEXTURE_3D l glintf (fromIntegral lw) (fromIntegral lh) (fromIntegral ld) 0 glf GL_BYTE nullPtr
+                            setDefaultTexParams GL_TEXTURE_3D (ls-1)                                    
+                        return tex
+newTextureCube f s mx | s < 0 = error "newTextureCube, negative size" 
+                      | mx <= 0 = error "newTextureCube, non-positive MaxLevels"
+                      | otherwise = do
+                    mxSize <- getGlValue GL_MAX_CUBE_MAP_TEXTURE_SIZE
+                    if s > mxSize 
+                      then liftIO $ throwIO $ GPipeException "newTextureCube, size larger then maximum supported by graphics driver"
+                      else do
+                            t <- makeTex
+                            let glintf = fromIntegral $ getGlInternalFormat f
+                                glf = getGlFormat (undefined :: c)
+                                ls = min mx (calcMaxLevels s)
+                                tex = TextureCube t s ls
+                            liftContextIOAsync $ do
+                                useTexSync t GL_TEXTURE_CUBE_MAP
+                                forM_ [(size, getGlCubeSide side) | size <- zip (textureCubeSizes tex) [0..], side <- [minBound..maxBound]] $ \((lx, l), side) ->
+                                    glTexImage2D side l glintf (fromIntegral lx) (fromIntegral lx) 0 glf GL_BYTE nullPtr
+                                setDefaultTexParams GL_TEXTURE_CUBE_MAP (ls-1)
+                                glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE
+                                glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE
+                                glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP_TO_EDGE                                    
+                            return tex
+
+getGlValue :: MonadIO m =>  GLenum -> ContextT w os f m Int
+getGlValue enum = liftContextIO $ alloca (\ptr -> liftM fromIntegral (glGetIntegerv enum ptr >> peek ptr)) 
+
+setDefaultTexParams :: GLenum -> Int -> IO ()
+setDefaultTexParams t ml = do
+                            glTexParameteri t GL_TEXTURE_BASE_LEVEL 0
+                            glTexParameteri t GL_TEXTURE_MAX_LEVEL (fromIntegral ml)
+                            glTexParameteri t GL_TEXTURE_MIN_FILTER GL_NEAREST_MIPMAP_NEAREST
+                            glTexParameteri t GL_TEXTURE_MAG_FILTER GL_NEAREST  
+
+
+texture1DLevels :: Texture1D os f -> Int 
+texture1DArrayLevels :: Texture1DArray os f -> Int 
+texture2DLevels :: Texture2D os f -> Int 
+texture2DArrayLevels :: Texture2DArray os f -> Int 
+texture3DLevels :: Texture3D os f -> Int 
+textureCubeLevels :: TextureCube os f -> Int 
+texture1DLevels (Texture1D _ _ ls) = ls
+texture1DArrayLevels (Texture1DArray _ _ ls) = ls 
+texture2DLevels (Texture2D _ _ ls) = ls 
+texture2DLevels (RenderBuffer2D _ _) = 1 
+texture2DArrayLevels (Texture2DArray _ _ ls) = ls 
+texture3DLevels (Texture3D _ _ ls) = ls 
+textureCubeLevels (TextureCube _ _ ls) = ls 
+                            
+texture1DSizes :: Texture1D os f -> [Size1] 
+texture1DArraySizes :: Texture1DArray os f -> [Size2] 
+texture2DSizes :: Texture2D os f -> [Size2] 
+texture2DArraySizes :: Texture2DArray os f -> [Size3] 
+texture3DSizes :: Texture3D os f -> [Size3] 
+textureCubeSizes :: TextureCube os f -> [Size1] 
+texture1DSizes (Texture1D _ w ls) = map (calcLevelSize w) [0..(ls-1)] 
+texture1DArraySizes (Texture1DArray _ (V2 w s) ls) = map (\l -> V2 (calcLevelSize w l) s) [0..(ls-1)]
+texture2DSizes (Texture2D _ (V2 w h) ls) = map (\l -> V2 (calcLevelSize w l) (calcLevelSize h l)) [0..(ls-1)]
+texture2DSizes (RenderBuffer2D _ s) = [s]
+texture2DArraySizes (Texture2DArray _ (V3 w h s) ls) = map (\l -> V3 (calcLevelSize w l) (calcLevelSize h l) s) [0..(ls-1)] 
+texture3DSizes (Texture3D _ (V3 w h d) ls) = map (\l -> V3 (calcLevelSize w l) (calcLevelSize h l) (calcLevelSize d l)) [0..(ls-1)] 
+textureCubeSizes (TextureCube _ x ls) = map (calcLevelSize x) [0..(ls-1)]
+
+calcLevelSize :: Int -> Int -> Int
+calcLevelSize size0 level = max 1 (size0 `div` (2 ^ level))
+
+calcMaxLevels :: Int -> Int
+calcMaxLevels s = 1 + truncate (logBase 2.0 (fromIntegral s :: Double))
+
+type TexName = IORef GLuint 
+
+makeTex :: MonadIO m => ContextT w os f m TexName 
+makeTex = do
+    name <- liftContextIO $ alloca (\ptr -> glGenTextures 1 ptr >> peek ptr)
+    tex <- liftIO $ newIORef name 
+    addContextFinalizer tex $ with name (glDeleteTextures 1)
+    addFBOTextureFinalizer False tex
+    return tex 
+
+makeRenderBuff :: MonadIO m => ContextT w os f m TexName 
+makeRenderBuff = do
+    name <- liftContextIO $ alloca (\ptr -> glGenRenderbuffers 1 ptr >> peek ptr)
+    tex <- liftIO $ newIORef name 
+    addContextFinalizer tex $ with name (glDeleteRenderbuffers 1)
+    addFBOTextureFinalizer True tex
+    return tex 
+    
+useTex :: Integral a => TexName -> GLenum -> a -> IO ()
+useTex texNameRef t bind = do glActiveTexture (GL_TEXTURE0 + fromIntegral bind)
+                              n <- readIORef texNameRef
+                              glBindTexture t n
+                                             
+useTexSync :: TexName -> GLenum -> IO ()
+useTexSync tn t = do maxUnits <- alloca (\ptr -> glGetIntegerv GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS ptr >> peek ptr)  -- Use last for all sync actions, keeping 0.. for async drawcalls
+                     useTex tn t (maxUnits-1)
+                                 
+
+type Level = Int
+data CubeSide = CubePosX | CubeNegX | CubePosY | CubeNegY | CubePosZ | CubeNegZ deriving (Eq, Enum, Bounded)
+
+type StartPos1 = Int
+type StartPos2 = V2 Int
+type StartPos3 = V3 Int
+
+
+writeTexture1D      :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture1D os (Format c) -> Level -> StartPos1 -> Size1 -> [h] -> ContextT w os f m ()
+writeTexture1DArray :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture1DArray os (Format c) -> Level -> StartPos2 -> Size2 -> [h] -> ContextT w os f m ()
+writeTexture2D      :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture2D os (Format c) -> Level -> StartPos2 -> Size2 -> [h] -> ContextT w os f m ()
+writeTexture2DArray :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture2DArray os (Format c) -> Level -> StartPos3 -> Size3 -> [h] -> ContextT w os f m ()
+writeTexture3D      :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture3D os (Format c) -> Level -> StartPos3 -> Size3 -> [h] -> ContextT w os f m ()
+writeTextureCube    :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => TextureCube os (Format c) -> Level -> CubeSide -> StartPos2 -> Size2 -> [h] -> ContextT w os f m ()
+
+writeTexture1DFromBuffer     :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture1D os (Format c) -> Level -> StartPos1 -> Size1 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+writeTexture1DArrayFromBuffer:: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture1DArray os (Format c) -> Level -> StartPos2 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+writeTexture2DFromBuffer     :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture2D os (Format c) -> Level -> StartPos2 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+writeTexture2DArrayFromBuffer:: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture2DArray os (Format c) -> Level -> StartPos3 -> Size3 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+writeTexture3DFromBuffer     :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture3D os (Format c) -> Level -> StartPos3 -> Size3 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+writeTextureCubeFromBuffer   :: forall b c h w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => TextureCube os (Format c) -> Level -> CubeSide -> StartPos2 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+
+
+readTexture1D      :: forall a b c h w os f m. (MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture1D os (Format c) -> Level -> StartPos1 -> Size1 -> (a -> h -> ContextT w os f m a) -> a -> ContextT w os f m a
+readTexture1DArray :: forall a b c h w os f m. (MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture1DArray os (Format c) -> Level -> StartPos2 -> Size1 -> (a -> h -> ContextT w os f m a) -> a -> ContextT w os f m a
+readTexture2D      :: forall a b c h w os f m. (MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture2D os (Format c) -> Level -> StartPos2 -> Size2 -> (a -> h -> ContextT w os f m a) -> a -> ContextT w os f m a
+readTexture2DArray :: forall a b c h w os f m. (MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture2DArray os (Format c) -> Level -> StartPos3 -> Size2 -> (a -> h -> ContextT w os f m a) -> a -> ContextT w os f m a
+readTexture3D      :: forall a b c h w os f m. (MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => Texture3D os (Format c) -> Level -> StartPos3 -> Size2 -> (a -> h -> ContextT w os f m a) -> a -> ContextT w os f m a
+readTextureCube    :: forall a b c h w os f m. (MonadAsyncException m, MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) h ~ b, h ~ HostFormat b) => TextureCube os (Format c) -> Level -> CubeSide -> StartPos2 -> Size2 -> (a -> h -> ContextT w os f m a) -> a -> ContextT w os f m a
+
+readTexture1DToBuffer     :: forall b c w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture1D os (Format c) -> Level -> StartPos1 -> Size1 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+readTexture1DArrayToBuffer:: forall b c w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture1DArray os (Format c) -> Level -> StartPos2 -> Size1 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+readTexture2DToBuffer     :: forall b c w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture2D os (Format c) -> Level -> StartPos2 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+readTexture2DArrayToBuffer:: forall b c w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture2DArray os (Format c) -> Level -> StartPos3 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+readTexture3DToBuffer     :: forall b c w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => Texture3D os (Format c) -> Level -> StartPos3 -> Size2 -> Buffer os b -> BufferStartPos -> ContextT w os f m ()
+readTextureCubeToBuffer   :: forall b c w os f m. (MonadIO m, BufferFormat b, ColorSampleable c, BufferColor (Color c (ColorElement c)) (HostFormat b) ~ b) => TextureCube os (Format c) -> Level -> CubeSide -> StartPos2 -> Size2 -> Buffer os b-> BufferStartPos -> ContextT w os f m ()
+
+getGlColorFormat :: (TextureFormat f, BufferFormat b) => f -> b -> GLenum
+getGlColorFormat f b = let x = getGlFormat f in if x == GL_DEPTH_STENCIL || x == GL_DEPTH_COMPONENT then GL_DEPTH_COMPONENT else getGlPaddedFormat b
+
+writeTexture1D t@(Texture1D texn _ ml) l x w d
+    | l < 0 || l >= ml = error "writeTexture1D, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture1D, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture1D, w out of bounds"
+    | otherwise = liftContextIOAsync $ do 
+                     let b = makeBuffer undefined undefined 0 :: Buffer os b
+                         size = w*bufElementSize b
+                     allocaBytes size $ \ ptr -> do
+                         end <- bufferWriteInternal b ptr (take w d)
+                         if end `minusPtr` ptr /= size 
+                            then error "writeTexture1D, data list too short"
+                            else do
+                                useTexSync texn GL_TEXTURE_1D
+                                glTexSubImage1D GL_TEXTURE_1D (fromIntegral l) (fromIntegral x) (fromIntegral w) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+    where mx = texture1DSizes t !! l  
+
+writeTexture1DArray t@(Texture1DArray texn _ ml) l (V2 x y) (V2 w h) d 
+    | l < 0 || l >= ml = error "writeTexture1DArray, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture1DArray, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture1DArray, w out of bounds"
+    | y < 0 || y >= my = error "writeTexture1DArray, y out of bounds"
+    | h < 0 || y+h > my = error "writeTexture2D, h out of bounds"
+    | otherwise = liftContextIOAsync $ do 
+                     let b = makeBuffer undefined undefined 0 :: Buffer os b
+                         size = w*h*bufElementSize b
+                     allocaBytes size $ \ ptr -> do
+                         end <- bufferWriteInternal b ptr (take (w*h) d)
+                         if end `minusPtr` ptr /= size 
+                            then error "writeTexture1DArray, data list too short"
+                            else do
+                                useTexSync texn GL_TEXTURE_1D_ARRAY
+                                glTexSubImage2D GL_TEXTURE_1D_ARRAY (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+    where V2 mx my = texture1DArraySizes t !! l  
+writeTexture2D t@(Texture2D texn _ ml) l (V2 x y) (V2 w h) d 
+    | l < 0 || l >= ml = error "writeTexture2D, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture2D, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture2D, w out of bounds"
+    | y < 0 || y >= my = error "writeTexture2D, y out of bounds"
+    | h < 0 || y+h > my = error "writeTexture2D, h out of bounds"
+    | otherwise = liftContextIOAsync $ do 
+                     let b = makeBuffer undefined undefined 0 :: Buffer os b
+                         size = w*h*bufElementSize b
+                     allocaBytes size $ \ ptr -> do
+                         end <- bufferWriteInternal b ptr (take (w*h) d)
+                         if end `minusPtr` ptr /= size 
+                            then error "writeTexture2D, data list too short"
+                            else do
+                                useTexSync texn GL_TEXTURE_2D
+                                glTexSubImage2D GL_TEXTURE_2D (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+    where V2 mx my = texture2DSizes t !! l                                                                                
+writeTexture2DArray t@(Texture2DArray texn _ ml) l (V3 x y z) (V3 w h d) dat 
+    | l < 0 || l >= ml = error "writeTexture2DArray, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture2DArray, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture2DArray, w out of bounds"
+    | y < 0 || y >= my = error "writeTexture2DArray, y out of bounds"
+    | h < 0 || y+h > my = error "writeTexture2DArray, h out of bounds"
+    | z < 0 || z >= mz = error "writeTexture2DArray, z out of bounds"
+    | d < 0 || z+d > mz = error "writeTexture2DArray, d out of bounds"
+    | otherwise = liftContextIOAsync $ do 
+                     let b = makeBuffer undefined undefined 0 :: Buffer os b
+                         size = w*h*d*bufElementSize b
+                     allocaBytes size $ \ ptr -> do
+                         end <- bufferWriteInternal b ptr (take (w*h*d) dat)
+                         if end `minusPtr` ptr /= size 
+                            then error "writeTexture2DArray, data list too short"
+                            else do
+                                useTexSync texn GL_TEXTURE_2D_ARRAY
+                                glTexSubImage3D GL_TEXTURE_2D_ARRAY (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+    where V3 mx my mz = texture2DArraySizes t !! l 
+writeTexture3D t@(Texture3D texn _ ml) l (V3 x y z) (V3 w h d) dat
+    | l < 0 || l >= ml = error "writeTexture3D, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture3D, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture3D, w out of bounds"
+    | y < 0 || y >= my = error "writeTexture3D, y out of bounds"
+    | h < 0 || y+h > my = error "writeTexture3D, h out of bounds"
+    | z < 0 || z >= mz = error "writeTexture3D, z out of bounds"
+    | d < 0 || z+d > mz = error "writeTexture3D, d out of bounds"
+    | otherwise = liftContextIOAsync $ do 
+                     let b = makeBuffer undefined undefined 0 :: Buffer os b
+                         size = w*h*d*bufElementSize b
+                     allocaBytes size $ \ ptr -> do
+                         end <- bufferWriteInternal b ptr (take (w*h*d) dat)
+                         if end `minusPtr` ptr /= size 
+                            then error "writeTexture3D, data list too short"
+                            else do
+                                useTexSync texn GL_TEXTURE_3D
+                                glTexSubImage3D GL_TEXTURE_3D (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+    where V3 mx my mz = texture3DSizes t !! l                                       
+writeTextureCube t@(TextureCube texn _ ml) l s (V2 x y) (V2 w h) d 
+    | l < 0 || l >= ml = error "writeTextureCube, level out of bounds"
+    | x < 0 || x >= mxy = error "writeTextureCube, x out of bounds"
+    | w < 0 || x+w > mxy = error "writeTextureCube, w out of bounds"
+    | y < 0 || y >= mxy = error "writeTextureCube, y out of bounds"
+    | h < 0 || y+h > mxy = error "writeTextureCube, h out of bounds"
+    | otherwise = liftContextIOAsync $ do 
+                     let b = makeBuffer undefined undefined 0 :: Buffer os b
+                         size = w*h*bufElementSize b
+                     allocaBytes size $ \ ptr -> do
+                         end <- bufferWriteInternal b ptr (take (w*h) d)
+                         if end `minusPtr` ptr /= size 
+                            then error "writeTextureCube, data list too short"
+                            else do
+                                useTexSync texn GL_TEXTURE_CUBE_MAP
+                                glTexSubImage2D (getGlCubeSide s) (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+    where mxy = textureCubeSizes t !! l
+
+writeTexture1DFromBuffer t@(Texture1D texn _ ml) l x w b i 
+    | l < 0 || l >= ml = error "writeTexture1DFromBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture1DFromBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture1DFromBuffer, w out of bounds"
+    | i < 0 || i > bufferLength b = error "writeTexture1DFromBuffer, i out of bounds"
+    | bufferLength b - i < w = error "writeTexture1DFromBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do 
+                    useTexSync texn GL_TEXTURE_1D
+                    bname <- readIORef $ bufName b
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
+                    glTexSubImage1D GL_TEXTURE_1D (fromIntegral l) (fromIntegral x) (fromIntegral w) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)        
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
+    where mx = texture1DSizes t !! l
+writeTexture1DArrayFromBuffer t@(Texture1DArray texn _ ml) l (V2 x y) (V2 w h) b i 
+    | l < 0 || l >= ml = error "writeTexture1DArrayFromBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture1DArrayFromBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture1DArrayFromBuffer, w out of bounds"
+    | y < 0 || y >= my = error "writeTexture1DArrayFromBuffer, y out of bounds"
+    | h < 0 || y+h > my = error "writeTexture1DArrayFromBuffer, h out of bounds"
+    | i < 0 || i > bufferLength b = error "writeTexture1DArrayFromBuffer, i out of bounds"
+    | bufferLength b - i < w*h = error "writeTexture1DArrayFromBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do 
+                    useTexSync texn GL_TEXTURE_1D_ARRAY
+                    bname <- readIORef $ bufName b
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
+                    glTexSubImage2D GL_TEXTURE_1D_ARRAY (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)        
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
+    where V2 mx my = texture1DArraySizes t !! l
+writeTexture2DFromBuffer t@(Texture2D texn _ ml) l (V2 x y) (V2 w h) b i
+    | l < 0 || l >= ml = error "writeTexture2DFromBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture2DFromBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture2DFromBuffer, w out of bounds"
+    | y < 0 || y >= my = error "writeTexture2DFromBuffer, y out of bounds"
+    | h < 0 || y+h > my = error "writeTexture2DFromBuffer, h out of bounds"
+    | i < 0 || i > bufferLength b = error "writeTexture2DFromBuffer, i out of bounds"
+    | bufferLength b - i < w*h = error "writeTexture2DFromBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do 
+                    useTexSync texn GL_TEXTURE_2D
+                    bname <- readIORef $ bufName b
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
+                    glTexSubImage2D GL_TEXTURE_2D (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)        
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
+    where V2 mx my = texture2DSizes t !! l                                                                                
+writeTexture2DArrayFromBuffer t@(Texture2DArray texn _ ml) l (V3 x y z) (V3 w h d) b i 
+    | l < 0 || l >= ml = error "writeTexture2DArrayFromBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture2DArrayFromBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture2DArrayFromBuffer, w out of bounds"
+    | y < 0 || y >= my = error "writeTexture2DArrayFromBuffer, y out of bounds"
+    | h < 0 || y+h > my = error "writeTexture2DArrayFromBuffer, h out of bounds"
+    | z < 0 || z >= mz = error "writeTexture2DArrayFromBuffer, z out of bounds"
+    | d < 0 || z+d > mz = error "writeTexture2DArrayFromBuffer, d out of bounds"
+    | i < 0 || i > bufferLength b = error "writeTexture2DArrayFromBuffer, i out of bounds"
+    | bufferLength b - i < w*h = error "writeTexture2DArrayFromBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do 
+                    useTexSync texn GL_TEXTURE_2D_ARRAY
+                    bname <- readIORef $ bufName b
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
+                    glTexSubImage3D GL_TEXTURE_2D_ARRAY (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)        
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
+    where V3 mx my mz = texture2DArraySizes t !! l    
+writeTexture3DFromBuffer t@(Texture3D texn _ ml) l (V3 x y z) (V3 w h d) b i 
+    | l < 0 || l >= ml = error "writeTexture3DFromBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "writeTexture3DFromBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "writeTexture3DFromBuffer, w out of bounds"
+    | y < 0 || y >= my = error "writeTexture3DFromBuffer, y out of bounds"
+    | h < 0 || y+h > my = error "writeTexture3DFromBuffer, h out of bounds"
+    | z < 0 || z >= mz = error "writeTexture3DFromBuffer, z out of bounds"
+    | d < 0 || z+d > mz = error "writeTexture3DFromBuffer, d out of bounds"
+    | i < 0 || i > bufferLength b = error "writeTexture3DFromBuffer, i out of bounds"
+    | bufferLength b - i < w*h = error "writeTexture3DFromBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do 
+                    useTexSync texn GL_TEXTURE_3D
+                    bname <- readIORef $ bufName b
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
+                    glTexSubImage3D GL_TEXTURE_3D (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w) (fromIntegral h) (fromIntegral d) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)        
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
+    where V3 mx my mz = texture3DSizes t !! l    
+writeTextureCubeFromBuffer t@(TextureCube texn _ ml) l s (V2 x y) (V2 w h) b i 
+    | l < 0 || l >= ml = error "writeTextureCubeFromBuffer, level out of bounds"
+    | x < 0 || x >= mxy = error "writeTextureCubeFromBuffer, x out of bounds"
+    | w < 0 || x+w > mxy = error "writeTextureCubeFromBuffer, w out of bounds"
+    | y < 0 || y >= mxy = error "writeTextureCubeFromBuffer, y out of bounds"
+    | h < 0 || y+h > mxy = error "writeTextureCubeFromBuffer, h out of bounds"
+    | i < 0 || i > bufferLength b = error "writeTextureCubeFromBuffer, i out of bounds"
+    | bufferLength b - i < w*h = error "writeTextureCubeFromBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do 
+                    useTexSync texn GL_TEXTURE_CUBE_MAP
+                    bname <- readIORef $ bufName b
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER bname
+                    glTexSubImage2D (getGlCubeSide s) (fromIntegral l) (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)        
+                    glBindBuffer GL_PIXEL_UNPACK_BUFFER 0
+    where mxy = textureCubeSizes t !! l           
+
+        
+readTexture1D t@(Texture1D texn _ ml) l x w f s 
+    | l < 0 || l >= ml = error "readTexture1DArray, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture1DArray, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture1DArray, w out of bounds"
+    | otherwise =  
+                 let b = makeBuffer undefined undefined 0 :: Buffer os b
+                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
+                 in bracket
+                   (liftContextIO $ do
+                     ptr <- mallocBytes $ w*bufElementSize b 
+                     setGlPixelStoreRange x 0 0 w 1
+                     useTexSync texn GL_TEXTURE_1D_ARRAY
+                     glGetTexImage GL_TEXTURE_1D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+                     return ptr)
+                   (liftIO . free)
+                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*bufElementSize b -1])
+    where mx = texture1DSizes t !! l                                             
+readTexture1DArray t@(Texture1DArray texn _ ml) l (V2 x y) w f s 
+    | l < 0 || l >= ml = error "readTexture1DArray, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture1DArray, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture1DArray, w out of bounds"
+    | y < 0 || y >= my = error "readTexture1DArray, y out of bounds"
+    | otherwise =  
+                 let b = makeBuffer undefined undefined 0 :: Buffer os b
+                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
+                 in bracket
+                   (liftContextIO $ do
+                     ptr <- mallocBytes $ w*bufElementSize b 
+                     setGlPixelStoreRange x y 0 w 1
+                     useTexSync texn GL_TEXTURE_1D_ARRAY
+                     glGetTexImage GL_TEXTURE_1D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+                     return ptr)
+                   (liftIO . free)
+                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*bufElementSize b -1])
+    where V2 mx my = texture1DArraySizes t !! l                                             
+readTexture2D t@(Texture2D texn _ ml) l (V2 x y) (V2 w h) f s 
+    | l < 0 || l >= ml = error "readTexture2D, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture2D, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture2D, w out of bounds"
+    | y < 0 || y >= my = error "readTexture2D, y out of bounds"
+    | h < 0 || y+h > my = error "readTexture2D, h out of bounds"
+    | otherwise =  
+                 let b = makeBuffer undefined undefined 0 :: Buffer os b
+                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
+                 in bracket
+                   (liftContextIO $ do
+                     ptr <- mallocBytes $ w*h*bufElementSize b 
+                     setGlPixelStoreRange x y 0 w h
+                     useTexSync texn GL_TEXTURE_2D
+                     glGetTexImage GL_TEXTURE_2D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+                     return ptr)
+                   (liftIO . free)
+                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*h*bufElementSize b -1])
+    where V2 mx my = texture2DSizes t !! l                                                                                
+readTexture2DArray t@(Texture2DArray texn _ ml) l (V3 x y z) (V2 w h) f s 
+    | l < 0 || l >= ml = error "readTexture2DArray, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture2DArray, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture2DArray, w out of bounds"
+    | y < 0 || y >= my = error "readTexture2DArray, y out of bounds"
+    | h < 0 || y+h > my = error "readTexture2DArray, h out of bounds"
+    | z < 0 || z >= mz = error "readTexture2DArray, y out of bounds"
+    | otherwise =  
+                 let b = makeBuffer undefined undefined 0 :: Buffer os b
+                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
+                 in bracket
+                   (liftContextIO $ do
+                     ptr <- mallocBytes $ w*h*bufElementSize b 
+                     setGlPixelStoreRange x y z w h
+                     useTexSync texn GL_TEXTURE_2D_ARRAY
+                     glGetTexImage GL_TEXTURE_2D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+                     return ptr)
+                   (liftIO . free)
+                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*h*bufElementSize b -1])
+    where V3 mx my mz = texture2DArraySizes t !! l   
+readTexture3D t@(Texture3D texn _ ml) l (V3 x y z) (V2 w h) f s 
+    | l < 0 || l >= ml = error "readTexture3D, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture3D, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture3D, w out of bounds"
+    | y < 0 || y >= my = error "readTexture3D, y out of bounds"
+    | h < 0 || y+h > my = error "readTexture3D, h out of bounds"
+    | z < 0 || z >= mz = error "readTexture3D, y out of bounds"
+    | otherwise =  
+                 let b = makeBuffer undefined undefined 0 :: Buffer os b
+                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
+                 in bracket
+                   (liftContextIO $ do
+                     ptr <- mallocBytes $ w*h*bufElementSize b 
+                     setGlPixelStoreRange x y z w h
+                     useTexSync texn GL_TEXTURE_3D
+                     glGetTexImage GL_TEXTURE_3D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+                     return ptr)
+                   (liftIO . free)
+                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*h*bufElementSize b -1])
+    where V3 mx my mz = texture3DSizes t !! l
+readTextureCube t@(TextureCube texn _ ml) l si (V2 x y) (V2 w h) f s 
+    | l < 0 || l >= ml = error "readTextureCube, level out of bounds"
+    | x < 0 || x >= mxy = error "readTextureCube, x out of bounds"
+    | w < 0 || x+w > mxy = error "readTextureCube, w out of bounds"
+    | y < 0 || y >= mxy = error "readTextureCube, y out of bounds"
+    | h < 0 || y+h > mxy = error "readTextureCube, h out of bounds"
+    | otherwise =  
+                 let b = makeBuffer undefined undefined 0 :: Buffer os b
+                     f' ptr a off = f a =<< liftIO (peekPixel (undefined :: b) (ptr `plusPtr` off))
+                 in bracket
+                   (liftContextIO $ do
+                     ptr <- mallocBytes $ w*h*bufElementSize b 
+                     setGlPixelStoreRange x y 0 w h
+                     useTexSync texn GL_TEXTURE_CUBE_MAP
+                     glGetTexImage (getGlCubeSide si) (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) ptr
+                     return ptr)
+                   (liftIO . free)
+                   (\ptr -> foldM (f' ptr) s [0,bufElementSize b..w*h*bufElementSize b -1])
+    where mxy = textureCubeSizes t !! l
+
+readTexture1DToBuffer t@(Texture1D texn _ ml) l x w b i
+    | l < 0 || l >= ml = error "readTexture1DToBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture1DToBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture1DToBuffer, w out of bounds"
+    | i < 0 || i > bufferLength b = error "readTexture1DToBuffer, i out of bounds"
+    | bufferLength b - i < w = error "readTexture1DToBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do
+                     bname <- readIORef $ bufName b
+                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
+                     setGlPixelStoreRange x 0 0 w 1
+                     useTexSync texn GL_TEXTURE_1D
+                     glGetTexImage GL_TEXTURE_1D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
+                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
+    where mx = texture1DSizes t !! l
+readTexture1DArrayToBuffer t@(Texture1DArray texn _ ml) l (V2 x y) w b i 
+    | l < 0 || l >= ml = error "readTexture1DArrayToBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture1DArrayToBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture1DArrayToBuffer, w out of bounds"
+    | y < 0 || y >= my = error "readTexture1DArrayToBuffer, y out of bounds"
+    | i < 0 || i > bufferLength b = error "readTexture1DArrayToBuffer, i out of bounds"
+    | bufferLength b - i < w = error "readTexture1DArrayToBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do
+                     bname <- readIORef $ bufName b
+                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
+                     setGlPixelStoreRange x y 0 w 1
+                     useTexSync texn GL_TEXTURE_1D_ARRAY
+                     glGetTexImage GL_TEXTURE_1D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
+                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
+    where V2 mx my = texture1DArraySizes t !! l
+readTexture2DToBuffer t@(Texture2D texn _ ml) l (V2 x y) (V2 w h) b i 
+    | l < 0 || l >= ml = error "readTexture2DToBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture2DToBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture2DToBuffer, w out of bounds"
+    | y < 0 || y >= my = error "readTexture2DToBuffer, y out of bounds"
+    | h < 0 || y+h > my = error "readTexture2DToBuffer, h out of bounds"
+    | i < 0 || i > bufferLength b = error "readTexture2DToBuffer, i out of bounds"
+    | bufferLength b - i < w*h = error "readTexture2DToBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do
+                     bname <- readIORef $ bufName b
+                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
+                     setGlPixelStoreRange x y 0 w h
+                     useTexSync texn GL_TEXTURE_2D
+                     glGetTexImage GL_TEXTURE_2D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
+                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
+    where V2 mx my = texture2DSizes t !! l                                                                                
+readTexture2DArrayToBuffer t@(Texture2DArray texn _ ml) l (V3 x y z) (V2 w h) b i 
+    | l < 0 || l >= ml = error "readTexture2DArrayToBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture2DArrayToBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture2DArrayToBuffer, w out of bounds"
+    | y < 0 || y >= my = error "readTexture2DArrayToBuffer, y out of bounds"
+    | h < 0 || y+h > my = error "readTexture2DArrayToBuffer, h out of bounds"
+    | z < 0 || z >= mz = error "readTexture2DArrayToBuffer, z out of bounds"
+    | i < 0 || i > bufferLength b = error "readTexture2DArrayToBuffer, i out of bounds"
+    | bufferLength b - i < w*h = error "readTexture2DArrayToBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do
+                     bname <- readIORef $ bufName b
+                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
+                     setGlPixelStoreRange x y z w h
+                     useTexSync texn GL_TEXTURE_2D_ARRAY
+                     glGetTexImage GL_TEXTURE_2D_ARRAY (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
+                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
+    where V3 mx my mz = texture2DArraySizes t !! l
+readTexture3DToBuffer t@(Texture3D texn _ ml) l (V3 x y z) (V2 w h) b i 
+    | l < 0 || l >= ml = error "readTexture3DToBuffer, level out of bounds"
+    | x < 0 || x >= mx = error "readTexture3DToBuffer, x out of bounds"
+    | w < 0 || x+w > mx = error "readTexture3DToBuffer, w out of bounds"
+    | y < 0 || y >= my = error "readTexture3DToBuffer, y out of bounds"
+    | h < 0 || y+h > my = error "readTexture3DToBuffer, h out of bounds"
+    | z < 0 || z >= mz = error "readTexture3DToBuffer, z out of bounds"
+    | i < 0 || i > bufferLength b = error "readTexture3DToBuffer, i out of bounds"
+    | bufferLength b - i < w*h = error "readTexture3DToBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do
+                     bname <- readIORef $ bufName b
+                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
+                     setGlPixelStoreRange x y z w h
+                     useTexSync texn GL_TEXTURE_3D
+                     glGetTexImage GL_TEXTURE_3D (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
+                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
+    where V3 mx my mz = texture3DSizes t !! l
+readTextureCubeToBuffer t@(TextureCube texn _ ml) l s (V2 x y) (V2 w h) b i 
+    | l < 0 || l >= ml = error "readTextureCubeToBuffer, level out of bounds"
+    | x < 0 || x >= mxy = error "readTextureCubeToBuffer, x out of bounds"
+    | w < 0 || x+w > mxy = error "readTextureCubeToBuffer, w out of bounds"
+    | y < 0 || y >= mxy = error "readTextureCubeToBuffer, y out of bounds"
+    | h < 0 || y+h > mxy = error "readTextureCubeToBuffer, h out of bounds"
+    | i < 0 || i > bufferLength b = error "readTextureCubeToBuffer, i out of bounds"
+    | bufferLength b - i < w*h = error "readTextureCubeToBuffer, buffer data too small"
+    | otherwise = liftContextIOAsync $ do
+                     setGlPixelStoreRange x y 0 w h
+                     bname <- readIORef $ bufName b
+                     glBindBuffer GL_PIXEL_PACK_BUFFER bname
+                     useTexSync texn GL_TEXTURE_CUBE_MAP
+                     glGetTexImage (getGlCubeSide s) (fromIntegral l) (getGlColorFormat (undefined :: c) (undefined :: b)) (getGlType (undefined :: b)) (wordPtrToPtr $ fromIntegral $ i*bufElementSize b)
+                     glBindBuffer GL_PIXEL_PACK_BUFFER 0
+    where mxy = textureCubeSizes t !! l                                                                                
+
+setGlPixelStoreRange :: Int -> Int -> Int -> Int -> Int -> IO ()
+setGlPixelStoreRange x y z w h = do
+        glPixelStorei GL_PACK_SKIP_PIXELS $ fromIntegral x
+        glPixelStorei GL_PACK_SKIP_ROWS $ fromIntegral y
+        glPixelStorei GL_PACK_SKIP_IMAGES $ fromIntegral z
+        glPixelStorei GL_PACK_ROW_LENGTH $ fromIntegral w
+        glPixelStorei GL_PACK_IMAGE_HEIGHT $ fromIntegral h
+
+
+generateTexture1DMipmap :: MonadIO m => Texture1D os f -> ContextT w os f' m ()
+generateTexture1DArrayMipmap :: MonadIO m => Texture1DArray os f -> ContextT w os f' m ()
+generateTexture2DMipmap :: MonadIO m => Texture2D os f -> ContextT w os f' m ()
+generateTexture2DArrayMipmap :: MonadIO m => Texture2DArray os f -> ContextT w os f' m ()
+generateTexture3DMipmap :: MonadIO m => Texture3D os f -> ContextT w os f' m ()
+generateTextureCubeMipmap :: MonadIO m => TextureCube os f -> ContextT w os f' m ()
+
+genMips texn target = liftContextIOAsync $ do
+                     useTexSync texn target
+                     glGenerateMipmap target
+
+generateTexture1DMipmap (Texture1D texn _ _) = genMips texn GL_TEXTURE_1D
+generateTexture1DArrayMipmap (Texture1DArray texn _ _) = genMips texn GL_TEXTURE_1D_ARRAY
+generateTexture2DMipmap (Texture2D texn _ _) = genMips texn GL_TEXTURE_2D
+generateTexture2DMipmap _ = return () -- Only one level for renderbuffers
+generateTexture2DArrayMipmap (Texture2DArray texn _ _) = genMips texn GL_TEXTURE_2D_ARRAY
+generateTexture3DMipmap (Texture3D texn _ _) = genMips texn GL_TEXTURE_3D
+generateTextureCubeMipmap (TextureCube texn _ _) = genMips texn GL_TEXTURE_CUBE_MAP
+       
+----------------------------------------------------------------------
+-- Samplers
+
+data Filter = Nearest | Linear  deriving (Eq, Enum)
+data EdgeMode = Repeat | Mirror | ClampToEdge | ClampToBorder deriving (Eq, Enum)
+type BorderColor c = Color c (ColorElement c) 
+type Anisotropy = Maybe Float
+
+type MinFilter = Filter
+type MagFilter = Filter
+type LodFilter = Filter
+
+-- | A GADT for sample filters, where 'SamplerFilter' cannot be used for integer textures. 
+data SamplerFilter c where
+    SamplerFilter :: (ColorElement c ~ Float) => MagFilter -> MinFilter -> LodFilter -> Anisotropy -> SamplerFilter c 
+    SamplerNearest :: SamplerFilter c
+
+type EdgeMode2 = V2 EdgeMode
+type EdgeMode3 = V3 EdgeMode
+
+data ComparisonFunction =
+     Never
+   | Less
+   | Equal
+   | Lequal
+   | Greater
+   | Notequal
+   | Gequal
+   | Always
+   deriving ( Eq, Ord, Show )
+
+getGlCompFunc :: (Num a, Eq a) => ComparisonFunction -> a
+getGlCompFunc Never = GL_NEVER
+getGlCompFunc Less = GL_LESS
+getGlCompFunc Equal = GL_EQUAL
+getGlCompFunc Lequal = GL_LEQUAL
+getGlCompFunc Greater = GL_GREATER
+getGlCompFunc Notequal = GL_NOTEQUAL
+getGlCompFunc Gequal = GL_GEQUAL
+getGlCompFunc Always = GL_ALWAYS
+   
+newSampler1D :: forall os f s c. ColorSampleable c => (s -> (Texture1D os (Format c), SamplerFilter c, (EdgeMode,  BorderColor c))) -> Shader os f s (Sampler1D (Format c))
+newSampler1DArray :: forall os f s c. ColorSampleable c => (s -> (Texture1DArray os (Format c), SamplerFilter c, (EdgeMode, BorderColor c))) -> Shader os f s (Sampler1DArray (Format c))
+newSampler2D :: forall os f s c. ColorSampleable c => (s -> (Texture2D os (Format c), SamplerFilter c, (EdgeMode2, BorderColor c))) -> Shader os f s (Sampler2D (Format c))
+newSampler2DArray :: forall os f s c. ColorSampleable c => (s -> (Texture2DArray os (Format c), SamplerFilter c, (EdgeMode2, BorderColor c))) -> Shader os f s (Sampler2DArray (Format c))
+newSampler3D :: forall os f s c. ColorRenderable c => (s -> (Texture3D os (Format c), SamplerFilter c, (EdgeMode3, BorderColor c))) -> Shader os f s (Sampler3D (Format c))
+newSamplerCube :: forall os f s c. ColorSampleable c => (s -> (TextureCube os (Format c), SamplerFilter c)) -> Shader os f s (SamplerCube (Format c))
+
+newSampler1DShadow :: forall os f s d. DepthRenderable d => (s -> (Texture1D os (Format d), SamplerFilter d, (EdgeMode, BorderColor d), ComparisonFunction)) -> Shader os f s (Sampler1D Shadow)
+newSampler1DArrayShadow :: forall os f s d. DepthRenderable d => (s -> (Texture1DArray os (Format d), SamplerFilter d, (EdgeMode, BorderColor d), ComparisonFunction)) -> Shader os f s (Sampler1DArray Shadow)
+newSampler2DShadow :: forall os f s d. DepthRenderable d => (s -> (Texture2D os d, SamplerFilter (Format d), (EdgeMode2, BorderColor d), ComparisonFunction)) -> Shader os f s (Sampler2D Shadow)
+newSampler2DArrayShadow :: forall os f s d. DepthRenderable d => (s -> (Texture2DArray os (Format d), SamplerFilter d, (EdgeMode2, BorderColor d), ComparisonFunction)) -> Shader os f s (Sampler2DArray Shadow)
+newSamplerCubeShadow :: forall os f s d. DepthRenderable d => (s -> (TextureCube os (Format d), SamplerFilter d, ComparisonFunction)) -> Shader os f s (SamplerCube Shadow)
+
+newSampler1D sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (Texture1D tn _ _, filt, (ex, ec)) = sf s
+                                                    in  do useTex tn GL_TEXTURE_1D bind
+                                                           setNoShadowMode GL_TEXTURE_1D                                       
+                                                           setSamplerFilter GL_TEXTURE_1D filt
+                                                           setEdgeMode GL_TEXTURE_1D (Just ex, Nothing, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_1D ec)
+                   return $ Sampler1D sampId False (samplerPrefix (undefined :: c))
+newSampler1DArray sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (Texture1DArray tn _ _, filt, (ex, ec)) = sf s 
+                                                    in  do useTex tn GL_TEXTURE_1D_ARRAY bind
+                                                           setNoShadowMode GL_TEXTURE_1D_ARRAY                                       
+                                                           setSamplerFilter GL_TEXTURE_1D_ARRAY filt
+                                                           setEdgeMode GL_TEXTURE_1D_ARRAY (Just ex, Nothing, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_1D_ARRAY ec)
+                   return $ Sampler1DArray sampId False (samplerPrefix (undefined :: c))
+newSampler2D sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (Texture2D tn _ _, filt, (V2 ex ey, ec)) = sf s 
+                                                    in  do useTex tn GL_TEXTURE_2D bind
+                                                           setNoShadowMode GL_TEXTURE_2D                                      
+                                                           setSamplerFilter GL_TEXTURE_2D filt
+                                                           setEdgeMode GL_TEXTURE_2D (Just ex, Just ey, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_2D ec)
+                   return $ Sampler2D sampId False (samplerPrefix (undefined :: c))
+newSampler2DArray sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (Texture2DArray tn _ _, filt, (V2 ex ey, ec)) = sf s 
+                                                    in  do useTex tn GL_TEXTURE_2D_ARRAY bind
+                                                           setNoShadowMode GL_TEXTURE_2D_ARRAY                                       
+                                                           setSamplerFilter GL_TEXTURE_2D_ARRAY filt
+                                                           setEdgeMode GL_TEXTURE_2D_ARRAY (Just ex, Just ey, Nothing) (setBorderColor (undefined :: c) GL_TEXTURE_2D_ARRAY ec)
+                   return $ Sampler2DArray sampId False (samplerPrefix (undefined :: c))
+newSampler3D sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (Texture3D tn _ _, filt, (V3 ex ey ez, ec)) = sf s 
+                                                    in  do useTex tn GL_TEXTURE_3D bind
+                                                           setNoShadowMode GL_TEXTURE_3D                                       
+                                                           setSamplerFilter GL_TEXTURE_3D filt
+                                                           setEdgeMode GL_TEXTURE_3D (Just ex, Just ey, Just ez) (setBorderColor (undefined :: c) GL_TEXTURE_3D ec)
+                   return $ Sampler3D sampId False (samplerPrefix (undefined :: c))
+newSamplerCube sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (TextureCube tn _ _, filt) = sf s 
+                                                    in  do useTex tn GL_TEXTURE_CUBE_MAP bind
+                                                           setNoShadowMode GL_TEXTURE_CUBE_MAP                                       
+                                                           setSamplerFilter GL_TEXTURE_CUBE_MAP filt
+                   return $ SamplerCube sampId False (samplerPrefix (undefined :: c))
+
+
+newSampler1DShadow sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (Texture1D tn _ _, filt, (ex, ec), cf) = sf s
+                                                    in  do useTex tn GL_TEXTURE_1D bind
+                                                           setShadowFunc GL_TEXTURE_1D cf                                     
+                                                           setSamplerFilter GL_TEXTURE_1D filt
+                                                           setEdgeMode GL_TEXTURE_1D (Just ex, Nothing, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_1D ec)
+                   return $ Sampler1D sampId True ""
+newSampler1DArrayShadow sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (Texture1DArray tn _ _, filt, (ex, ec), cf) = sf s 
+                                                    in  do useTex tn GL_TEXTURE_1D_ARRAY bind
+                                                           setShadowFunc GL_TEXTURE_1D_ARRAY cf                                       
+                                                           setSamplerFilter GL_TEXTURE_1D_ARRAY filt
+                                                           setEdgeMode GL_TEXTURE_1D_ARRAY (Just ex, Nothing, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_1D_ARRAY ec)
+                   return $ Sampler1DArray sampId True ""
+newSampler2DShadow sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (Texture2D tn _ _, filt, (V2 ex ey, ec), cf) = sf s 
+                                                    in  do useTex tn GL_TEXTURE_2D bind
+                                                           setShadowFunc GL_TEXTURE_2D cf                                      
+                                                           setSamplerFilter GL_TEXTURE_2D filt
+                                                           setEdgeMode GL_TEXTURE_2D (Just ex, Just ey, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_2D ec)
+                   return $ Sampler2D sampId True ""
+newSampler2DArrayShadow sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (Texture2DArray tn _ _, filt, (V2 ex ey, ec), cf) = sf s 
+                                                    in  do useTex tn GL_TEXTURE_2D_ARRAY bind
+                                                           setShadowFunc GL_TEXTURE_2D_ARRAY cf                                       
+                                                           setSamplerFilter GL_TEXTURE_2D_ARRAY filt
+                                                           setEdgeMode GL_TEXTURE_2D_ARRAY (Just ex, Just ey, Nothing) (setBorderColor (undefined :: d) GL_TEXTURE_2D_ARRAY ec)
+                   return $ Sampler2DArray sampId True ""
+newSamplerCubeShadow sf = Shader $ do 
+                   sampId <- getName
+                   doForSampler sampId $ \s bind -> let (TextureCube tn _ _, filt, cf) = sf s 
+                                                    in  do useTex tn GL_TEXTURE_CUBE_MAP bind
+                                                           setShadowFunc GL_TEXTURE_CUBE_MAP cf                                       
+                                                           setSamplerFilter GL_TEXTURE_CUBE_MAP filt
+                   return $ SamplerCube sampId True ""
+
+setNoShadowMode :: GLenum -> IO ()
+setNoShadowMode t = glTexParameteri t GL_TEXTURE_COMPARE_MODE GL_NONE
+
+setShadowFunc :: GLenum -> ComparisonFunction -> IO ()
+setShadowFunc t cf = do 
+    glTexParameteri t GL_TEXTURE_COMPARE_MODE GL_COMPARE_REF_TO_TEXTURE 
+    glTexParameteri t GL_TEXTURE_COMPARE_FUNC (getGlCompFunc cf) 
+                                                           
+setEdgeMode :: GLenum -> (Maybe EdgeMode, Maybe EdgeMode, Maybe EdgeMode) -> IO () -> IO ()
+setEdgeMode t (se,te,re) bcio = do glwrap GL_TEXTURE_WRAP_S se
+                                   glwrap GL_TEXTURE_WRAP_T te
+                                   glwrap GL_TEXTURE_WRAP_R re
+                                   when (se == Just ClampToBorder || te == Just ClampToBorder || re == Just ClampToBorder) 
+                                      bcio
+    where glwrap _ Nothing = return ()
+          glwrap x (Just Repeat) = glTexParameteri t x GL_REPEAT
+          glwrap x (Just Mirror) = glTexParameteri t x GL_MIRRORED_REPEAT
+          glwrap x (Just ClampToEdge) = glTexParameteri t x GL_CLAMP_TO_EDGE
+          glwrap x (Just ClampToBorder) = glTexParameteri t x GL_CLAMP_TO_BORDER
+          
+setSamplerFilter :: GLenum -> SamplerFilter a -> IO ()
+setSamplerFilter t (SamplerFilter magf minf lodf a) = setSamplerFilter' t magf minf lodf a
+setSamplerFilter t SamplerNearest = setSamplerFilter' t Nearest Nearest Nearest Nothing
+
+setSamplerFilter' :: GLenum -> MagFilter -> MinFilter -> LodFilter -> Anisotropy -> IO () 
+setSamplerFilter' t magf minf lodf a = do
+                                           glTexParameteri t GL_TEXTURE_MIN_FILTER glmin
+                                           glTexParameteri t GL_TEXTURE_MAG_FILTER glmag
+                                           case a of
+                                                Nothing -> return ()
+                                                Just a' -> glTexParameterf t GL_TEXTURE_MAX_ANISOTROPY_EXT (realToFrac a')
+    where glmin = case (minf, lodf) of
+                    (Nearest, Nearest) -> GL_NEAREST_MIPMAP_NEAREST
+                    (Linear, Nearest) -> GL_LINEAR_MIPMAP_NEAREST
+                    (Nearest, Linear) -> GL_NEAREST_MIPMAP_LINEAR                                                        
+                    (Linear, Linear) -> GL_LINEAR_MIPMAP_LINEAR
+          glmag = case magf of
+                    Nearest -> GL_NEAREST                                
+                    Linear -> GL_LINEAR
+          
+
+
+
+doForSampler :: Int -> (s -> Binding -> IO()) -> ShaderM s ()
+doForSampler n io = modifyRenderIO (\s -> s { samplerNameToRenderIO = insert n io (samplerNameToRenderIO s) } )
+
+-- | Used instead of 'Format' for shadow samplers. These samplers have specialized sampler values, see 'sample1DShadow' and friends.
+data Shadow
+data Sampler1D f = Sampler1D Int Bool String
+data Sampler1DArray f = Sampler1DArray Int Bool String
+data Sampler2D f = Sampler2D Int Bool String
+data Sampler2DArray f = Sampler2DArray Int Bool String
+data Sampler3D f = Sampler3D Int Bool String
+data SamplerCube f = SamplerCube Int Bool String
+
+-- | A GADT to specify where the level of detail and/or partial derivates should be taken from. Some values of this GADT are restricted to
+--   only 'FragmentStream's.
+data SampleLod vx x where
+    SampleAuto :: SampleLod v F
+    SampleBias :: FFloat -> SampleLod vx F   
+    SampleLod :: S x Float -> SampleLod vx x
+    SampleGrad :: vx -> vx -> SampleLod vx x
+
+-- | For some reason, OpenGl doesnt allow explicit lod to be specified for some sampler types, hence this extra GADT. 
+data SampleLod' vx x where
+    SampleAuto' :: SampleLod' v F
+    SampleBias' :: FFloat -> SampleLod' vx F   
+    SampleGrad' :: vx -> vx -> SampleLod' vx x
+
+type SampleLod1 x = SampleLod (S x Float) x
+type SampleLod2 x = SampleLod (V2 (S x Float)) x
+type SampleLod3 x = SampleLod (V3 (S x Float)) x
+type SampleLod2' x = SampleLod' (V2 (S x Float)) x
+type SampleLod3' x = SampleLod' (V3 (S x Float)) x
+
+fromLod' :: SampleLod' v x -> SampleLod v x
+fromLod' SampleAuto' = SampleAuto
+fromLod' (SampleBias' x) = SampleBias x
+fromLod' (SampleGrad' x y) = SampleGrad x y
+
+type SampleProj x = Maybe (S x Float)
+type SampleOffset1 x = Maybe Int 
+type SampleOffset2 x = Maybe (V2 Int) 
+type SampleOffset3 x = Maybe (V3 Int)
+
+-- | The type of a color sample made by a texture t 
+type ColorSample x f = Color f (S x (ColorElement f))
+type ReferenceValue x = S x Float 
+
+sample1D            :: forall c x. ColorSampleable c =>  Sampler1D (Format c)          -> SampleLod1 x -> SampleProj x -> SampleOffset1 x -> S x Float -> ColorSample x c
+sample1DArray       :: forall c x. ColorSampleable c =>  Sampler1DArray (Format c)     -> SampleLod1 x -> SampleOffset1 x -> V2 (S x Float) -> ColorSample x c
+sample2D            :: forall c x. ColorSampleable c =>  Sampler2D (Format c)          -> SampleLod2 x -> SampleProj x -> SampleOffset2 x -> V2 (S x Float) -> ColorSample x c
+sample2DArray       :: forall c x. ColorSampleable c =>  Sampler2DArray (Format c)     -> SampleLod2 x -> SampleOffset2 x -> V3 (S x Float) -> ColorSample x c
+sample3D            :: forall c x. ColorSampleable c =>  Sampler3D (Format c)          -> SampleLod3 x -> SampleProj x -> SampleOffset3 x -> V3 (S x Float) -> ColorSample x c
+sampleCube          :: forall c x. ColorSampleable c =>  SamplerCube (Format c)        -> SampleLod3 x -> V3 (S x Float) -> ColorSample x c
+
+sample1DShadow      :: forall x. Sampler1D Shadow     -> SampleLod1 x -> SampleProj x -> SampleOffset1 x -> ReferenceValue x -> S x Float -> S x Float
+sample1DArrayShadow :: forall x. Sampler1DArray Shadow-> SampleLod1 x -> SampleOffset1 x -> ReferenceValue x -> V2 (S x Float) -> S x Float
+sample2DShadow      :: forall x. Sampler2D Shadow     -> SampleLod2 x -> SampleProj x -> SampleOffset2 x -> ReferenceValue x -> V2 (S x Float) -> S x Float
+sample2DArrayShadow :: forall x. Sampler2DArray Shadow-> SampleLod2' x -> SampleOffset2 x -> ReferenceValue x -> V3 (S x Float)-> S x Float
+sampleCubeShadow    :: forall x. SamplerCube Shadow   -> SampleLod3' x -> ReferenceValue x -> V3 (S x Float) -> S x Float
+
+sample1D (Sampler1D sampId _ prefix) lod proj off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "1D" sampId lod proj off coord v1toF v1toF civ1toF pv1toF
+sample1DArray (Sampler1DArray sampId _ prefix) lod off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "1DArray" sampId lod Nothing off coord v2toF v1toF civ1toF undefined
+sample2D (Sampler2D sampId _ prefix) lod proj off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "2D" sampId lod proj off coord v2toF v2toF civ2toF pv2toF 
+sample2DArray (Sampler2DArray sampId _ prefix) lod off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "2DArray" sampId lod Nothing off coord v3toF v2toF civ2toF undefined
+sample3D (Sampler3D sampId _ prefix) lod proj off coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "3D" sampId lod proj off coord v3toF v3toF civ3toF pv3toF
+sampleCube (SamplerCube sampId _ prefix) lod coord = toColor (undefined :: c) $ sample (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "Cube" sampId lod Nothing Nothing coord v3toF v3toF undefined undefined
+
+sample1DShadow (Sampler1D sampId _ _) lod proj off ref coord = sampleShadow "1D" sampId lod proj off (t1t3 coord ref) v3toF v1toF civ1toF pv3toF
+sample1DArrayShadow (Sampler1DArray sampId _ _) lod off ref coord = sampleShadow "1DArray" sampId lod Nothing off (t2t3 coord ref) v3toF v1toF civ1toF undefined
+sample2DShadow (Sampler2D sampId _ _) lod proj off ref coord = sampleShadow "2D" sampId lod proj off (t2t3 coord ref) v3toF v2toF civ2toF pv3toF
+sample2DArrayShadow (Sampler2DArray sampId _ _) lod off ref coord = sampleShadow "2DArray" sampId (fromLod' lod) Nothing off (t3t4 coord ref) v4toF v2toF civ2toF undefined
+sampleCubeShadow (SamplerCube sampId _ _) lod ref coord = sampleShadow "Cube" sampId (fromLod' lod) Nothing Nothing (t3t4 coord ref) v4toF v3toF undefined undefined
+
+t1t3 :: S x Float -> S x Float -> V3 (S x Float)
+t2t3 :: V2 t -> t -> V3 t
+t3t4 :: V3 t -> t -> V4 t
+t1t3 x = V3 x 0 
+t2t3 (V2 x y) = V3 x y 
+t3t4 (V3 x y z) = V4 x y z
+
+texelFetch1D        :: forall c x. ColorSampleable c =>  Sampler1D (Format c)          -> SampleOffset1 x -> S x Level -> S x Int -> ColorSample x c
+texelFetch1DArray   :: forall c x. ColorSampleable c =>  Sampler1DArray (Format c)     -> SampleOffset1 x -> S x Level -> V2(S x Int) -> ColorSample x c
+texelFetch2D        :: forall c x. ColorSampleable c =>  Sampler2D (Format c)          -> SampleOffset2 x -> S x Level -> V2 (S x Int) -> ColorSample x c
+texelFetch2DArray   :: forall c x. ColorSampleable c =>  Sampler2DArray (Format c)     -> SampleOffset2 x -> S x Level -> V3 (S x Int) -> ColorSample x c
+texelFetch3D        :: forall c x. ColorSampleable c =>  Sampler3D (Format c)          -> SampleOffset3 x -> S x Level -> V3 (S x Int) -> ColorSample x c
+
+texelFetch1D (Sampler1D sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "1D" sampId lod off coord iv1toF civ1toF
+texelFetch1DArray (Sampler1DArray sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "1DArray" sampId lod off coord iv2toF civ1toF
+texelFetch2D (Sampler2D sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "2D" sampId lod off coord iv2toF civ2toF
+texelFetch2DArray (Sampler2DArray sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "2DArray" sampId lod off coord iv3toF civ2toF
+texelFetch3D (Sampler3D sampId _ prefix) off lod coord = toColor (undefined :: c) $ fetch (undefined :: ColorElement c) prefix (typeStr4 (undefined :: c)) "3D" sampId lod off coord iv3toF civ3toF
+
+sampler1DSize      :: Sampler1D f -> S x Level -> S x Int
+sampler1DArraySize :: Sampler1DArray f -> S x Level -> V2 (S x Int)
+sampler2DSize      :: Sampler2D f -> S x Level -> V2 (S x Int)
+sampler2DArraySize :: Sampler2DArray f -> S x Level -> V3 (S x Int)
+sampler3DSize      :: Sampler3D f -> S x Level -> V3 (S x Int)
+samplerCubeSize    :: SamplerCube f -> S x Level -> S x Int
+
+sampler1DSize (Sampler1D sampId shadow prefix) = scalarS STypeInt . getTextureSize prefix sampId (addShadowPrefix shadow "1D")
+sampler1DArraySize (Sampler1DArray sampId shadow prefix) = vec2S (STypeIVec 2) . getTextureSize prefix sampId (addShadowPrefix shadow "1DArray")
+sampler2DSize (Sampler2D sampId shadow prefix) = vec2S (STypeIVec 2) . getTextureSize prefix sampId (addShadowPrefix shadow "2D")
+sampler2DArraySize (Sampler2DArray sampId shadow prefix) = vec3S (STypeIVec 3) . getTextureSize prefix sampId (addShadowPrefix shadow "2DArray")
+sampler3DSize (Sampler3D sampId shadow prefix) = vec3S (STypeIVec 3) . getTextureSize prefix sampId (addShadowPrefix shadow "3D")
+samplerCubeSize (SamplerCube sampId shadow prefix) = (\(V2 x _) -> x) . vec2S (STypeIVec 2) . getTextureSize prefix sampId (addShadowPrefix shadow "Cube")    
+
+addShadowPrefix :: Bool -> String -> String
+addShadowPrefix shadow = if shadow then (++ "Shadow") else id 
+
+getTextureSize :: String -> Int -> String -> S c Int -> ExprM String
+getTextureSize prefix sampId sName l = do s <- useSampler prefix sName sampId  
+                                          l' <- unS l
+                                          return $ "textureSize(" ++ s ++ ',' : l' ++ ")"
+
+sample :: e -> String -> String -> String -> Int -> SampleLod lcoord x -> SampleProj x -> Maybe off -> coord -> (coord -> ExprM String) -> (lcoord -> ExprM String) -> (off -> String) -> (coord -> S x Float -> ExprM String) -> V4 (S x e)  
+sample _ prefix sDynType sName sampId lod proj off coord vToS lvToS ivToS pvToS =
+    vec4S (STypeDyn sDynType) $ do s <- useSampler prefix sName sampId
+                                   sampleFunc s proj lod off coord vToS lvToS ivToS pvToS 
+
+sampleShadow :: String -> Int -> SampleLod lcoord x -> SampleProj x -> Maybe off -> coord -> (coord -> ExprM String) -> (lcoord -> ExprM String) -> (off -> String) -> (coord -> S x Float -> ExprM String) -> S x Float  
+sampleShadow sName sampId lod proj off coord vToS lvToS civToS pvToS =
+    scalarS STypeFloat $ do s <- useSampler "" (sName ++ "Shadow") sampId
+                            sampleFunc s proj lod off coord vToS lvToS civToS pvToS 
+
+fetch :: e -> String -> String -> String -> Int -> S x Int -> Maybe off -> coord -> (coord -> ExprM String) -> (off -> String) -> V4 (S x e)  
+fetch _ prefix sDynType sName sampId lod off coord ivToS civToS =
+    vec4S (STypeDyn sDynType) $ do s <- useSampler prefix sName sampId
+                                   fetchFunc s off coord lod ivToS civToS
+
+v1toF :: S c Float -> ExprM String
+v2toF :: V2 (S c Float) -> ExprM String
+v3toF :: V3 (S c Float) -> ExprM String
+v4toF :: V4 (S c Float) -> ExprM String
+v1toF = unS
+v2toF (V2 x y) = do x' <- unS x
+                    y' <- unS y
+                    return $ "vec2(" ++ x' ++ ',':y' ++ ")"   
+v3toF (V3 x y z) = do x' <- unS x
+                      y' <- unS y
+                      z' <- unS z
+                      return $ "vec3(" ++ x' ++ ',':y' ++ ',':z' ++ ")"   
+v4toF (V4 x y z w) = do x' <- unS x
+                        y' <- unS y
+                        z' <- unS z
+                        w' <- unS w
+                        return $ "vec4(" ++ x' ++ ',':y' ++ ',':z' ++ ',':w' ++ ")"
+
+iv1toF :: S c Int -> ExprM String
+iv2toF :: V2 (S c Int) -> ExprM String
+iv3toF :: V3 (S c Int) -> ExprM String
+iv1toF = unS
+iv2toF (V2 x y) = do x' <- unS x
+                     y' <- unS y
+                     return $ "ivec2(" ++ x' ++ ',':y' ++ ")"   
+iv3toF (V3 x y z) = do x' <- unS x
+                       y' <- unS y
+                       z' <- unS z
+                       return $ "ivec3(" ++ x' ++ ',':y' ++ ',':z' ++ ")"   
+                                                
+civ1toF :: Int -> String
+civ2toF :: V2 Int -> String
+civ3toF :: V3 Int -> String
+civ1toF = show   
+civ2toF (V2 x y) = "ivec2(" ++ show x ++ ',':show y ++ ")"   
+civ3toF (V3 x y z) = "ivec3(" ++ show x ++ ',':show y ++ ',':show z ++ ")"   
+pv1toF :: S c Float -> S c Float -> ExprM String
+pv2toF :: V2 (S c Float) -> S c Float -> ExprM String
+pv3toF :: V3 (S c Float) -> S c Float -> ExprM String
+
+pv1toF x y = do x' <- unS x
+                y' <- unS y
+                return $ "vec2(" ++ x' ++ ',':y' ++ ")"
+pv2toF (V2 x y) z = do x' <- unS x
+                       y' <- unS y
+                       z' <- unS z
+                       return $ "vec3(" ++ x' ++ ',':y' ++ ',':z' ++ ")"
+pv3toF (V3 x y z) w = do x' <- unS x
+                         y' <- unS y
+                         z' <- unS z
+                         w' <- unS w
+                         return $ "vec4(" ++ x' ++ ',':y' ++ ',':z' ++  ',':w' ++ ")"
+
+sampleFunc s proj lod off coord vToS lvToS civToS pvToS = do
+    pc <- projCoordParam proj  
+    l <- lodParam lod 
+    b <- biasParam lod
+    return $ "texture" ++ projName proj ++ lodName lod ++ offName off ++ '(' : s ++ ',' : pc ++ l ++ o ++ b ++ ")"  
+  where 
+    o = offParam off civToS 
+    
+    projName Nothing = ""
+    projName _ = "Proj"
+
+    projCoordParam Nothing = vToS coord
+    projCoordParam (Just p) = pvToS coord p
+    
+    lodParam (SampleLod x) = fmap (',':) (unS x)
+    lodParam (SampleGrad x y) = (++) <$> fmap (',':) (lvToS x) <*> fmap (',':) (lvToS y)
+    lodParam _ = return ""
+    
+    biasParam :: SampleLod v x -> ExprM String 
+    biasParam (SampleBias (S x)) = do x' <- x
+                                      return $ ',':x'
+    biasParam _ = return ""    
+       
+    lodName (SampleLod _) = "Lod"
+    lodName (SampleGrad _ _) = "Grad"
+    lodName _ = ""
+    
+fetchFunc s off coord lod vToS civToS = do
+    c <- vToS coord 
+    l <- unS lod 
+    return $ "fetch" ++ offName off ++ '(' : s ++ ',' : c ++ ',': l ++ o ++ ")"  
+  where 
+    o = offParam off civToS
+        
+offParam :: Maybe t -> (t -> String) -> String
+offParam Nothing _ = ""
+offParam (Just x) civToS = ',' : civToS x
+
+offName :: Maybe t -> String
+offName Nothing = ""
+offName _ = "Offset"
+
+----------------------------------------------------------------------------------
+
+-- | A texture image is a reference to a 2D array of pixels in a texture. Some textures contain one 'Image' per level of detail while some contain several. 
+data Image f = Image TexName Int Int (V2 Int) (GLuint -> IO ()) -- the two Ints is last two in FBOKey
+
+instance Eq (Image f) where
+    (==) = imageEquals 
+
+-- | Compare two images that doesn't necessarily has same type
+imageEquals :: Image a -> Image b -> Bool
+imageEquals (Image tn' k1' k2' _ _) (Image tn k1 k2 _ _) = tn' == tn && k1' == k1 && k2' == k2
+
+getImageBinding :: Image t -> GLuint -> IO ()
+getImageBinding (Image _ _ _ _ io) = io
+
+getImageFBOKey :: Image t -> IO FBOKey
+getImageFBOKey (Image tn k1 k2 _ _) = do tn' <- readIORef tn
+                                         return $ FBOKey tn' k1 k2 
+-- | Retrieve the 2D size an image
+imageSize :: Image f -> V2 Int
+imageSize (Image _ _ _ s _) = s
+
+getTexture1DImage :: Texture1D os f -> Level -> Render os f' (Image f) 
+getTexture1DArrayImage :: Texture1DArray os f -> Level -> Int -> Render os f' (Image f) 
+getTexture2DImage :: Texture2D os f -> Level -> Render os f' (Image f) 
+getTexture2DArrayImage :: Texture2DArray os f -> Level -> Int -> Render os f' (Image f) 
+getTexture3DImage :: Texture3D os f -> Level -> Int -> Render os f' (Image f) 
+getTextureCubeImage :: TextureCube os f -> Level -> CubeSide -> Render os f' (Image f) 
+
+getTexture1DImage t@(Texture1D tn _ ls) l' = let l = min ls l' in return $ Image tn 0 l (V2 (texture1DSizes t !! l) 1) $ \attP -> do { n <- readIORef tn; glFramebufferTexture1D GL_DRAW_FRAMEBUFFER attP GL_TEXTURE_1D n (fromIntegral l) }
+getTexture1DArrayImage t@(Texture1DArray tn _ ls) l' y' = let l = min ls l' 
+                                                              V2 x y = texture1DArraySizes t !! l 
+                                                          in return $ Image tn y' l (V2 x 1) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min y' (y-1)) }
+getTexture2DImage t@(Texture2D tn _ ls) l' = let l = min ls l' in return $ Image tn 0 l (texture2DSizes t !! l) $ \attP -> do { n <- readIORef tn; glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attP GL_TEXTURE_2D n (fromIntegral l) }
+getTexture2DImage t@(RenderBuffer2D tn _) _ = return $ Image tn (-1) 0 (head $ texture2DSizes t) $ \attP -> do { n <- readIORef tn; glFramebufferRenderbuffer GL_DRAW_FRAMEBUFFER attP GL_RENDERBUFFER n }
+getTexture2DArrayImage t@(Texture2DArray tn _ ls) l' z' = let l = min ls l' 
+                                                              V3 x y z = texture2DArraySizes t !! l 
+                                                          in return $ Image tn z' l (V2 x y) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min z' (z-1)) } 
+getTexture3DImage t@(Texture3D tn _ ls) l' z' = let l = min ls l' 
+                                                    V3 x y z = texture3DSizes t !! l 
+                                                in return $ Image tn z' l (V2 x y) $ \attP -> do { n <- readIORef tn; glFramebufferTextureLayer GL_DRAW_FRAMEBUFFER attP n (fromIntegral l) (fromIntegral $ min z' (z-1)) }
+getTextureCubeImage t@(TextureCube tn _ ls) l' s = let l = min ls l' 
+                                                       x = textureCubeSizes t !! l
+                                                       s' = getGlCubeSide s
+                                                   in return $ Image tn (fromIntegral s') l (V2 x x) $ \attP -> do { n <- readIORef tn; glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attP s' n (fromIntegral l) }
+
+getGlCubeSide :: CubeSide -> GLenum
+getGlCubeSide CubePosX = GL_TEXTURE_CUBE_MAP_POSITIVE_X 
+getGlCubeSide CubeNegX = GL_TEXTURE_CUBE_MAP_NEGATIVE_X 
+getGlCubeSide CubePosY = GL_TEXTURE_CUBE_MAP_POSITIVE_Y
+getGlCubeSide CubeNegY = GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
+getGlCubeSide CubePosZ = GL_TEXTURE_CUBE_MAP_POSITIVE_Z
+getGlCubeSide CubeNegZ = GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
+
+
+
+

@@ -0,0 +1,182 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, GADTs, TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances, GeneralizedNewtypeDeriving, Arrows, MultiParamTypeClasses, AllowAmbiguousTypes #-}
+
+module Graphics.GPipe.Internal.Uniform where
+
+import Graphics.GPipe.Internal.Buffer 
+import Graphics.GPipe.Internal.Shader
+import Graphics.GPipe.Internal.Compiler
+import Graphics.GPipe.Internal.Expr
+import Control.Arrow
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class (lift)
+import Control.Category hiding ((.))
+import qualified Data.IntMap as Map
+import Data.IntMap.Lazy (insert)
+import Data.Word
+
+import Graphics.GL.Core33
+import Data.IORef
+import Data.Int
+import Linear.V4
+import Linear.V3
+import Linear.V2
+import Linear.V1
+import Linear.V0
+
+-- | This class constraints which buffer types can be loaded as uniforms, and what type those values have.  
+class BufferFormat a => UniformInput a where
+    -- | The type the buffer value will be turned into once it becomes a vertex or fragment value (the @x@ parameter is either 'V' or 'F'). 
+    type UniformFormat a x
+    -- | An arrow action that turns a value from it's buffer representation to it's vertex or fragment representation. Use 'toUniform' from
+    --   the GPipe provided instances to operate in this arrow. Also note that this arrow needs to be able to return a value
+    --   lazily, so ensure you use
+    -- 
+    --  @proc ~pattern -> do ...@. 
+    toUniform :: ToUniform x a (UniformFormat a x) 
+
+-- | Load a uniform value from a 'Buffer' into a 'Shader'. The argument function is used to retrieve the buffer and the index into this buffer from the shader environment. 
+getUniform :: forall os f s b x. (UniformInput b) => (s -> (Buffer os (Uniform b), Int)) -> Shader os f s (UniformFormat b x)
+getUniform sf = Shader $ do
+                   uniAl <- askUniformAlignment 
+                   blockId <- getName
+                   let (u, offToStype) = shaderGen (useUniform (buildUDecl offToStype) blockId)
+                       sampleBuffer = makeBuffer undefined undefined uniAl :: Buffer os (Uniform b)
+                       shaderGen :: (Int -> ExprM String) -> (UniformFormat b x, OffsetToSType) -- Int is name of uniform block
+                       shaderGen = runReader $ runWriterT $ shaderGenF $ fromBUnifom $ bufBElement sampleBuffer $ BInput 0 0
+                   doForUniform blockId $ \s bind -> let (ub, i) = sf s 
+                                                     in if i < 0 || i >= bufferLength ub 
+                                                            then error "toUniformBlock, uniform buffer offset out of bounds"
+                                                            else do
+                                                                bname <- readIORef $ bufName ub
+                                                                glBindBufferRange GL_UNIFORM_BUFFER (fromIntegral bind) bname (fromIntegral $ i * bufElementSize ub) (fromIntegral $ bufElementSize ub)
+                   return u
+    where
+            ToUniform (Kleisli shaderGenF) = toUniform :: ToUniform x b (UniformFormat b x)
+            fromBUnifom (Uniform b) = b
+
+            doForUniform :: Int -> (s -> Binding -> IO()) -> ShaderM s ()
+            doForUniform n io = modifyRenderIO (\s -> s { uniformNameToRenderIO = insert n io (uniformNameToRenderIO s) } )
+
+buildUDecl :: OffsetToSType -> GlobDeclM ()
+buildUDecl = buildUDecl' 0 . Map.toAscList 
+    where buildUDecl' p xxs@((off, stype):xs) | off == p = do tellGlobal $ stypeName stype
+                                                              tellGlobal " u"
+                                                              tellGlobalLn $ show off
+                                                              buildUDecl' (p + stypeSize stype) xs
+                                              | off > p = do tellGlobal "float pad"
+                                                             tellGlobalLn $ show p
+                                                             buildUDecl' (p + 4) xxs
+                                              | otherwise = error "buildUDecl: Expected all offsets to be multiple of 4"
+          buildUDecl' _ [] = return ()
+
+type OffsetToSType = Map.IntMap SType  
+                    
+-- | The arrow type for 'toUniform'.
+newtype ToUniform x a b = ToUniform (Kleisli (WriterT OffsetToSType (Reader (Int -> ExprM String))) a b) deriving (Category, Arrow) 
+
+makeUniform :: SType -> ToUniform x (B a) (S x b)
+makeUniform styp = ToUniform $ Kleisli $ \bIn -> do let offset = bOffset bIn
+                                                    tell $ Map.singleton offset styp
+                                                    useF <- lift ask
+                                                    return $ S $ useF offset
+
+instance UniformInput (B Float) where
+    type UniformFormat (B Float) x = (S x Float)
+    toUniform = makeUniform STypeFloat
+
+instance UniformInput (B Int32) where
+    type UniformFormat (B Int32) x = (S x Int)
+    toUniform = makeUniform STypeInt
+
+instance UniformInput (B Word32) where
+    type UniformFormat (B Word32) x = (S x Word)
+    toUniform = makeUniform STypeUInt
+
+instance UniformInput (B2 Float) where
+    type UniformFormat (B2 Float) x = V2 (S x Float)
+    toUniform = arr unB2 >>> makeUniform (STypeVec 2) >>> arr vec2S''
+
+instance UniformInput (B2 Int32) where
+    type UniformFormat (B2 Int32) x = V2 (S x Int)
+    toUniform = arr unB2 >>> makeUniform (STypeIVec 2) >>> arr vec2S''
+
+instance UniformInput (B2 Word32) where
+    type UniformFormat (B2 Word32) x = V2 (S x Word)
+    toUniform = arr unB2 >>> makeUniform (STypeVec 2) >>> arr vec2S''
+
+instance UniformInput (B3 Float) where
+    type UniformFormat (B3 Float) x = V3 (S x Float)
+    toUniform = arr unB3 >>> makeUniform (STypeVec 3) >>> arr vec3S''
+
+instance UniformInput (B3 Int32) where
+    type UniformFormat (B3 Int32) x = V3 (S x Int)
+    toUniform = arr unB3 >>> makeUniform (STypeIVec 3) >>> arr vec3S''
+
+instance UniformInput (B3 Word32) where
+    type UniformFormat (B3 Word32) x = V3 (S x Word)
+    toUniform = arr unB3 >>> makeUniform (STypeVec 3) >>> arr vec3S''
+
+instance UniformInput (B4 Float) where
+    type UniformFormat (B4 Float) x = V4 (S x Float)
+    toUniform = arr unB4 >>> makeUniform (STypeVec 4) >>> arr vec4S''
+
+instance UniformInput (B4 Int32) where
+    type UniformFormat (B4 Int32) x = V4 (S x Int)
+    toUniform = arr unB4 >>> makeUniform (STypeIVec 4) >>> arr vec4S''
+
+instance UniformInput (B4 Word32) where
+    type UniformFormat (B4 Word32) x = V4 (S x Word)
+    toUniform = arr unB4 >>> makeUniform (STypeVec 4) >>> arr vec4S''
+
+
+instance UniformInput a => UniformInput (V0 a) where
+    type UniformFormat (V0 a) x = V0 (UniformFormat a x)
+    toUniform = arr (const V0)
+
+instance UniformInput a => UniformInput (V1 a) where
+    type UniformFormat (V1 a) x = V1 (UniformFormat a x)
+    toUniform = proc ~(V1 a) -> do a' <- toUniform -< a
+                                   returnA -< V1 a'
+
+instance UniformInput a => UniformInput (V2 a) where
+    type UniformFormat (V2 a) x = V2 (UniformFormat a x)
+    toUniform = proc ~(V2 a b) -> do a' <- toUniform -< a
+                                     b' <- toUniform -< b
+                                     returnA -< V2 a' b'
+
+instance UniformInput a => UniformInput (V3 a) where
+    type UniformFormat (V3 a) x = V3 (UniformFormat a x)
+    toUniform = proc ~(V3 a b c) -> do a' <- toUniform -< a
+                                       b' <- toUniform -< b
+                                       c' <- toUniform -< c
+                                       returnA -< V3 a' b' c'
+
+instance UniformInput a => UniformInput (V4 a)  where
+    type UniformFormat (V4 a) x = V4 (UniformFormat a x)
+    toUniform = proc ~(V4 a b c d) -> do a' <- toUniform -< a
+                                         b' <- toUniform -< b
+                                         c' <- toUniform -< c
+                                         d' <- toUniform -< d
+                                         returnA -< V4 a' b' c' d'                                                   
+
+instance (UniformInput a, UniformInput b) => UniformInput (a,b) where
+    type UniformFormat (a,b) x = (UniformFormat a x, UniformFormat b x)
+    toUniform = proc ~(a,b) -> do a' <- toUniform -< a
+                                  b' <- toUniform -< b
+                                  returnA -< (a', b')
+
+instance (UniformInput a, UniformInput b, UniformInput c) => UniformInput (a,b,c) where
+    type UniformFormat (a,b,c) x = (UniformFormat a x, UniformFormat b x, UniformFormat c x)
+    toUniform = proc ~(a,b,c) -> do a' <- toUniform -< a
+                                    b' <- toUniform -< b
+                                    c' <- toUniform -< c
+                                    returnA -< (a', b', c')
+
+instance (UniformInput a, UniformInput b, UniformInput c, UniformInput d) => UniformInput (a,b,c,d)  where
+    type UniformFormat (a,b,c,d) x = (UniformFormat a x, UniformFormat b x, UniformFormat c x, UniformFormat d x)
+    toUniform = proc ~(a,b,c,d) -> do a' <- toUniform -< a
+                                      b' <- toUniform -< b
+                                      c' <- toUniform -< c
+                                      d' <- toUniform -< d
+                                      returnA -< (a', b', c', d')                                                   

@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.PrimitiveArray
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- | PrimitiveArrays (aka VAOs in OpenGl) are the main input to compiled shaders. A primitive array is created from one or more zipped vertex arrays.
+--   A primitive array may also be instanced, using one or more zipped vertex arrays as instance arrays. And lastly, an index array may also be used to pick vertices for the primitive array.   
+--
+--   Any possible combination of interleaved or non-interleaved vertex buffers may be used, for example:
+--
+--  Buffer @a@ = @{(A,B),(A,B),(A,B)...}@
+--  Buffer @b@ = @{(X,Y,Z),(X,Y,Z),(X,Y,Z),...}@
+--
+--  @
+--   do
+--      aArr <- newVertexArray a        
+--      bArr <- newVertexArray b 
+--      let primArr = toPrimitiveArray TriangleList (zipVertices (\(a,b) y -> (a,b,y)) aArr (fmap (\(_,y,_) -> y) bArr))
+--  @
+--  
+--  will create a primitive array @primArr@ with this layout: @{(A,B,Y),(A,B,Y),(A,B,Y)...}@
+-----------------------------------------------------------------------------
+module Graphics.GPipe.PrimitiveArray (          
+    -- * Vertex arrays
+    VertexArray(),
+    Instances,
+    newVertexArray,
+    vertexArrayLength,
+    zipVertices,
+    Combine,
+    takeVertices,
+    dropVertices,
+    replicateEach,
+    
+    -- * Index arrays
+    IndexArray(),    
+    newIndexArray,
+    IndexFormat,
+    indexArrayLength,
+    takeIndices,
+    dropIndices,
+   
+    -- * Primitive arrays
+    PrimitiveArray(),   
+    PrimitiveTopology(..),
+    Triangles,
+    Lines,
+    Points,    
+    toPrimitiveArray,
+    toPrimitiveArrayIndexed,
+    toPrimitiveArrayInstanced,
+    toPrimitiveArrayIndexedInstanced,
+
+    -- * Operations on buffer values
+    -- | You may split up a @B4 a@, @B3 a@ and @B2 a@ value into its components, if the parts are representable buffer types (e.g. due to alignment, you may for instance not split a @B4 Word8@).
+    --   Note that there are no functions to combine smaller parts together again. 
+    toB22, toB3, toB21, toB12, toB11,
+)
+where
+
+import Graphics.GPipe.Internal.PrimitiveArray
+import Graphics.GPipe.Internal.Buffer

@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.PrimitiveStream
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- A 'Graphics.GPipe.PrimitiveArray.PrimitiveArray' can be turned into a 'PrimitiveStream' in a 'Graphics.GPipe.Shader.Shader', in order to operate on the vertices of it and ultimately rasterize it into
+-- a 'Graphics.GPipe.FragmentStream.FragmentStream'.
+
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe.PrimitiveStream (
+    -- * The data type
+    PrimitiveStream(),
+    VertexInput(..),
+    ToVertex(),
+
+    -- * Creating PrimitiveStreams
+    toPrimitiveStream,
+   
+    -- * Various PrimitiveStream operations   
+    withInputIndices,   
+    InputIndices(..),
+)
+where
+
+import Graphics.GPipe.Internal.PrimitiveStream 

@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.Sampler
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- A sampler is a value from which filtered color samples may be taken inside a shader. A sampler is created from a texture and some sampling parameters. There also exist
+-- 'Shadow' samplers that doesnt return a sampled color value, but instead compare a reference value to the texture value.  
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe.Sampler (
+    -- * Sampler data types
+    Sampler1D(), Sampler1DArray(), Sampler2D(), Sampler2DArray(), Sampler3D(), SamplerCube(),
+    Shadow,
+
+    -- * Creating samplers
+    -- | These 'Shader' actions all take a texture and some filtering and edge options from the shader environment, and return a sampler. 
+    newSampler1D, newSampler1DArray, newSampler2D, newSampler2DArray, newSampler3D, newSamplerCube,
+    newSampler1DShadow, newSampler1DArrayShadow, newSampler2DShadow, newSampler2DArrayShadow, newSamplerCubeShadow,
+
+    -- * Types for specifying sampler filter and edge mode
+    Filter(..),
+    EdgeMode(..),
+    EdgeMode2, 
+    EdgeMode3,
+    BorderColor,
+    Anisotropy,
+    MinFilter,
+    MagFilter,
+    LodFilter,
+    SamplerFilter(..),
+    ComparisonFunction(..),
+    
+    -- * Sampler properties
+    -- | These functions can be used to get the size of a sampler inside the shader.
+    sampler1DSize, sampler1DArraySize, sampler2DSize, sampler2DArraySize, sampler3DSize, samplerCubeSize,
+   
+    -- * Sampling functions
+    -- | These functions sample a sampler using its filter and edge mode. Besides the sampler and the coordinate, many additional parameters are provided to enable many
+    --   different variations of sampling. In most cases when sampling in a 'FragmentStream', use 'Nothing' or 'SampleAuto' to get what you need.
+    --   Float coordinates are given with components in range [0,1]. 
+    sample1D, sample1DArray, sample2D, sample2DArray, sample3D, sampleCube,
+    -- | The following functions sample a shadow sampler using a 'ReferenceValue' to compare the texture values to. The returned value is a @S x Float@ value in the range [0,1] where 0 means false, 1 means true and any value in between is a fuzzy boolean value indicating how many adjacent texels compared true and how many compared false.
+    sample1DShadow, sample1DArrayShadow, sample2DShadow, sample2DArrayShadow, sampleCubeShadow, 
+    -- | The following functions retrieve a texel value from a samplers texture without using any filtering. Coordinates for these functions are integer texel indices, and not normalized coordinates.
+    texelFetch1D, texelFetch1DArray, texelFetch2D, texelFetch2DArray, texelFetch3D,   
+
+    -- * Sample parameter types
+    SampleLod(..), 
+    SampleLod1, 
+    SampleLod2, 
+    SampleLod3, 
+    SampleLod'(..), 
+    SampleLod2', 
+    SampleLod3',
+    fromLod',
+    SampleProj,
+    SampleOffset1,
+    SampleOffset2,
+    SampleOffset3, 
+    ReferenceValue,
+    ColorSample,
+)
+where
+
+import Graphics.GPipe.Internal.Texture
+

@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.Shader
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- A 'Shader' is a monad in which 'PrimitiveStream's and 'FragmentStream's live, together with samplers and uniform values. Any computations made on the streams and values in 
+-- the 'Shader' monad will be performed on the GPU. A 'Shader' needs to be compiled before it can be used. In order to make it work over different environments after it
+-- has been compiled, it closes over an environment value just like a 'Reader' monad, with the distinction that there is no 'ask' action, since we cannot make the
+-- actual monad operation depend on the environment.
+--
+-- A 'Shader' is an instance of 'Alternative' and 'MonadPlus' which makes it possible to express choice with functions like 'guard'. The left most alternative will always be the
+-- resulting monad.
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe.Shader (
+    -- * The Shader monad
+    Shader(),
+    compileShader,
+    withoutContext,
+    CompiledShader,
+
+    -- * The Render monad
+    Render(), 
+    render,
+        
+    -- * Shader monad combinators
+    guard',
+    mapShader,
+    maybeShader,
+    chooseShader,
+    silenceShader
+)
+where
+
+import Graphics.GPipe.Internal.Context
+import Graphics.GPipe.Internal.Shader 

@@ -1,36 +0,0 @@------------------------------------------------------------------------------------ Module      :  Graphics.GPipe.Stream--- Copyright   :  Tobias Bexelius--- License     :  BSD3------ Maintainer  :  Tobias Bexelius--- Stability   :  Experimental--- Portability :  Portable------ | A GPipe program mainly consits of creating and manipulating streams of primitives and fragments.--- The modules "Graphics.GPipe.Stream.Primitive" and "Graphics.GPipe.Stream.Fragment" defines those streams.------ All atomic values except textures in streams uses the 'Vertex' or 'Fragment' type constructors.--- Composite types are created by composing the atomic 'Vertex' or 'Fragment' types, rather than wrapping the--- composite type in any of those type constructors. This module provides the common classes for those atomic types,--- as well as reexports of imported common types and modules.--------------------------------------------------------------------------------module Graphics.GPipe.Stream (-    -- * Common classes-    Shader(),-    GPU(..),-    Real'(..),-    Convert(..),-    -- * Reexports-    (:.)(..),Vec2,Vec3,Vec4,-    module Data.Vec.LinAlg,          -    module Data.Boolean-) where--import Shader-import Data.Boolean-import Data.Vec-import Data.Vec.LinAlg-import Data.Vec.Boolean()

@@ -1,63 +0,0 @@------------------------------------------------------------------------------------ Module      :  Graphics.GPipe.Stream.Fragment--- Copyright   :  Tobias Bexelius--- License     :  BSD3------ Maintainer  :  Tobias Bexelius--- Stability   :  Experimental--- Portability :  Portable------ | 'FragmentStream's implement the 'Functor' class, which provides the--- 'fmap' method that you can use to manipulate those streams. This corresponds to writing and using--- fragment shaders, but in a much more modular way. You may for instance apply 'fmap'--- several times in a sequence, effectively creating complex shaders.------ Instances are also provided for the 'Monoid' class, so several streams (of the same type) can be--- concatenated. The order is preserved, meaning that the fragments in stream @a@ in @a `mappend` b@ will be--- drawn before the fragments in @b@.------ All atomic values except textures in fragment streams uses the 'Fragment' type constructor.--- Composite types are created by composing the atomic 'Fragment' types, rather than wrapping the--- composite type in the 'Fragment' type constructors.------ 'Fragment' instances for are provided for most of Prelude's numerical classes. Since 'Eq', 'Ord'--- and 'Show' are prerequisites for these classes, instances are provided for them too, even though--- their methods all will generate errors if used (except 'min' and 'max'). Use the instances of--- 'EqB', 'OrdB' and 'IfB' from the Boolean package if you want to compare 'Fragment' values.--- Hyperbolic trigonometrical functions aren't provided either.------ Rewrite rule specializations are provided for the Vec package functions 'norm', 'normalize',--- 'dot' and 'cross' on vectors of 'Fragment' 'Float', so the use of these functions (and others--- from that package that is defined in terms of them) are highly encouraged.---------------------------------------------------------------------------------module Graphics.GPipe.Stream.Fragment (-    -- * Data types-    FragmentStream(),-    F,-    Fragment,--    -- * Various fragment functions-    dFdx,-    dFdy,-    fwidth,-    filterFragments,--    -- * Creating fragment streams-    VertexOutput(..),-    Rasterizer(),-    VertexPosition,-    -- | When using the @rasterize@ functions, give the vertices positions in canonical view space, i.e. where @x@, @y@ and @z@-    -- is in the interval @[-1, 1]@. These aren't interpolated back to the fragments by default, so you-    -- must duplicate these positions into the vertices interpolated values if you need them in the fragments (which is very unusual).-    rasterizeFront,-    rasterizeBack,-    rasterizeFrontAndBack,-) where--import Shader-import GPUStream-import Rasterizer-

@@ -1,61 +0,0 @@------------------------------------------------------------------------------------ Module      :  Graphics.GPipe.Stream.Primitive--- Copyright   :  Tobias Bexelius--- License     :  BSD3------ Maintainer  :  Tobias Bexelius--- Stability   :  Experimental--- Portability :  Portable------ | 'PrimitiveStream's implement the 'Functor' class, which provides the--- 'fmap' method that you can use to manipulate those streams. This corresponds to writing and using--- vertex shaders, but in a much more modular way. You may for instance apply 'fmap'--- several times in a sequence, effectively creating complex shaders.------ Instances are also provided for the 'Monoid' class, so several streams (of the same type) can be--- concatenated. The order is preserved, meaning that the primitives in stream @a@ in @a `mappend` b@ will be--- drawn before the primitives in @b@.------ All atomic values except textures in vertex streams uses the 'Vertex' type constructor.--- Composite types are created by composing the atomic 'Vertex' types, rather than wrapping the--- composite type in the 'Vertex' type constructors.------ 'Vertex' instances for are provided for most of Prelude's numerical classes. Since 'Eq', 'Ord'--- and 'Show' are prerequisites for these classes, instances are provided for them too, even though--- their methods all will generate errors if used (except 'min' and 'max'). Use the instances of--- 'EqB', 'OrdB' and 'IfB' from the Boolean package if you want to compare 'Vertex' values.--- Hyperbolic trigonometrical functions aren't provided either.------ Rewrite rule specializations are provided for the Vec package functions 'norm', 'normalize',--- 'dot' and 'cross' on vectors of 'Vertex' 'Float', so the use of these functions (and others--- from that package that is defined in terms of them) are highly encouraged.--------------------------------------------------------------------------------module Graphics.GPipe.Stream.Primitive (-    -- * Data types-    PrimitiveStream(),-    V,-    Vertex,--    -- * Creating primitive streams-    VertexInput(..),-    InputAssembler(),-    Triangle(..),-    Line(..),-    Point(..),-    Primitive(),-    toGPUStream,-    toIndexedGPUStream,  -) where---import Shader-import GPUStream-import InputAssembler------

@@ -1,46 +1,104 @@------------------------------------------------------------------------------------ Module      :  Graphics.GPipe.Texture--- Copyright   :  Tobias Bexelius--- License     :  BSD3------ Maintainer  :  Tobias Bexelius--- Stability   :  Experimental--- Portability :  Portable------ | Textures are type safe in GPipe, e.g. when you sample a @RGBFormat@ texture, you get an @RGB@ value.------ Textures are either created directly from memory, or by giving a framebuffer a concrete size (which--- it otherwise don't have). The latter is however not possible for 3D textures.------ Depth textures are textures that contains depth component data (of type @DepthFormat@) but takes the type--- of @LuminanceFormat@ or @AlphaFormat@ textures, and are sampled as such.-----------------------------------------------------------------------------------module Graphics.GPipe.Texture (-    -- * Data types-    Texture3D(),-    Texture2D(),-    Texture1D(),-    TextureCube(),-    -- * Operation-    Texture(..),-    -- * Creation-    newTexture,-    newDepthTexture,-    FromFrameBufferColor(..),-    FromFrameBufferDepth(..),-    DepthColorFormat(),-    fromFrameBufferCubeColor,-    fromFrameBufferCubeDepth,-    -- * Samplers-    Sampler(..),-    Filter(..),-    EdgeMode(..),   -) where--import Resources-import Textures--+-----------------------------------------------------------------------------
+--
+-- Module      :  Graphics.GPipe.Texture
+-- Copyright   :  Tobias Bexelius
+-- License     :  MIT
+--
+-- Maintainer  :  Tobias Bexelius
+-- Stability   :  Experimental
+-- Portability :  Portable
+--
+-- |
+-- A texture is a spatially arranged map of pixels that resides on the GPU. A texture can be a 1D, 2D or 3D image, or an array of several same sized 1D or 2D images, or a cube map with six square images.
+-- A texture may also have several levels of detail, in decreasing size.
+--
+-- A texture has a strongly typed format and immutable size and number of levels, but its content is mutable. A texture lives in
+-- an object space and may be shared between contexts.
+--
+-- The main purpose for a texture is to be sampled in a 'Shader', by turning it into a sampler object (See 'Graphics.Gpipe.Sampler.Sampler1D' and friends). A texture may
+-- also be used as a render target into which 'Graphics.Gpipe.FragmentStream.FragmentStream's are drawn, thus generating the texture on the GPU. To that end, a texture may not only be written
+-- from the host (i.e. the normal Haskell world) but also read back.
+-----------------------------------------------------------------------------
+
+module Graphics.GPipe.Texture (
+    -- * Texture data types
+    Texture1D(), Texture1DArray(), Texture2D(), Texture2DArray(), Texture3D(), TextureCube(), 
+    CubeSide(..),
+
+    -- * Creating textures
+    -- | All of these functions take a format and a texture size in the dimensionality of the specific texture type. It also takes a 'MaxLevels' parameter to limit number of
+    --   levels to be created. The maximum number of levels created is always constrained by the texture size, so using 'maxBound' will effectively create a texture with
+    --   maximum possible number of levels.  
+    newTexture1D,
+    newTexture1DArray,
+    newTexture2D,
+    newTexture2DArray,
+    newTexture3D,
+    newTextureCube,
+
+    -- * Texture properties
+    -- | The following functions retrieve number of levels a texture has. This number is always smaller or equal to the 'MaxLevels' parameter provided when the texture was created.
+    texture1DLevels, 
+    texture1DArrayLevels, 
+    texture2DLevels, 
+    texture2DArrayLevels, 
+    texture3DLevels, 
+    textureCubeLevels, 
+    -- | The following functions retrieve a list of texture sizes for each level of detail, from the largest to the smallest, where the first has the size as defined by the 'newTextureX' call. 
+    texture1DSizes, 
+    texture1DArraySizes, 
+    texture2DSizes, 
+    texture2DArraySizes, 
+    texture3DSizes, 
+    textureCubeSizes, 
+
+    -- * Writing texture data
+    -- | The following functions write the texture data from the host (i.e. the normal Haskell world), using a compatible 'Graphics.GPipe.Buffer.HostFormat' of the texture's format, see 'Graphics.GPipe.Buffer.BufferColor'.  
+    writeTexture1D,
+    writeTexture1DArray,
+    writeTexture2D,
+    writeTexture2DArray,
+    writeTexture3D,
+    writeTextureCube,    
+    -- | The following functions write the texture data using values in a 'Graphics.GPipe.Buffer.Buffer' with a format compatible with the texture's format, see 'Graphics.GPipe.Buffer.BufferColor'.
+    writeTexture1DFromBuffer,
+    writeTexture1DArrayFromBuffer,
+    writeTexture2DFromBuffer,
+    writeTexture2DArrayFromBuffer,
+    writeTexture3DFromBuffer,
+    writeTextureCubeFromBuffer,
+    -- | The following functions uses the level of detail 0 to generate all other levels of detail. The common pattern is to call this directly after a call to
+    --   'writeTextureX' where parameter 'Level' is 0.    
+    generateTexture1DMipmap,
+    generateTexture1DArrayMipmap,
+    generateTexture2DMipmap,
+    generateTexture2DArrayMipmap,
+    generateTexture3DMipmap,
+    generateTextureCubeMipmap,
+
+    -- * Reading texture data
+    -- | Read textures to the host (i.e. the normal Haskell world), using a compatible 'Graphics.GPipe.Buffer.HostFormat' of the texture's format, see 'Graphics.GPipe.Buffer.BufferColor'.
+    --   This works like any 'fold' like function.
+    readTexture1D,
+    readTexture1DArray,
+    readTexture2D,
+    readTexture2DArray,
+    readTexture3D,
+    readTextureCube,
+    
+    -- | The following read textures into a 'Graphics.GPipe.Buffer.Buffer' with a format compatible with the texture's format, see 'Graphics.GPipe.Buffer.BufferColor'.
+    readTexture1DToBuffer,
+    readTexture1DArrayToBuffer,
+    readTexture2DToBuffer,
+    readTexture2DArrayToBuffer,
+    readTexture3DToBuffer,
+    readTextureCubeToBuffer,
+    
+    -- * Type synonyms
+    MaxLevels, Level,
+    Size1, Size2, Size3,
+    StartPos1, StartPos2, StartPos3, 
+)
+where
+
+import Graphics.GPipe.Internal.Texture