14 files changed, 1359 insertions, 1126 deletions

diff --git a/Graphics/Glyph/ArrayGenerator.hs b/Graphics/Glyph/ArrayGenerator.hs
index 16fe41f..088ccc7 100644
--- a/Graphics/Glyph/ArrayGenerator.hs
+++ b/Graphics/Glyph/ArrayGenerator.hs
@@ -1,9 +1,9 @@
 {-# LANGUAGE UndecidableInstances #-}
-module Graphics.Glyph.ArrayGenerator where
 
-import qualified Data.Map as M
+module Graphics.Glyph.ArrayGenerator where
 
 import Data.Array
+import qualified Data.Map as M
 import Data.Maybe
 
 data ArrayTransaction ix val b = ArrayBuilderM_ (M.Map ix val) b
@@ -13,33 +13,36 @@ instance (Ord ix) => Functor (ArrayTransaction ix a) where
 
 instance (Ord ix) => Applicative (ArrayTransaction ix a) where
   (<*>) afn aa = do
-     fn <- afn
-     a <- aa
-     return (fn a)
+    fn <- afn
+    a <- aa
+    return (fn a)
 
   pure = return
 
 instance (Ord ix) => Monad (ArrayTransaction ix a) where
-    return = ArrayBuilderM_ M.empty
-    (ArrayBuilderM_ map1 val) >>= f = 
-        ArrayBuilderM_ (map1 `M.union` map2) val2
-        where (ArrayBuilderM_ map2 val2) = f val
+  return = ArrayBuilderM_ M.empty
+  (ArrayBuilderM_ map1 val) >>= f =
+    ArrayBuilderM_ (map1 `M.union` map2) val2
+    where
+      (ArrayBuilderM_ map2 val2) = f val
 
 class HasDefault a where
-    theDefault :: a
+  theDefault :: a
 
 instance (Num a) => HasDefault a where
-    theDefault = 0
-instance (HasDefault a, HasDefault b) => HasDefault (a,b) where
-    theDefault = (theDefault,theDefault)
-instance (HasDefault a, HasDefault b, HasDefault c) => HasDefault (a,b,c) where
-    theDefault = (theDefault,theDefault,theDefault)
+  theDefault = 0
+
+instance (HasDefault a, HasDefault b) => HasDefault (a, b) where
+  theDefault = (theDefault, theDefault)
+
+instance (HasDefault a, HasDefault b, HasDefault c) => HasDefault (a, b, c) where
+  theDefault = (theDefault, theDefault, theDefault)
 
 writeArray :: ix -> a -> ArrayTransaction ix a ()
 writeArray index' val = ArrayBuilderM_ (M.singleton index' val) ()
 
-buildArray :: (Ix ix) => (ix,ix) -> e -> ArrayTransaction ix e () -> Array ix e
+buildArray :: (Ix ix) => (ix, ix) -> e -> ArrayTransaction ix e () -> Array ix e
 buildArray bounds' def (ArrayBuilderM_ map' _) =
-    listArray bounds' [maybeLookup map' bound | bound <- range bounds'] 
-    where maybeLookup map_ key = fromMaybe def (M.lookup key map_)
-
+  listArray bounds' [maybeLookup map' bound | bound <- range bounds']
+  where
+    maybeLookup map_ key = fromMaybe def (M.lookup key map_)
diff --git a/Graphics/Glyph/BufferBuilder.hs b/Graphics/Glyph/BufferBuilder.hs
index b23f6ba..8a41f9e 100644
--- a/Graphics/Glyph/BufferBuilder.hs
+++ b/Graphics/Glyph/BufferBuilder.hs
@@ -1,25 +1,25 @@
-{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
 module Graphics.Glyph.BufferBuilder where
 
-import Graphics.Rendering.OpenGL
-import Foreign.Storable
-import Foreign.Ptr
-import Foreign.Marshal.Array
 import Data.Array.Storable
 import qualified Data.Foldable as Fold
-import Data.Sequence as Seq
 import Data.Map as Map
-
-import Graphics.Glyph.Util
+import Data.Sequence as Seq
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import Foreign.Storable
 import Graphics.Glyph.GLMath
-
+import Graphics.Glyph.Util
+import Graphics.Rendering.OpenGL
 import System.IO.Unsafe
 import Unsafe.Coerce
 
-data BufferBuilder3D = Plot BufferBuilder3D (GLfloat,GLfloat,GLfloat) Int Int | End
+data BufferBuilder3D = Plot BufferBuilder3D (GLfloat, GLfloat, GLfloat) Int Int | End
+
 bufferSize :: BufferBuilder3D -> Int
 bufferSize End = 0
 bufferSize (Plot _ _ l _) = l
@@ -31,78 +31,78 @@ nelem (Plot _ _ _ l) = l
 sizeofGLfloat :: Int
 sizeofGLfloat = 4
 
-simpleCube :: Num a => [(a,a,a)]
-simpleCube = trianglesFromQuads [
-      (-1, 1,-1)
-    , ( 1, 1,-1)
-    , ( 1,-1,-1)
-    , (-1,-1,-1)
-
-    , (-1, 1, 1)
-    , ( 1, 1, 1)
-    , ( 1,-1, 1)
-    , (-1,-1, 1)
-
-    , (-1, 1, 1)
-    , ( 1, 1, 1)
-    , ( 1, 1,-1)
-    , (-1, 1,-1)
-
-    , (-1,-1, 1)
-    , ( 1,-1, 1)
-    , ( 1,-1,-1)
-    , (-1,-1,-1)
-
-    , (-1,-1, 1)
-    , (-1, 1, 1)
-    , (-1, 1,-1)
-    , (-1,-1,-1)
-
-    , ( 1,-1, 1)
-    , ( 1, 1, 1)
-    , ( 1, 1,-1)
-    , ( 1,-1,-1)
+simpleCube :: Num a => [(a, a, a)]
+simpleCube =
+  trianglesFromQuads
+    [ (-1, 1, -1),
+      (1, 1, -1),
+      (1, -1, -1),
+      (-1, -1, -1),
+      (-1, 1, 1),
+      (1, 1, 1),
+      (1, -1, 1),
+      (-1, -1, 1),
+      (-1, 1, 1),
+      (1, 1, 1),
+      (1, 1, -1),
+      (-1, 1, -1),
+      (-1, -1, 1),
+      (1, -1, 1),
+      (1, -1, -1),
+      (-1, -1, -1),
+      (-1, -1, 1),
+      (-1, 1, 1),
+      (-1, 1, -1),
+      (-1, -1, -1),
+      (1, -1, 1),
+      (1, 1, 1),
+      (1, 1, -1),
+      (1, -1, -1)
     ]
 
 class Monad a => IsModelBuilder b a where
-    plotVertex3 :: b -> b -> b -> a ()
-    plotNormal  :: b -> b -> b -> a ()
-    plotTexture :: b -> b ->a ()
+  plotVertex3 :: b -> b -> b -> a ()
+  plotNormal :: b -> b -> b -> a ()
+  plotTexture :: b -> b -> a ()
 
 {- A state monad that keeps track of operations
  - and will compile them into a buffer -}
 
 data BuilderM b a = BuilderM (Builder (BuildDatum b)) a
-data Builder b = Builder
-                    !(Builder b) -- before
-                    !(Builder b) -- after
-                  | LeafBuilder !(Seq b) deriving Show
+
+data Builder b
+  = Builder
+      !(Builder b) -- before
+      !(Builder b) -- after
+  | LeafBuilder !(Seq b)
+  deriving (Show)
 
 instance IsModelBuilder GLfloat (BuilderM GLfloat) where
-    plotVertex3 x y z = bVertex3 (x,y,z)
-    plotNormal x y z  = bNormal3 (x,y,z)
-    plotTexture x y   = bTexture2 (x,y)
-
-data BuildDatum b =
-    VertexLink (b,b,b)  |
-    NormalLink (b,b,b)  |
-    ColorLink (b,b,b,b) |
-    TextureLink (b,b) deriving Show
-
-data CompiledBuild b = CompiledBuild {
-    bStride :: Int,
-    bEnabled :: (Bool,Bool,Bool),
-    nElems  :: Int,
+  plotVertex3 x y z = bVertex3 (x, y, z)
+  plotNormal x y z = bNormal3 (x, y, z)
+  plotTexture x y = bTexture2 (x, y)
+
+data BuildDatum b
+  = VertexLink (b, b, b)
+  | NormalLink (b, b, b)
+  | ColorLink (b, b, b, b)
+  | TextureLink (b, b)
+  deriving (Show)
+
+data CompiledBuild b = CompiledBuild
+  { bStride :: Int,
+    bEnabled :: (Bool, Bool, Bool),
+    nElems :: Int,
     array :: Ptr b,
     arrayBytes :: Int
-}
+  }
 
 bufferLength :: (Integral a) => CompiledBuild b -> a
 bufferLength = fromIntegral . nElems
 
 instance Show (CompiledBuild x) where
-    show (CompiledBuild stride enabled n ptr nbytes) =
-        "[CompiledBuild stride="++!stride++" enabled"++!enabled++" n="++!n++" ptr="++!ptr++" nbytes="++!nbytes++"]"
+  show (CompiledBuild stride enabled n ptr nbytes) =
+    "[CompiledBuild stride=" ++! stride ++ " enabled" ++! enabled ++ " n=" ++! n ++ " ptr=" ++! ptr ++ " nbytes=" ++! nbytes ++ "]"
 
 instance Functor (BuilderM t) where
   fmap f b = b >>= (return . f)
@@ -115,206 +115,240 @@ instance Applicative (BuilderM t) where
     return (fn a)
 
 instance Monad (BuilderM t) where
-    (BuilderM !builder1 _) >> (BuilderM !builder2 ret) =
-        BuilderM (builder1 ><> builder2) ret
-        where
-            b1@(LeafBuilder !seq1) ><> b2@(LeafBuilder !seq2) 
-                | Seq.length seq1 + Seq.length seq2 < 128 = LeafBuilder (seq1 >< seq2)
-                | otherwise = Builder b1 b2
-            (Builder !b1 !b2)  ><> leaf@(LeafBuilder !_)  =
-                (Builder b1 (b2 ><> leaf))
-            builder1' ><> builder2' = (Builder builder1' builder2')
+  (BuilderM !builder1 _) >> (BuilderM !builder2 ret) =
+    BuilderM (builder1 ><> builder2) ret
+    where
+      b1@(LeafBuilder !seq1) ><> b2@(LeafBuilder !seq2)
+        | Seq.length seq1 + Seq.length seq2 < 128 = LeafBuilder (seq1 >< seq2)
+        | otherwise = Builder b1 b2
+      (Builder !b1 !b2) ><> leaf@(LeafBuilder !_) =
+        (Builder b1 (b2 ><> leaf))
+      builder1' ><> builder2' = (Builder builder1' builder2')
 
-    b1@(BuilderM _ ret) >>= func = b1 >> func ret
+  b1@(BuilderM _ ret) >>= func = b1 >> func ret
 
-    return = BuilderM (LeafBuilder Seq.empty)
+  return = BuilderM (LeafBuilder Seq.empty)
 
 instance Functor Builder where
-    fmap f (Builder b1 b2) = (Builder (fmap f b1) (fmap f b2))
-    fmap f (LeafBuilder seq') = (LeafBuilder (fmap f seq'))
+  fmap f (Builder b1 b2) = (Builder (fmap f b1) (fmap f b2))
+  fmap f (LeafBuilder seq') = (LeafBuilder (fmap f seq'))
 
 instance Fold.Foldable Builder where
-    foldl f ini (Builder b1 b2) = 
-        Fold.foldl f (Fold.foldl f ini b1) b2
-    foldl f ini (LeafBuilder seq') =
-        Fold.foldl f ini seq'
+  foldl f ini (Builder b1 b2) =
+    Fold.foldl f (Fold.foldl f ini b1) b2
+  foldl f ini (LeafBuilder seq') =
+    Fold.foldl f ini seq'
 
-    foldr f ini (Builder b1 b2) = 
-        Fold.foldr f (Fold.foldr f ini b2) b1
-    foldr f ini (LeafBuilder seq') =
-        Fold.foldr f ini seq'
+  foldr f ini (Builder b1 b2) =
+    Fold.foldr f (Fold.foldr f ini b2) b1
+  foldr f ini (LeafBuilder seq') =
+    Fold.foldr f ini seq'
 
-expandBuilder :: Builder a -> b -> (b -> a -> (b,[a])) -> Builder a
+expandBuilder :: Builder a -> b -> (b -> a -> (b, [a])) -> Builder a
 expandBuilder builder ini f = snd $ expandBuilder' builder ini f
-    where expandBuilder' :: Builder a -> b -> (b -> a -> (b,[a])) -> (b,Builder a)
-
-          expandBuilder' (Builder builder1 builder2) ini' f' = 
-            let (snowball1,newBuilder1) = expandBuilder' builder1 ini' f'
-                (snowball2,newBuilder2) = expandBuilder' builder2 snowball1 f' in
-                (snowball2,Builder newBuilder1 newBuilder2)
-
-          expandBuilder' (LeafBuilder seq1) initial func = 
-            let (sequ,snow) = Fold.foldl' (\(seq', snowball) datum -> 
-                            let (snow',lst) = func snowball datum in
-                            (seq' >< Seq.fromList lst,snow')) (Seq.empty,initial) seq1 in
-                (snow,LeafBuilder sequ)
+  where
+    expandBuilder' :: Builder a -> b -> (b -> a -> (b, [a])) -> (b, Builder a)
+
+    expandBuilder' (Builder builder1 builder2) ini' f' =
+      let (snowball1, newBuilder1) = expandBuilder' builder1 ini' f'
+          (snowball2, newBuilder2) = expandBuilder' builder2 snowball1 f'
+       in (snowball2, Builder newBuilder1 newBuilder2)
+    expandBuilder' (LeafBuilder seq1) initial func =
+      let (sequ, snow) =
+            Fold.foldl'
+              ( \(seq', snowball) datum ->
+                  let (snow', lst) = func snowball datum
+                   in (seq' >< Seq.fromList lst, snow')
+              )
+              (Seq.empty, initial)
+              seq1
+       in (snow, LeafBuilder sequ)
 
 {- Add a vertex to the current builder -}
-bVertex3 :: (a,a,a) -> BuilderM a ()
+bVertex3 :: (a, a, a) -> BuilderM a ()
 bVertex3 vert = BuilderM (LeafBuilder (Seq.singleton $ VertexLink vert)) ()
 
-bTexture2 :: (a,a) -> BuilderM a ()
+bTexture2 :: (a, a) -> BuilderM a ()
 bTexture2 tex = BuilderM (LeafBuilder (Seq.singleton $ TextureLink tex)) ()
 
-bNormal3 :: (a,a,a) -> BuilderM a ()
+bNormal3 :: (a, a, a) -> BuilderM a ()
 bNormal3 norm = BuilderM (LeafBuilder (Seq.singleton $ NormalLink norm)) ()
 
-bColor4 :: (a,a,a,a) -> BuilderM a ()
+bColor4 :: (a, a, a, a) -> BuilderM a ()
 bColor4 col = BuilderM (LeafBuilder (Seq.singleton $ ColorLink col)) ()
 
 writeAndAvance :: (Storable a) => [a] -> Ptr a -> IO (Ptr a)
-writeAndAvance (a:as) ptr = poke ptr a >> writeAndAvance as (advancePtr ptr 1)
+writeAndAvance (a : as) ptr = poke ptr a >> writeAndAvance as (advancePtr ptr 1)
 writeAndAvance [] ptr = return ptr
 
 compilingBuilder :: (Storable b, Num b, Show b) => BuilderM b x -> IO (CompiledBuild b)
 compilingBuilder (BuilderM builder _) = do
+  putStrLn "COMPILING"
+  -- Size of the elements TODO unhardcode this
+  let sizeof = sizeOf $ builderElem builder
+        where
+          builderElem :: Builder (BuildDatum a) -> a
+          builderElem _ = unsafeCoerce (0 :: Int)
+
+  {- Simply figure out what types of elementse
+   - exist in this buffer -}
+  let (bn, bc, bt, nVerts) =
+        Fold.foldl'
+          ( \(bn, bc, bt, len) ele ->
+              case ele of
+                NormalLink _ -> (True, bc, bt, len)
+                ColorLink _ -> (bn, True, bt, len)
+                TextureLink _ -> (bn, bc, True, len)
+                VertexLink _ -> (bn, bc, bt, len + 1)
+          )
+          (False, False, False, 0)
+          builder
+  {- Calculate the stride; number of floats per element -}
+  let stride = (3 + (?) bn * 3 + (?) bc * 4 + (?) bt * 2) * sizeof
+        where
+          (?) True = 1
+          (?) False = 0
+
+  let nbytes = stride * nVerts
+  putStrLn $ "Mallocing array of size: " ++! nbytes
+  array <- mallocArray nbytes
+
+  -- Tuple
+  -- Pointer to current element, current normal/color/texture
+  putStrLn "Writing array buffer"
+  !_ <-
+    Fold.foldlM
+      ( \(ptr, cn, cc, ct) ele ->
+          -- trace ("foldl " ++! ele) $
+          case ele of
+            NormalLink nn -> return (ptr, nn, cc, ct)
+            ColorLink nc -> return (ptr, cn, nc, ct)
+            TextureLink nt -> return (ptr, cn, cc, nt)
+            VertexLink vert -> do
+              ptr' <-
+                writeAndAvance (tp3 True vert) ptr
+                  >>= writeAndAvance (tp3 bn cn)
+                  >>= writeAndAvance (tp4 bc cc)
+                  >>= writeAndAvance (tp2 bt ct)
+              return (ptr', cn, cc, ct)
+      )
+      (array, (0, 0, 0), (0, 0, 0, 0), (0, 0))
+      builder
+  putStrLn "Buffer written"
+  let !compiledRet = CompiledBuild stride (bn, bc, bt) nVerts array nbytes
+  putStrLn $ "COMPILE COMPLETE" ++! compiledRet
+  return compiledRet
+  where
+    tp2 True (a, b) = [a, b]
+    tp2 False _ = []
 
-    putStrLn "COMPILING"
-    -- Size of the elements TODO unhardcode this
-    let sizeof = sizeOf $ builderElem builder
-                  where builderElem :: Builder (BuildDatum a) -> a
-                        builderElem _ = unsafeCoerce (0::Int)
-
-    {- Simply figure out what types of elementse
-     - exist in this buffer -}
-    let (bn,bc,bt,nVerts) = Fold.foldl' (\(bn,bc,bt,len) ele ->
-                                case ele of
-                                    NormalLink _ -> (True,bc,bt,len)
-                                    ColorLink _ -> (bn,True,bt,len)
-                                    TextureLink _ -> (bn,bc,True,len)
-                                    VertexLink _ -> (bn,bc,bt,len+1)) (False,False,False,0) builder
-    {- Calculate the stride; number of floats per element -}
-    let stride = (3 + (?)bn * 3 + (?)bc * 4 + (?)bt * 2) * sizeof
-                    where (?) True = 1
-                          (?) False = 0
-
-    let nbytes = stride * nVerts
-    putStrLn $ "Mallocing array of size: " ++! nbytes
-    array <- mallocArray nbytes
-
-    -- Tuple
-    -- Pointer to current element, current normal/color/texture
-    putStrLn "Writing array buffer"
-    !_ <- Fold.foldlM (\(ptr, cn, cc, ct) ele ->
-           -- trace ("foldl " ++! ele) $
-            case ele of
-                NormalLink nn -> return (ptr,nn,cc,ct)
-                ColorLink nc -> return (ptr,cn,nc,ct)
-                TextureLink nt -> return (ptr,cn,cc,nt)
-                VertexLink vert -> do
-                  ptr' <- writeAndAvance (tp3 True vert) ptr >>=
-                            writeAndAvance (tp3 bn cn) >>=
-                            writeAndAvance (tp4 bc cc) >>=
-                            writeAndAvance (tp2 bt ct)
-                  return (ptr',cn,cc,ct) ) ( array, (0,0,0), (0,0,0,0), (0,0) ) builder
-    putStrLn "Buffer written"
-    let !compiledRet = CompiledBuild stride (bn,bc,bt) nVerts array nbytes
-    putStrLn $ "COMPILE COMPLETE" ++! compiledRet
-    return compiledRet
+    tp3 True (a, b, c) = [a, b, c]
+    tp3 False _ = []
 
-  where
-      tp2 True (a,b)  = [a,b]
-      tp2 False _  = []
- 
-      tp3 True (a,b,c) = [a,b,c]
-      tp3 False _ = []
- 
-      tp4 True (a,b,c,d) = [a,b,c,d]
-      tp4 False _ = []
+    tp4 True (a, b, c, d) = [a, b, c, d]
+    tp4 False _ = []
 
 storableArrayToBuffer :: (Storable el) => BufferTarget -> StorableArray Int el -> IO BufferObject
 storableArrayToBuffer target arr = do
-    let sizeof = sizeOf $ unsafePerformIO (readArray arr 0)
-    [buffer] <- genObjectNames 1
-    bindBuffer target $= Just buffer
-    len <- getBounds arr >>= (\(a,b) -> return $ (b - a) * sizeof )
-    withStorableArray arr $ \ptr ->
-        bufferData target $= (fromIntegral len, ptr, StaticDraw)
-    return buffer
+  let sizeof = sizeOf $ unsafePerformIO (readArray arr 0)
+  [buffer] <- genObjectNames 1
+  bindBuffer target $= Just buffer
+  len <- getBounds arr >>= (\(a, b) -> return $ (b - a) * sizeof)
+  withStorableArray arr $ \ptr ->
+    bufferData target $= (fromIntegral len, ptr, StaticDraw)
+  return buffer
 
 ptrToBuffer :: (Storable b) => BufferTarget -> Int -> Ptr b -> IO BufferObject
 ptrToBuffer target len ptr = do
-    -- len is length in bytes
-    [buffer] <- genObjectNames 1
-    bindBuffer target $= Just buffer
-    bufferData target $= (fromIntegral len, ptr, StaticDraw)
-    return buffer
+  -- len is length in bytes
+  [buffer] <- genObjectNames 1
+  bindBuffer target $= Just buffer
+  bufferData target $= (fromIntegral len, ptr, StaticDraw)
+  return buffer
 
 vertexArrayDescriptor :: CompiledBuild GLfloat -> VertexArrayDescriptor GLfloat
 vertexArrayDescriptor (CompiledBuild stride _ _ _ _) = VertexArrayDescriptor 3 Float (fromIntegral stride) (wordPtrToPtr 0)
 
 normalArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
-normalArrayDescriptor (CompiledBuild stride (True,_,_) _ _ _) =
-                Just $ VertexArrayDescriptor 3 Float
-                        (fromIntegral stride) (wordPtrToPtr (3*4))
-normalArrayDescriptor  _ = Nothing
+normalArrayDescriptor (CompiledBuild stride (True, _, _) _ _ _) =
+  Just $
+    VertexArrayDescriptor
+      3
+      Float
+      (fromIntegral stride)
+      (wordPtrToPtr (3 * 4))
+normalArrayDescriptor _ = Nothing
 
 colorArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
-colorArrayDescriptor (CompiledBuild stride tup@(_,True,_) _ _ _) =
-                Just $ VertexArrayDescriptor 4 Float
-                        (fromIntegral stride) (wordPtrToPtr (offset tup))
-                where offset (b1,_,_) = if b1 then (6*4) else (3*4)
-                        
-colorArrayDescriptor  _ = Nothing
+colorArrayDescriptor (CompiledBuild stride tup@(_, True, _) _ _ _) =
+  Just $
+    VertexArrayDescriptor
+      4
+      Float
+      (fromIntegral stride)
+      (wordPtrToPtr (offset tup))
+  where
+    offset (b1, _, _) = if b1 then (6 * 4) else (3 * 4)
+colorArrayDescriptor _ = Nothing
 
 textureArrayDescriptor :: CompiledBuild GLfloat -> Maybe (VertexArrayDescriptor GLfloat)
-textureArrayDescriptor (CompiledBuild stride tup@(_,_,True) _ _ _) =
-                Just $ VertexArrayDescriptor 2 Float
-                        (fromIntegral stride) (wordPtrToPtr (offset tup))
-                where offset (b1,b2,_) = (3 + (ifp b1 3) + (ifp b2 4)) * 4
-                      ifp b x = if b then x else 0  
-textureArrayDescriptor  _ = Nothing
+textureArrayDescriptor (CompiledBuild stride tup@(_, _, True) _ _ _) =
+  Just $
+    VertexArrayDescriptor
+      2
+      Float
+      (fromIntegral stride)
+      (wordPtrToPtr (offset tup))
+  where
+    offset (b1, b2, _) = (3 + (ifp b1 3) + (ifp b2 4)) * 4
+    ifp b x = if b then x else 0
+textureArrayDescriptor _ = Nothing
+
 createBufferObject :: BufferTarget -> CompiledBuild GLfloat -> IO BufferObject
 createBufferObject target (CompiledBuild _ _ _ arr len) = ptrToBuffer target len arr
 
 mapListInsert :: (Ord k) => k -> a -> Map.Map k [a] -> Map.Map k [a]
 mapListInsert key val map =
-    flip (Map.insert key) map $
-        case Map.lookup key map of
-            Nothing -> [val]
-            Just x -> (val:x)
+  flip (Map.insert key) map $
+    case Map.lookup key map of
+      Nothing -> [val]
+      Just x -> (val : x)
 
-inferingNormals :: (RealFloat a,Ord a,Show a) => BuilderM a b -> BuilderM a b
+inferingNormals :: (RealFloat a, Ord a, Show a) => BuilderM a b -> BuilderM a b
 inferingNormals (BuilderM builder ret) =
-    let (normalMap,_,_) = Fold.foldl' (\(newMap, v1, v2) datum ->
-                            case datum of
-                                VertexLink w ->
-                                    case (v1,v2) of
-                                        (Just u, Just v) -> 
-                                            let (Vec3 normal) = (Vec3 u <-> Vec3 v) × (Vec3 u <-> Vec3 w) in
-                                            (insertWith (zipWithT3 (+)) w normal newMap, Nothing, Nothing)
-                                        (Just u, Nothing) -> (newMap, v1, Just w)
-                                        (Nothing,Nothing) -> (newMap, Just w, Nothing)
-                                _ -> (newMap,v1,v2)
-                                ) (Map.empty,Nothing,Nothing) builder in
-
-    let newBuilder = expandBuilder builder () $ \() datum ->
-         case datum of
-            VertexLink tup ->
-                let normalLink = NormalLink $ maybe (0,0,0) id $ Map.lookup tup normalMap in
-                ((),[normalLink, datum])
-            _ -> ((),[datum]) in
-
-    (BuilderM newBuilder ret)
-
+  let (normalMap, _, _) =
+        Fold.foldl'
+          ( \(newMap, v1, v2) datum ->
+              case datum of
+                VertexLink w ->
+                  case (v1, v2) of
+                    (Just u, Just v) ->
+                      let (Vec3 normal) = (Vec3 u <-> Vec3 v) × (Vec3 u <-> Vec3 w)
+                       in (insertWith (zipWithT3 (+)) w normal newMap, Nothing, Nothing)
+                    (Just u, Nothing) -> (newMap, v1, Just w)
+                    (Nothing, Nothing) -> (newMap, Just w, Nothing)
+                _ -> (newMap, v1, v2)
+          )
+          (Map.empty, Nothing, Nothing)
+          builder
+   in let newBuilder = expandBuilder builder () $ \() datum ->
+            case datum of
+              VertexLink tup ->
+                let normalLink = NormalLink $ maybe (0, 0, 0) id $ Map.lookup tup normalMap
+                 in ((), [normalLink, datum])
+              _ -> ((), [datum])
+       in (BuilderM newBuilder ret)
 
 trianglesFromQuads :: [a] -> [a]
-trianglesFromQuads (a:b:c:d:xs) = [a,b,c,a,c,d] ++ trianglesFromQuads xs
+trianglesFromQuads (a : b : c : d : xs) = [a, b, c, a, c, d] ++ trianglesFromQuads xs
 trianglesFromQuads l = l
 
-translating :: (Num a) => (a,a,a) -> BuilderM a b -> BuilderM a b
+translating :: (Num a) => (a, a, a) -> BuilderM a b -> BuilderM a b
 translating trans (BuilderM builder ret) = do
-    BuilderM (flip fmap builder $ \datum ->
-                case datum of
-                    VertexLink tup -> VertexLink $ zipWithT3 (+) tup trans
-                    _ -> datum) ret
+  BuilderM
+    ( flip fmap builder $ \datum ->
+        case datum of
+          VertexLink tup -> VertexLink $ zipWithT3 (+) tup trans
+          _ -> datum
+    )
+    ret
diff --git a/Graphics/Glyph/ExtendedGL.hs b/Graphics/Glyph/ExtendedGL.hs
index a056c5b..4d77924 100644
--- a/Graphics/Glyph/ExtendedGL.hs
+++ b/Graphics/Glyph/ExtendedGL.hs
@@ -1,8 +1,7 @@
-module Graphics.Glyph.ExtendedGL 
-    (
-      module All
-    ) where
+module Graphics.Glyph.ExtendedGL
+  ( module All,
+  )
+where
 
-import Graphics.Glyph.ExtendedGL.Framebuffers as All hiding (framebufferBasicParameteri)
 import Graphics.Glyph.ExtendedGL.Base as All
-
+import Graphics.Glyph.ExtendedGL.Framebuffers as All hiding (framebufferBasicParameteri)
diff --git a/Graphics/Glyph/ExtendedGL/Base.hs b/Graphics/Glyph/ExtendedGL/Base.hs
index 88566f4..9b50ddb 100644
--- a/Graphics/Glyph/ExtendedGL/Base.hs
+++ b/Graphics/Glyph/ExtendedGL/Base.hs
@@ -1,111 +1,117 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-module Graphics.Glyph.ExtendedGL.Base where
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
 
-import qualified Graphics.Rendering.OpenGL as GL
-import Graphics.GL.Core43
-import Graphics.GL.Compatibility30
+module Graphics.Glyph.ExtendedGL.Base where
 
+import Control.Monad
+import Data.Proxy
+import Data.StateVar
+import Foreign.C.Types
 import Foreign.Marshal.Alloc
 import Foreign.Ptr
 import Foreign.Storable
-import Foreign.C.Types
-
+import Graphics.GL.Compatibility30
+import Graphics.GL.Core43
+import qualified Graphics.Rendering.OpenGL as GL
 import System.IO.Unsafe
-import Control.Monad
-
-import Data.StateVar
 import Unsafe.Coerce
-import Data.Proxy
 
-data ExPrimitiveMode = Points | Triangles | Lines | Patches deriving (Show,Enum)
+data ExPrimitiveMode = Points | Triangles | Lines | Patches deriving (Show, Enum)
 
 class IsBindable a where
-    bind :: a -> IO ()
+  bind :: a -> IO ()
+
 class IsGLEnumMarshallable a where
-    toGLEnum :: a -> GLenum
+  toGLEnum :: a -> GLenum
+
 class IsGenerable a where
-    generate :: IO a
+  generate :: IO a
+
 class IsWrappedPrimitive t a where
-    unwrap :: a -> t
-    wrap :: t -> a
+  unwrap :: a -> t
+  wrap :: t -> a
+
 class HasIntegerParam t a where
-    parami :: t -> a -> SettableStateVar GLuint
+  parami :: t -> a -> SettableStateVar GLuint
+
 class HasFloatParam t a where
-    paramf :: t -> a -> SettableStateVar GLfloat
+  paramf :: t -> a -> SettableStateVar GLfloat
+
 class HasParamOfType b t a where
-    param :: t -> a -> SettableStateVar b
+  param :: t -> a -> SettableStateVar b
 
 class IsPrimitiveModeMarshallable a where
-    marshalPrimitiveMode :: a -> GLuint
+  marshalPrimitiveMode :: a -> GLuint
 
 castPrimitive :: forall a b t. (IsWrappedPrimitive t a, IsWrappedPrimitive t b) => Proxy t -> a -> b
 castPrimitive _ x = wrap unw
-    where
-        unw :: t
-        unw = unwrap x
+  where
+    unw :: t
+    unw = unwrap x
 
 instance (IsWrappedPrimitive a a) where
-    unwrap = id
-    wrap = id
+  unwrap = id
+  wrap = id
+
 instance (IsWrappedPrimitive GLenum a) => IsGLEnumMarshallable a where
-    toGLEnum = unwrap
+  toGLEnum = unwrap
 
 instance IsPrimitiveModeMarshallable ExPrimitiveMode where
-    marshalPrimitiveMode x = case x of
-        Points    -> GL_POINTS
-        Triangles -> GL_TRIANGLES
-        Lines     -> GL_LINES
-        Patches   -> GL_PATCHES
+  marshalPrimitiveMode x = case x of
+    Points -> GL_POINTS
+    Triangles -> GL_TRIANGLES
+    Lines -> GL_LINES
+    Patches -> GL_PATCHES
 
 instance IsPrimitiveModeMarshallable GL.PrimitiveMode where
-    marshalPrimitiveMode x = case x of
-        GL.Points -> 0x0
-        GL.Lines -> 0x1
-        GL.LineLoop -> 0x2
-        GL.LineStrip -> 0x3
-        GL.Triangles -> 0x4
-        GL.TriangleStrip -> 0x5
-        GL.TriangleFan -> 0x6
-        GL.Quads -> 0x7
-        GL.QuadStrip -> 0x8
-        GL.Polygon -> 0x9
+  marshalPrimitiveMode x = case x of
+    GL.Points -> 0x0
+    GL.Lines -> 0x1
+    GL.LineLoop -> 0x2
+    GL.LineStrip -> 0x3
+    GL.Triangles -> 0x4
+    GL.TriangleStrip -> 0x5
+    GL.TriangleFan -> 0x6
+    GL.Quads -> 0x7
+    GL.QuadStrip -> 0x8
+    GL.Polygon -> 0x9
 
 instance IsPrimitiveModeMarshallable GLuint where
-    marshalPrimitiveMode = id
+  marshalPrimitiveMode = id
 
 vertexAttributeDivisor :: GL.AttribLocation -> SettableStateVar GLuint
 vertexAttributeDivisor (GL.AttribLocation loc) =
-    makeSettableStateVar $ \val ->
-        glVertexAttribDivisor loc val
+  makeSettableStateVar $ \val ->
+    glVertexAttribDivisor loc val
 
 {- Sets the number of vertices per patch
  - for OpenGL -}
 patchVertices :: (Integral a) => SettableStateVar a
-patchVertices = 
-    makeSettableStateVar $ \val ->
-        glPatchParameteri GL_PATCH_VERTICES $ fromIntegral val
+patchVertices =
+  makeSettableStateVar $ \val ->
+    glPatchParameteri GL_PATCH_VERTICES $ fromIntegral val
 
 {- Returns the maximum number of patches
  - for a tessilation shader -}
 maxPatchVertices :: IO CInt
 maxPatchVertices =
-        alloca $ \ptr -> do
-            glGetIntegerv GL_MAX_PATCH_VERTICES ptr
-            fromIntegral <$> peek ptr
+  alloca $ \ptr -> do
+    glGetIntegerv GL_MAX_PATCH_VERTICES ptr
+    fromIntegral <$> peek ptr
 
 getGLVersion :: IO String
 getGLVersion =
-    let lift2 (a,b) = do
-            x <- a ; y <- b ; return (x,y)
-             in
-    alloca $ \ptr1 -> alloca $ \ptr2 -> do
+  let lift2 (a, b) = do
+        x <- a
+        y <- b
+        return (x, y)
+   in alloca $ \ptr1 -> alloca $ \ptr2 -> do
         glGetIntegerv GL_MAJOR_VERSION ptr1
         glGetIntegerv GL_MINOR_VERSION ptr2
-        (v1,v2) <- lift2 (peek ptr1, peek ptr2)
+        (v1, v2) <- lift2 (peek ptr1, peek ptr2)
         return ("OpenGL " ++ show v1 ++ "." ++ show v2)
 
 coerced :: a
-coerced = unsafeCoerce (0::Int)
+coerced = unsafeCoerce (0 :: Int)
diff --git a/Graphics/Glyph/ExtendedGL/Framebuffers.hs b/Graphics/Glyph/ExtendedGL/Framebuffers.hs
index a6c2891..1de7781 100644
--- a/Graphics/Glyph/ExtendedGL/Framebuffers.hs
+++ b/Graphics/Glyph/ExtendedGL/Framebuffers.hs
@@ -1,109 +1,120 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Graphics.Glyph.ExtendedGL.Framebuffers where
 
-import Graphics.GL.Compatibility30
-import Graphics.GL.Core43
-import qualified Graphics.Rendering.OpenGL as GL
-
-import Graphics.Glyph.ExtendedGL.Base
-
+import Control.Monad
+import Data.StateVar
+import Foreign.C.Types
 import Foreign.Marshal.Alloc
 import Foreign.Ptr
 import Foreign.Storable
-import Foreign.C.Types
-
-import Data.StateVar
-import Control.Monad
-
+import Graphics.GL.Compatibility30
+import Graphics.GL.Core43
+import Graphics.Glyph.ExtendedGL.Base
+import qualified Graphics.Rendering.OpenGL as GL
 import Unsafe.Coerce
 
-
-class (
-    HasParamOfType GLuint FramebufferParameter a,
+class
+  ( HasParamOfType GLuint FramebufferParameter a,
     HasIntegerParam GLenum a,
     IsGenerable a,
-    IsBindable a, IsWrappedPrimitive GLuint a) => IsFramebuffer a where
-    
-    -- this function MUST discard the argument
-    getType :: a -> GLenum
+    IsBindable a,
+    IsWrappedPrimitive GLuint a
+  ) =>
+  IsFramebuffer a
+  where
+  -- this function MUST discard the argument
+  getType :: a -> GLenum
 
 framebufferBasicParameteri :: (IsFramebuffer a) => GLenum -> a -> GLenum -> SettableStateVar GLuint
 framebufferBasicParameteri typ fb enum =
-    makeSettableStateVar (\value -> do
+  makeSettableStateVar
+    ( \value -> do
         bind fb
-        glFramebufferParameteri typ enum $ fromIntegral value)
+        glFramebufferParameteri typ enum $ fromIntegral value
+    )
 
 data Renderbuffer = Renderbuffer GLuint
+
 instance IsWrappedPrimitive GLuint Renderbuffer where
-    unwrap (Renderbuffer x) = x
+  unwrap (Renderbuffer x) = x
+
 instance IsGenerable Renderbuffer where
-    generate = alloca $ \ptr -> do
-        glGenRenderbuffers 1 ptr
-        liftM Renderbuffer $ peek ptr
+  generate = alloca $ \ptr -> do
+    glGenRenderbuffers 1 ptr
+    liftM Renderbuffer $ peek ptr
+
 instance IsBindable Renderbuffer where
-    bind = glBindRenderbuffer GL_RENDERBUFFER . unwrap
+  bind = glBindRenderbuffer GL_RENDERBUFFER . unwrap
+
+data RenderbufferArgument
+  = DepthAttachment
 
-data RenderbufferArgument =
-        DepthAttachment
 instance IsWrappedPrimitive GLenum RenderbufferArgument where
-    unwrap DepthAttachment = GL_DEPTH_ATTACHMENT
+  unwrap DepthAttachment = GL_DEPTH_ATTACHMENT
 
 renderBufferStorageRaw :: (IsGLEnumMarshallable a, IsGLEnumMarshallable b) => a -> b -> Int -> Int -> IO ()
-renderBufferStorageRaw typ enum w h = glRenderbufferStorage (toGLEnum typ) 
-                                    (toGLEnum enum) (fromIntegral w) (fromIntegral h)
-renderBufferStorage :: (IsGLEnumMarshallable a) => Renderbuffer -> SettableStateVar (a,Int,Int)
-renderBufferStorage buffer = makeSettableStateVar $ \(en,w,h) -> do
-                                bind buffer
-                                renderBufferStorageRaw GL_RENDERBUFFER en w h
-
-frameBufferRenderBuffer :: forall a b. (IsFramebuffer a,IsGLEnumMarshallable b) => Renderbuffer -> b -> IO a
+renderBufferStorageRaw typ enum w h =
+  glRenderbufferStorage
+    (toGLEnum typ)
+    (toGLEnum enum)
+    (fromIntegral w)
+    (fromIntegral h)
+
+renderBufferStorage :: (IsGLEnumMarshallable a) => Renderbuffer -> SettableStateVar (a, Int, Int)
+renderBufferStorage buffer = makeSettableStateVar $ \(en, w, h) -> do
+  bind buffer
+  renderBufferStorageRaw GL_RENDERBUFFER en w h
+
+frameBufferRenderBuffer :: forall a b. (IsFramebuffer a, IsGLEnumMarshallable b) => Renderbuffer -> b -> IO a
 frameBufferRenderBuffer rb e = do
-    let enum :: GLenum
-        enum = getType test
-        unw ::