packages feed

GPipe-Core (empty) → 0.2.3.0

raw patch · 41 files changed

+9344/−0 lines, 41 filesdep +Booleandep +GPipe-Coredep +basesetup-changed

Dependencies added: Boolean, GPipe-Core, base, containers, exception-transformers, gl, hashtables, hspec, lens, linear, text, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,92 @@+### 0.2.3.0++Pre-release for GPipe-Core.++- Added geometry shader support.+- Added transform feedback support.++### 2.2.4++- Support for GHC 8.6.5 (#63)++### 2.2.3++- Removing an unnecessary optimization that was broken since 2.2++### 2.2.2++- Support for GHC 8.2.1 (#52)+- Fixing errors with hidden contexts+- Fixing GLSL link error on subtracting a negative constant (#55)+- Fixing GLSL ambiguous overload with "clamp" (#51)+- Adding atan2' (#44)++### 2.2.1++- Render monad would crash if using deleted windows, when that should be a no-op. (#41).+- Manually deleting last visible window causes objects to be deleted (#42).++### 2.2++- Windows are now explicit objects dynamically created and deleted with newWindow and deleteWindow, and are sent as parameter to drawWindowColor et al. (#18)+- Each window created can now take their own window manager specific parameters (#19)+- Update to GHC 8.0.2 and gl-0.8.0 (#38)++### 2.1.8++- Update dependencies to make it build with stack resolver nightly-2016-09-24++### 2.1.7++- Runtime optimizations (Use BaseVertex for glDraw\* instead of offsetting each attribute)++### 2.1.6++- Adding support for normal Floats, Int32s and Word32s in PrimitiveStreams+- Runtime optimizations++### 2.1.5++- Fixed bug in clear where masks weren't set+- Added up to 7-tuple instances++### 2.1.4++- Fixed bug in dropVertices and dropIndices (#16)+- Added withPointSize (#15)++### 2.1.3++- Fixed bug in clearImage++### 2.1.2++- Fixed bug when nesting while, ifThen, ifThenElse or ifThenElse'.++### 2.1.1++- Made ifB use ifThenElse' instead to avoid unwanted strictness+- Fixed bug where ShaderBaseType for () wasn't lazy enough, causing error in ifThenElse'+- Added missing () instances++### 2.1++- Making dangling finalizers work with shared and unshared contexts (#10)+- Moved orphan instances to separate module (#11)+- Fixing a bug introduced in 2.0.2 when using multiple uniforms+- Fixing exception when using conditionals in the shader (#12)++### 2.0.2++- Linear bumped to 1.20+- Running contextSwap and contextFrameBufferSize on right thread (#7)+- render now throws if rendering to an image from a texture thats used for sampling (#8)+- Added GPipe class instances for all linear types (#9)++### 2.0.1++- Fixed runtime error in simple fragment program when not all uniforms where used (#5)++### 2.0++- Initial release of GPipe 2
+ GPipe-Core.cabal view
@@ -0,0 +1,93 @@+name:           GPipe-Core+version:        0.2.3.0+cabal-version:  >= 1.10+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:       https://github.com/tobbebex/GPipe-Core#readme+bug-reports:    https://github.com/tobbebex/GPipe-Core/issues+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 4.5 core profile under the hood.+maintainer:     Pippijn van Steenhoven+data-files:     CHANGELOG.md++library+  hs-source-dirs: src+  default-language: Haskell2010+  exposed-modules:+      Graphics.GPipe+      Graphics.GPipe.Buffer+      Graphics.GPipe.Context+      Graphics.GPipe.Expr+      Graphics.GPipe.Format+      Graphics.GPipe.FragmentStream+      Graphics.GPipe.FrameBuffer+      Graphics.GPipe.GeometryStream+      Graphics.GPipe.Linear+      Graphics.GPipe.PrimitiveArray+      Graphics.GPipe.PrimitiveStream+      Graphics.GPipe.Sampler+      Graphics.GPipe.Shader+      Graphics.GPipe.Texture+      Graphics.GPipe.TransformFeedback+      Graphics.GPipe.Uniform+      Graphics.GPipe.Orphans+      -- Internal modules, exported for tests and power users, but don't have+      -- a stable API and are not necessarily safe to use.+      Graphics.GPipe.Internal.Buffer+      Graphics.GPipe.Internal.Compiler+      Graphics.GPipe.Internal.Context+      Graphics.GPipe.Internal.Debug+      Graphics.GPipe.Internal.Expr+      Graphics.GPipe.Internal.Format+      Graphics.GPipe.Internal.FragmentStream+      Graphics.GPipe.Internal.FrameBuffer+      Graphics.GPipe.Internal.GeometryStream+      Graphics.GPipe.Internal.Linear+      Graphics.GPipe.Internal.PrimitiveArray+      Graphics.GPipe.Internal.PrimitiveStream+      Graphics.GPipe.Internal.Shader+      Graphics.GPipe.Internal.Texture+      Graphics.GPipe.Internal.TransformFeedback+      Graphics.GPipe.Internal.Uniform+      Graphics.GPipe.Internal.Orphans+  other-modules:+      -- Data structures, not useful for users of the library.+      Data.SNMap+  build-depends:+      base                          >= 4.9 && < 5+    , Boolean                       >= 0.2 && < 0.3+    , containers                    >= 0.5 && < 0.7+    , exception-transformers        >= 0.3 && < 0.5+    , transformers                  >= 0.5.2 && < 0.6+    , gl                            >= 0.8 && < 0.10+    , hashtables                    >= 1.2 && < 1.3+    , lens                          >= 5.0 && < 5.1+    , linear                        >= 1.18 && < 1.22++test-suite testsuite+  default-language: Haskell2010+  hs-source-dirs:   test+  type: exitcode-stdio-1.0+  main-is:          testsuite.hs+  other-modules:+      Graphics.GPipe.ExprSpec+  ghc-options:+      -Wall+      -threaded+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      base < 5+    , GPipe-Core+    , hspec+    , lens+    , text
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/SNMap.hs view
@@ -0,0 +1,67 @@+-- {-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.SNMap (+    -- SNMap,+    SNMapReaderT,+    runSNMapReaderT,+    -- newSNMap,+    -- memoize,    +    memoizeM,+    scopedM+)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.Applicative (Applicative)+import Control.Monad.Exception (MonadException, MonadAsyncException)+import Control.Monad.Trans.State.Strict++{- A map (SN stands for stable name) to cache the results of computations+(m ends up being constrained to MonadIO m).+-}+newtype SNMap m a = SNMap (HT.BasicHashTable (StableName (m a)) a)++newSNMap :: IO (SNMap m a)+newSNMap = SNMap <$> HT.new++memoize :: MonadIO m+    => m (SNMap m a) -- An "IO call" to retrieve our cache.+    -> m a -- The "IO call" to execute and cache the result.+    -> m a -- The result being naturally also returned.+memoize getter m = do s <- liftIO $ makeStableName $! m -- Does forcing the evaluation make sense here (since we try to avoid it...)? Is it just the first level?+                      (SNMap h) <- getter +                      x <- liftIO $ HT.lookup h s+                      case x of+                                Just a -> return a+                                Nothing -> do a <- m+                                              (SNMap h') <- getter --Need to redo because of scope (TODO Check it)+                                              liftIO $ HT.insert h' s a+                                              return a++-- An (IO) action producing a 'b' value while caching 'a' values along the way.+newtype SNMapReaderT a m b = SNMapReaderT (StateT (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+                                      evalStateT m h ++instance MonadTrans (SNMapReaderT a) where+    lift = SNMapReaderT . lift++-- Simplified memoize version when using a SNMapReaderT.+memoizeM :: MonadIO m => SNMapReaderT a m a -> SNMapReaderT a m a+memoizeM = memoize (SNMapReaderT get)++-- | Run a subcomputation in a scope, where nothing memoized inside will be remembered after+scopedM :: MonadIO m => SNMapReaderT a m x -> SNMapReaderT a m x+scopedM m= do SNMap h <- SNMapReaderT get+              save <- liftIO $ HT.toList h+              x <- m+              h' <- liftIO $ HT.fromList save+              SNMapReaderT $ put (SNMap h')+              return x
+ src/Graphics/GPipe.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------+--+-- 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.+-- GPipe aims to be as close to raw OpenGl performance as possible, without compromising type safety or functional style.+-- Includes an embedded domain specific language for GLSL shaders which provides type safety even when crossing into that domain.+-- Uses the OpenGl 3.3 core profile under the hood.+--+-- To learn GPipe, start with the <https://github.com/tobbebex/GPipe-Core#readme readme>+-- at the <https://github.com/tobbebex/GPipe-Core source repository>.+-- You could also go directly to <https://github.com/plredmond/GPipe-Test a working example>+-- or the tutorials:+-- <http://tobbebex.blogspot.se/2015/09/gpu-programming-in-haskell-using-gpipe.html    Part 1>,+-- <http://tobbebex.blogspot.se/2015/09/gpu-programming-in-haskell-using-gpipe_11.html Part 2>,+-- <http://tobbebex.blogspot.se/2015/10/gpu-programming-in-haskell-using-gpipe.html    Part 3>,+-- <http://tobbebex.blogspot.se/2015/10/gpu-programming-in-haskell-using-gpipe_21.html Part 4>,+-- <http://tobbebex.blogspot.se/2015/11/gpu-programming-in-haskell-using-gpipe.html    Part 5>.+--+-- This module reexports relevant GPipe modules and the external "Linear" and "Data.Boolean" 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.GeometryStream,+    module Graphics.GPipe.Linear,+    module Graphics.GPipe.TransformFeedback,+    module Graphics.GPipe.Shader,+    module Graphics.GPipe.Expr,+    module Graphics.GPipe.Uniform,+    module Graphics.GPipe.Texture,+    module Graphics.GPipe.Sampler,+    module Graphics.GPipe.Orphans,+    module Data.Boolean+)+where++import           Data.Boolean+import           Graphics.GPipe.Buffer+import           Graphics.GPipe.Context+import           Graphics.GPipe.Expr+import           Graphics.GPipe.Format+import           Graphics.GPipe.FragmentStream+import           Graphics.GPipe.FrameBuffer+import           Graphics.GPipe.GeometryStream+import           Graphics.GPipe.Linear+import           Graphics.GPipe.Orphans+import           Graphics.GPipe.PrimitiveArray+import           Graphics.GPipe.PrimitiveStream+import           Graphics.GPipe.Sampler+import           Graphics.GPipe.Shader+import           Graphics.GPipe.Texture+import           Graphics.GPipe.TransformFeedback+import           Graphics.GPipe.Uniform
+ src/Graphics/GPipe/Buffer.hs view
@@ -0,0 +1,64 @@+{-# 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+    ( copyBuffer,+      newBuffer,+      writeBuffer,+      B,+      B2,+      B3,+      B4,+      BPacked,+      Buffer(bufferLength),+      BufferColor,+      BufferFormat(toBuffer, HostFormat),+      BufferStartPos,+      Normalized(..),+      ToBuffer )
+ src/Graphics/GPipe/Context.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+--+-- 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 (+    -- * Contexts+    ContextT(),+    runContextT,++    -- * Windows+    Window(),+    newWindow,+    deleteWindow,+    getFrameBufferSize,+    swapWindowBuffers,+    withContextWindow,++    -- * Extending interface+    ContextHandler(..),++    -- * Hardware exceptions+    GPipeException(..),+)+where++import Graphics.GPipe.Internal.Context
+ src/Graphics/GPipe/Expr.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+--+-- 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,+    GGenerativeGeometry,++    -- * Type classes where the Prelude ones are lacking+    Convert(..),+    Integral'(..),+    Bits'(..),+    Real'(..),+    FloatingOrd(..),++    -- * Additional functions+    dFdx,+    dFdy,+    fwidth,++    -- * Shader control structures+    while,+    ifThen,+    ifThenElse,+    ifThenElse',+    ShaderBase(),+    ShaderType(..)+)+where++import Data.Boolean+import Graphics.GPipe.Internal.Expr
+ src/Graphics/GPipe/Format.hs view
@@ -0,0 +1,36 @@+{-# 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+    WindowFormat(..),+    ContextColorFormat(), -- XXX: Maybe this needs to be renamed?+    windowBits,+    WindowBits+)+where++import Graphics.GPipe.Internal.Format
+ src/Graphics/GPipe/FragmentStream.hs view
@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+--+-- 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(..),+    PolygonMode(..),+    ViewPort(..),+    DepthRange(..),++    -- * Various FragmentStream operations+    filterFragments,+    withRasterizedInfo,+    RasterizedInfo(..),+)+where++import Graphics.GPipe.Internal.FragmentStream
+ src/Graphics/GPipe/FrameBuffer.hs view
@@ -0,0 +1,87 @@+-----------------------------------------------------------------------------+--+-- 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+    drawWindowColor,+    drawWindowDepth,+    drawWindowColorDepth,+    drawWindowStencil,+    drawWindowColorStencil,+    drawWindowDepthStencil,+    drawWindowColorDepthStencil,++    -- * Draw into one or more texture images+    draw,+    drawDepth,+    drawStencil,+    drawDepthStencil,+    drawColor,+    DrawColors(),++    -- * Texture images+    Image(),+    imageEquals,+    imageSize,+    getTexture1DImage,+    getTexture1DArrayImage,+    getTexture2DImage,+    getTexture2DArrayImage,+    getTexture3DImage,+    getTextureCubeImage,++    getLayeredTextureImage,++    -- * Clearing the context window+    -- | Use these functions to clear the color, depth or stencil values in the context's window+    clearWindowColor,+    clearWindowDepth,+    clearWindowStencil,+    clearWindowDepthStencil,++    -- * Clearing texture images+    -- | Use these functions to clear the color, depth or stencil values in texture images.+    clearImageColor,+    clearImageDepth,+    clearImageStencil,+    clearImageDepthStencil,++    -- * 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
+ src/Graphics/GPipe/GeometryStream.hs view
@@ -0,0 +1,30 @@+module Graphics.GPipe.GeometryStream (+    -- * The data type+    GeometryStream(),++    -- * Needed to use custom data types with the geometry shader.+    FragmentCreator(..),+    AnotherVertexInput(..),+    AnotherFragmentInput(..),+    GeometryExplosive(..),++    -- * Needed for generic functions.+    GeometryInput(..),++    -- * Creating GeometryStream+    geometrize,+    generateAndRasterize,++    -- * Various GeometryStream operations+    generativePoints,+    generativeLineStrip,+    generativeTriangleStrip,+    emitVertex,+    emitVertexPosition,+    emitVertexLayer,+    emitVertexPositionAndLayer,+    endPrimitive,+)+where++import Graphics.GPipe.Internal.GeometryStream
+ src/Graphics/GPipe/Internal/Buffer.hs view
@@ -0,0 +1,682 @@+{-# 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, bufTransformFeedback, bufferWriteInternal, makeBuffer, getUniformAlignment, UniformAlignment+) where++import Graphics.GPipe.Internal.Context++import Graphics.GL.Core45+import Graphics.GL.Types+import Foreign.Marshal.Utils+import Foreign.Marshal.Alloc++import Prelude hiding ((.), id)+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.State.Strict+import Control.Monad.Trans.Writer.Strict+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class (lift)+import Data.IORef+import Linear.V4+import Linear.V3+import Linear.V2+import Linear.V1+import Linear.V0+import Linear.Plucker (Plucker(..))+import Linear.Quaternion (Quaternion(..))+import Linear.Affine (Point(..))++-- | 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 ()+    ,   bufTransformFeedback :: IORef (Maybe (GLuint, GLuint))+    }++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 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 (UniformAlignment, AlignmentMode)))) a b) -- Normal = aligned to 4 bytes+    !(Kleisli (StateT Offset (Reader (BufferName, Stride, BInput))) a b)+    !(Kleisli (StateT (Ptr (), [Int]) IO) a b) -- Normal = aligned to 4 bytes+    !AlignmentMode++instance Category ToBuffer where+    {-# INLINE id #-}+    id = ToBuffer id id id AlignUnknown+    {-# INLINE (.) #-}+    ToBuffer a b c m1 . ToBuffer x y z m2 = ToBuffer (a.x) (b.y) (c.z) (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+    {-# INLINE arr #-}+    arr f = ToBuffer (arr f) (arr f) (arr f) AlignUnknown+    {-# INLINE first #-}+    first (ToBuffer a b c m) = ToBuffer (first a) (first b) (first c) 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 $ const valueProd)+        (Kleisli writer)+        Align4+    where+        size = sizeOf (undefined :: a)+        static = do+            offset <- get+            put $ offset + size+            return undefined+        valueProd = do+            (name, stride, bIn) <- 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 preStep)+        (Kleisli elementBuilderA)+        (Kleisli writerA)+        AlignUniform+        where+            ToBuffer (Kleisli preStep') (Kleisli elementBuilderA) (Kleisli writerA') _ = toBuffer :: ToBuffer (HostFormat a) a+            preStep a = do+                (x,_) <- lift $ lift ask+                a' <- preStep' 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 () where+    type HostFormat () = ()+    toBuffer = arr (const ())+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')+instance (BufferFormat a, BufferFormat b, BufferFormat c, BufferFormat d, BufferFormat e) => BufferFormat (a, b, c, d, e) where+    type HostFormat (a,b,c,d,e) = (HostFormat a, HostFormat b, HostFormat c, HostFormat d, HostFormat e)+    toBuffer = proc ~(a, b, c, d, e) -> do+        ((a', b', c', d'), e') <- toBuffer -< ((a, b, c, d), e)+        returnA -< (a', b', c', d', e')+instance (BufferFormat a, BufferFormat b, BufferFormat c, BufferFormat d, BufferFormat e, BufferFormat f) => BufferFormat (a, b, c, d, e, f) where+    type HostFormat (a,b,c,d,e,f) = (HostFormat a, HostFormat b, HostFormat c, HostFormat d, HostFormat e, HostFormat f)+    toBuffer = proc ~(a, b, c, d, e, f) -> do+        ((a', b', c', d', e'), f') <- toBuffer -< ((a, b, c, d, e), f)+        returnA -< (a', b', c', d', e', f')+instance (BufferFormat a, BufferFormat b, BufferFormat c, BufferFormat d, BufferFormat e, BufferFormat f, BufferFormat g) => BufferFormat (a, b, c, d, e, f, g) where+    type HostFormat (a,b,c,d,e,f,g) = (HostFormat a, HostFormat b, HostFormat c, HostFormat d, HostFormat e, HostFormat f, HostFormat g)+    toBuffer = proc ~(a, b, c, d, e, f, g) -> do+        ((a', b', c', d', e', f'), g') <- toBuffer -< ((a, b, c, d, e, f), g)+        returnA -< (a', b', c', d', e', f', g')++instance BufferFormat a => BufferFormat (Quaternion a) where+    type HostFormat (Quaternion a) = Quaternion (HostFormat a)+    toBuffer = proc ~(Quaternion a v) -> do+        a' <- toBuffer -< a+        v' <- toBuffer -< v+        returnA -< Quaternion a' v'++instance (BufferFormat (f a), BufferFormat a, HostFormat (f a) ~ f (HostFormat a)) => BufferFormat (Point f a) where+    type HostFormat (Point f a) = Point f (HostFormat a)+    toBuffer = proc ~(P a) -> do+        a' <- toBuffer -< a+        returnA -< P a'++instance BufferFormat a => BufferFormat (Plucker a) where+    type HostFormat (Plucker a) = Plucker (HostFormat a)+    toBuffer = proc ~(Plucker a b c d e f) -> do+        a' <- toBuffer -< a+        b' <- toBuffer -< b+        c' <- toBuffer -< c+        d' <- toBuffer -< d+        e' <- toBuffer -< e+        f' <- toBuffer -< f+        returnA -< Plucker a' b' c' d' e' f'++-- | Create a buffer with a specified number of elements.+newBuffer :: (MonadIO m, BufferFormat b, ContextHandler ctx) => Int -> ContextT ctx os m (Buffer os b)+newBuffer elementCount+    | elementCount < 0 = error "newBuffer, length negative"+    | otherwise = do+    (buffer, nameRef, name) <- liftNonWinContextIO $ do+        name <- alloca $ \ptr -> do+            glGenBuffers 1 ptr+            peek ptr+        nameRef <- newIORef name+        tfRef <- newIORef Nothing+        uniAl <- getUniformAlignment+        let buffer = makeBuffer' nameRef elementCount uniAl tfRef+        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 :: (ContextHandler ctx, MonadIO m) => Buffer os b -> BufferStartPos -> [HostFormat b] -> ContextT ctx os 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 liftNonWinContextAsyncIO $ 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 :: (ContextHandler ctx, MonadIO m) => Buffer os b -> BufferStartPos -> Buffer os b -> BufferStartPos -> Int -> ContextT ctx os 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 = liftNonWinContextAsyncIO $ 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 return) (Kleisli setWriterAlignM) AlignUniform++setElemAlignM :: [(AlignmentMode, Int)] -> b -> StateT Offset (WriterT [Int] (Reader (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 = makeBuffer' name elementCount uniformAlignment (error "Not meant to be used for transform feedback")++makeBuffer' :: forall os b. BufferFormat b => BufferName -> Int -> UniformAlignment -> IORef (Maybe (GLuint, GLuint)) -> Buffer os b+makeBuffer' name elementCount uniformAlignment tfRef = do+    let ToBuffer skipIt readIt writeIt alignMode = toBuffer :: ToBuffer (HostFormat b) b+        err = error "toBuffer is 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+        ((_,elementSize),pads) = runReader (runWriterT (runStateT (runKleisli skipIt err) 0)) (uniformAlignment, alignMode)+        elementF bIn = fst $ runReader (runStateT (runKleisli readIt err) 0) (name, elementSize, bIn)+        writer ptr x = void $ runStateT (runKleisli writeIt x) (ptr,pads)+    Buffer name elementSize elementCount elementF writer tfRef++-- | 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 => Ptr x -> IO a+peekPixel1 = peek . castPtr+peekPixel2 :: (Storable a) => Ptr x -> IO (V2 a)+peekPixel2 ptr = do+    x <- peek (castPtr ptr)+    y <- peekElemOff (castPtr ptr ) 1+    return (V2 x y)+peekPixel3 :: (Storable a) => 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) => Ptr x -> IO (V4 a)+peekPixel4 ptr = do+    V3 x y z <- peekPixel3 ptr+    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 = const peekPixel1+    getGlPaddedFormat _ = GL_RED_INTEGER++instance BufferFormat (B Word32) where+    type HostFormat (B Word32) = Word32+    toBuffer = toBufferB+    getGlType _ = GL_UNSIGNED_INT+    peekPixel = const peekPixel1+    getGlPaddedFormat _ = GL_RED_INTEGER++instance BufferFormat (BPacked Word16) where+    type HostFormat (BPacked Word16) = Word16+    toBuffer = let ToBuffer a b c _ = toBufferB :: ToBuffer Word16 (B Word16) in arr BPacked . ToBuffer a b c AlignPackedIndices+    getGlType _ = GL_UNSIGNED_SHORT+    peekPixel = const peekPixel1+    getGlPaddedFormat _ = GL_RED_INTEGER++instance BufferFormat (BPacked Word8) where+    type HostFormat (BPacked Word8) = Word8+    toBuffer = let ToBuffer a b c _ = toBufferB :: ToBuffer Word8 (B Word8) in arr BPacked . ToBuffer a b c AlignPackedIndices+    getGlType _ = GL_UNSIGNED_BYTE+    peekPixel = const peekPixel1+    getGlPaddedFormat _ = GL_RED_INTEGER++instance BufferFormat (B Float) where+    type HostFormat (B Float) = Float+    toBuffer = toBufferB+    getGlType _ = GL_FLOAT+    peekPixel = const peekPixel1+    getGlPaddedFormat _ = GL_RED++instance BufferFormat (B2 Int32) where+    type HostFormat (B2 Int32) = V2 Int32+    toBuffer = toBufferB2+    getGlType _ = GL_INT+    peekPixel = const peekPixel2+    getGlPaddedFormat _ = GL_RG_INTEGER++instance BufferFormat (B2 Int16) where+    type HostFormat (B2 Int16) = V2 Int16+    toBuffer = toBufferB2+    getGlType _ = GL_SHORT+    peekPixel = const peekPixel2+    getGlPaddedFormat _ = GL_RG_INTEGER++instance BufferFormat (B2 Word32) where+    type HostFormat (B2 Word32) = V2 Word32+    toBuffer = toBufferB2+    getGlType _ = GL_UNSIGNED_INT+    peekPixel = const peekPixel2+    getGlPaddedFormat _ = GL_RG_INTEGER++instance BufferFormat (B2 Word16) where+    type HostFormat (B2 Word16) = V2 Word16+    toBuffer = toBufferB2+    getGlType _ = GL_UNSIGNED_SHORT+    peekPixel = const peekPixel2+    getGlPaddedFormat _ = GL_RG_INTEGER++instance BufferFormat (B2 Float) where+    type HostFormat (B2 Float) = V2 Float+    toBuffer = toBufferB2+    getGlType _ = GL_FLOAT+    peekPixel = const peekPixel2+    getGlPaddedFormat _ = GL_RG++instance BufferFormat (B3 Int32) where+    type HostFormat (B3 Int32) = V3 Int32+    toBuffer = toBufferB3+    getGlType _ = GL_INT+    peekPixel = const peekPixel3+    getGlPaddedFormat _ = GL_RGB_INTEGER++instance BufferFormat (B3 Int16) where+    type HostFormat (B3 Int16) = V3 Int16+    toBuffer = toBufferB3+    getGlType _ = GL_SHORT+    peekPixel = const peekPixel3+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B3 Int8) where+    type HostFormat (B3 Int8) = V3 Int8+    toBuffer = toBufferB3+    getGlType _ = GL_BYTE+    peekPixel = const peekPixel3+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B3 Word32) where+    type HostFormat (B3 Word32) = V3 Word32+    toBuffer = toBufferB3+    getGlType _ = GL_UNSIGNED_INT+    peekPixel = const peekPixel3+    getGlPaddedFormat _ = GL_RGB_INTEGER++instance BufferFormat (B3 Word16) where+    type HostFormat (B3 Word16) = V3 Word16+    toBuffer = toBufferB3+    getGlType _ = GL_UNSIGNED_SHORT+    peekPixel = const peekPixel3+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B3 Word8) where+    type HostFormat (B3 Word8) = V3 Word8+    toBuffer = toBufferB3+    getGlType _ = GL_UNSIGNED_BYTE+    peekPixel = const peekPixel3+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B3 Float) where+    type HostFormat (B3 Float) = V3 Float+    toBuffer = toBufferB3+    getGlType _ = GL_FLOAT+    peekPixel = const peekPixel3+    getGlPaddedFormat _ = GL_RGB++instance BufferFormat (B4 Int32) where+    type HostFormat (B4 Int32) = V4 Int32+    toBuffer = toBufferB4+    getGlType _ = GL_INT+    peekPixel = const peekPixel4+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B4 Int16) where+    type HostFormat (B4 Int16) = V4 Int16+    toBuffer = toBufferB4+    getGlType _ = GL_SHORT+    peekPixel = const peekPixel4+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B4 Int8) where+    type HostFormat (B4 Int8) = V4 Int8+    toBuffer = toBufferB4+    getGlType _ = GL_BYTE+    peekPixel = const peekPixel4+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B4 Word32) where+    type HostFormat (B4 Word32) = V4 Word32+    toBuffer = toBufferB4+    getGlType _ = GL_UNSIGNED_INT+    peekPixel = const peekPixel4+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B4 Word16) where+    type HostFormat (B4 Word16) = V4 Word16+    toBuffer = toBufferB4+    getGlType _ = GL_UNSIGNED_SHORT+    peekPixel = const peekPixel4+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B4 Word8) where+    type HostFormat (B4 Word8) = V4 Word8+    toBuffer = toBufferB4+    getGlType _ = GL_UNSIGNED_BYTE+    peekPixel = const peekPixel4+    getGlPaddedFormat _ = GL_RGBA_INTEGER++instance BufferFormat (B4 Float) where+    type HostFormat (B4 Float) = V4 Float+    toBuffer = toBufferB4+    getGlType _ = GL_FLOAT+    peekPixel = const peekPixel4+    getGlPaddedFormat _ = GL_RGBA
+ src/Graphics/GPipe/Internal/Compiler.hs view
@@ -0,0 +1,672 @@+{-# 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 qualified Data.IntSet as Set+import Data.IntMap ((!))+import Data.Maybe+import Control.Monad+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Control.Monad.Trans.Class++import Graphics.GL.Core45+import Graphics.GL.Types+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.Word+import Graphics.GPipe.Internal.Debug+import System.IO+import Control.Monad.IO.Class++-- public+type WinId = Int++{-+A Drawcall is an OpenGL shader program with its context. Drawcalls are produced+when evaluating a (GPipe) Shader and are intended to be "compiled" (sources+compiled and linked into a program used by a render action).+-}+-- public+data Drawcall s = Drawcall+    {   drawcallFbo :: s ->+        (   Either WinId+                (   IO FBOKeys+                ,   IO ()+                )+        ,   IO ()+        )+    ,   feedbackBuffer :: Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))+        -- Key for RenderIOState::inputArrayToRenderIOs.+    ,   primitiveName :: Int+        -- Key for RenderIOState::rasterizationNameToRenderIO.+    ,   rasterizationName :: Maybe Int+        -- Shader sources.+    ,   vertexSource :: String+    ,   optionalGeometrySource :: Maybe String+    ,   optionalFragmentSource :: Maybe String+        -- Inputs.+    ,   usedInputs :: [Int]+        -- Uniforms and texture units used in each shader.+    ,   usedVUniforms :: [Int],   usedVSamplers :: [Int]+    ,   usedGUniforms :: [Int],   usedGSamplers :: [Int]+    ,   usedFUniforms :: [Int],   usedFSamplers :: [Int]+        -- The size of the uniform buffer for the primitive stream (see USize in PrimitiveStream data).+    ,   primStrUBufferSize :: Int+    }++-- public+mapDrawcall :: (s -> s') -> Drawcall s' -> Drawcall s+mapDrawcall f dc = dc{ drawcallFbo = drawcallFbo dc . f, feedbackBuffer = feedbackBuffer' }+    where+        feedbackBuffer' = case feedbackBuffer dc of+            Nothing -> Nothing+            Just b -> Just (b . f)++-- 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 (in all shaders)+-- and is unlimited(TM)+-- What? Contradiction.+-- Should be used elsewhere instead of Int (of are they pre-alloc Int?).+-- public+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++{- Contains the interactions between a GPipeShader and its environment. It is+populated when creating a GPipeShader and queried when compiling it into a+rendering action. In other words, it’s not a state at all, but some kind of+environment connector or adaptor. It is simply called a state because it build+using a State monad.+-}+-- public+data RenderIOState s = RenderIOState+    {   -- Uniform buffer objects bindings. TODO Return buffer name here when we+        -- start writing to buffers during rendering (transform feedback, buffer+        -- textures) -> Ok, but uniform only?+        uniformNameToRenderIO :: Map.IntMap (s -> Binding -> IO ())+        -- Texture units bindings. IO returns texturename for validating that it+        -- isnt used as render target+    ,   samplerNameToRenderIO :: Map.IntMap (s -> Binding -> IO Int)+        -- Final rasterization operations (mostly setting the viewport).+    ,   rasterizationNameToRenderIO :: Map.IntMap (s -> IO ())+        -- Final vertex processiong stage.+    ,   transformFeedbackToRenderIO :: Map.IntMap (s -> GLuint -> IO ())+        -- VAO bindings.+    ,   inputArrayToRenderIO :: Map.IntMap (s ->+        [   (   [Binding] -- inputs (drawcall's usedInputs)+            ,   GLuint -- primitive stream uniforms buffer+            ,   Int -- primitive stream uniforms buffer size+            ) ->+            (   (   IO [VAOKey] -- VAO names?+                ,   IO () -- To bind the VAO?+                )+            ,   IO () -- To draw with it.+            )+        ])+    }++-- public+newRenderIOState :: RenderIOState s+newRenderIOState = RenderIOState Map.empty Map.empty Map.empty Map.empty Map.empty++-- Why 'map'? Wouldn’t 'inject' be a better name?+-- public+mapRenderIOState :: (s -> s') -> RenderIOState s' -> RenderIOState s -> RenderIOState s+mapRenderIOState f (RenderIOState a' b' c' d' e') (RenderIOState a b c d e) =+    let merge x x' = Map.union x $ Map.map (\ g -> g . f) x'+    in  RenderIOState (merge a a') (merge b b') (merge c c') (merge d d') (merge e e')++-- | May throw a GPipeException+-- The multiple drawcalls to be compiled are intended to use the same environment 's' (and only one is selected dynamically when rendering).+-- public+compileDrawcalls :: (Monad m, MonadIO m, MonadException m, ContextHandler ctx)+    => [IO (Drawcall s)] -- The proto drawcalls to generate and compile.+    -> RenderIOState s -- Interactions between the drawcalls and the environment 's'.+    -> ContextT ctx os m (s -> Render os ()) -- The compiled drawcall (OpenGL program shader actually) as a function on an environment.+compileDrawcalls protoDrawcalls state = do++    (drawcalls, limitErrors) <- liftNonWinContextIO $ safeGenerateDrawcalls protoDrawcalls+    compilationResults <- liftNonWinContextIO $ mapM (innerCompile state) drawcalls+    let (compilationErrors, compiledDrawcalls) = partitionEithers compilationResults+        (programNameAndDeleters, renderers) = unzip compiledDrawcalls+        compositeRenderer x = mapM_ ($ x) renderers+        allErrors = limitErrors ++ compilationErrors++    if null allErrors+        then do+            -- Register each deleter separately on their program finalization.+            forM_ programNameAndDeleters $ \ (programNameRef, deleter) -> do+                programName <- liftIO $ readIORef programNameRef+                addContextFinalizer programNameRef deleter+            -- Return a composite rendering action.+            return compositeRenderer+        else do+            -- Directly call all the deleters.+            liftNonWinContextAsyncIO $ forM_ programNameAndDeleters $ \ (_, deleter) -> do+                deleter+            -- Raise an error.+            liftIO $ throwIO $ GPipeException $ concat allErrors++{- Generate the drawcalls (a single one each time in fact) and check their+inputs don't exceed some OpenGL limits.+-}+-- private+safeGenerateDrawcalls :: [IO (Drawcall s)] -- The proto drawcalls to generate.+    ->  IO (+        [   (   Drawcall s -- A generated drawcall.+            ,   [Int] -- Its uniform buffers used.+            ,   [Int] -- Its textures units used.+            ,   [Int] -- Its allocated uniforms.+            ,   [Int] -- Its allocated texture units.+            )+        ]+        , [String] -- The raised errors regarding exceeded limits.+        )+safeGenerateDrawcalls protoDrawcalls = do++    -- Retrieve some limits from OpenGL.+    [   maxGUnis, maxGSamplers,+        maxVUnis, maxVSamplers,+        maxFUnis, maxFSamplers,+        maxUnis, maxSamplers ]+        <- liftIO $+            mapM (\t -> fromIntegral <$> alloca (\ ptr -> glGetIntegerv t ptr >> peek ptr))+                [ GL_MAX_GEOMETRY_UNIFORM_BLOCKS+                , GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS+                , GL_MAX_VERTEX_UNIFORM_BLOCKS+                , GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS+                , GL_MAX_FRAGMENT_UNIFORM_BLOCKS+                , GL_MAX_TEXTURE_IMAGE_UNITS+                , GL_MAX_COMBINED_UNIFORM_BLOCKS+                , GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS+                ]++    -- Build the drawcalls.+    drawcalls <- liftIO $ sequence protoDrawcalls -- IO only for SNMap++    let+        -- Collect stats from the drawcalls (bound uniforms and texture units).+        gUnisPerDrawcall = map usedGUniforms drawcalls+        gSampsPerDrawcall = map usedGSamplers drawcalls+        vUnisPerDrawcall = map usedVUniforms drawcalls+        vSampsPerDrawcall = map usedVSamplers drawcalls+        fUnisPerDrawcall = map usedFUniforms drawcalls+        fSampsPerDrawcall = map usedFSamplers drawcalls++        -- Consolidate them for the whole program.+        unisPerDrawcall = zipWith orderedUnion (zipWith orderedUnion gUnisPerDrawcall vUnisPerDrawcall) fUnisPerDrawcall+        sampsPerDrawcall = zipWith orderedUnion (zipWith orderedUnion gSampsPerDrawcall vSampsPerDrawcall) fSampsPerDrawcall++        -- Produce an error message for each limit exceeded by at least one of the drawcalls.+        limitErrors = concat+            [ ["Too many uniform blocks used in a single geometry shader\n" | any (\ xs -> length xs >= maxGUnis) gUnisPerDrawcall]+            , ["Too many textures used in a single geometry shader\n" | any (\ xs -> length xs >= maxGSamplers) gSampsPerDrawcall]+            , ["Too many uniform blocks used in a single vertex shader\n" | any (\ xs -> length xs >= maxVUnis) vUnisPerDrawcall]+            , ["Too many textures used in a single vertex shader\n" | any (\ xs -> length xs >= maxVSamplers) vSampsPerDrawcall]+            , ["Too many uniform blocks used in a single fragment shader\n" | any (\ xs -> length xs >= maxFUnis) fUnisPerDrawcall]+            , ["Too many textures used in a single fragment shader\n" | any (\ xs -> length xs >= maxFSamplers) fSampsPerDrawcall]+            , ["Too many uniform blocks used in a single shader program\n" | any (\ xs -> length xs >= maxUnis) unisPerDrawcall]+            , ["Too many textures used in a single shader program\n" | any (\ xs -> length xs >= maxSamplers) sampsPerDrawcall]+            ]++        allocatedUniforms = allocateConsecutiveIndexes maxUnis unisPerDrawcall+        allocatedSamplers = allocateConsecutiveIndexes maxSamplers sampsPerDrawcall++    return (zip5 drawcalls unisPerDrawcall sampsPerDrawcall allocatedUniforms allocatedSamplers, limitErrors)++-- private+innerCompile :: RenderIOState s -- Interactions between the drawcall and the environment 's'.+    ->  ( Drawcall s -- A drawcall with:+        , [Int] -- its uniform buffers used,+        , [Int] -- its textures units used,+        , [Int] -- its allocated uniforms,+        , [Int] -- its allocated texture units.+        )+    ->  IO+        ( Either+            String -- A failure in case the program cannot be compiled in linked.+            ( (IORef GLuint, IO ()) -- The program name and its destructor.+            , s -> Render os () -- The program's renderer as a function on a render (OpenGL) state. Upper stage called this a 'CompiledShader'.+            )+        )+innerCompile state (drawcall, unis, samps, ubinds, sbinds) = do+    let vsource = vertexSource drawcall+        ogsource = optionalGeometrySource drawcall+        ofsource = optionalFragmentSource drawcall+        inputs = usedInputs drawcall++    -- Compile and link the shader program.+    errorOrProgramName <- do+        -- Compile the vertex shader.+        vShader <- glCreateShader GL_VERTEX_SHADER+        mErrV <- compileOpenGlShader vShader vsource+        -- Compile the optional geometry shader.+        (ogShader, mErrG) <- case ogsource of+            Nothing -> return (Nothing, Nothing)+            Just gsource -> do+                gShader <- glCreateShader GL_GEOMETRY_SHADER+                mErrG <- compileOpenGlShader gShader gsource+                return (Just gShader, mErrG)+        -- Compile the fragment shader.+        (ofShader, mErrF) <- case ofsource of+            Nothing -> return (Nothing, Nothing)+            Just fsource -> do+                fShader <- glCreateShader GL_FRAGMENT_SHADER+                mErrF <- compileOpenGlShader fShader fsource+                return (Just fShader, mErrF)++        if all isNothing [mErrV, mErrG, mErrF]+            then do+                pName <- glCreateProgram+                glAttachShader pName vShader++                whenJust' ogShader $ glAttachShader pName+                whenJust' ofShader $ glAttachShader pName+                mapM_ (\(name, ix) -> withCString ("in"++ show name) $ glBindAttribLocation pName ix) $ zip inputs [0..]++                case (feedbackBuffer drawcall, rasterizationName drawcall) of+                    (Nothing, Just _) -> return ()+                    (Just _, Just geoN) -> (transformFeedbackToRenderIO state ! geoN) undefined pName++                mPErr <- linkProgram pName++                glDetachShader pName vShader+                whenJust' ogShader $ glDetachShader pName+                whenJust' ofShader $ glDetachShader pName++                glDeleteShader vShader+                whenJust' ogShader $ glDeleteShader+                whenJust' ofShader $ glDeleteShader++                case mPErr of+                    Just errP -> do+                        glDeleteProgram pName+                        return $ Left $ "Linking a GPU progam failed:\n" ++ errP ++ concat+                            [ maybe "" (\e -> "\nVertex source:\n" ++ e ++ "\n") (Just vsource)+                            , maybe "" (\e -> "\nGeometry source:\n" ++ e ++ "\n") ogsource+                            , maybe "" (\e -> "\nFragment source:\n" ++ e ++ "\n") ofsource+                            ]+                    Nothing -> return $ Right pName+            else do+                glDeleteShader vShader+                whenJust' ogShader $ glDeleteShader+                whenJust' ofShader $ glDeleteShader++                let err = concat+                        [ maybe "" (\e -> "A vertex shader compilation failed:\n" ++ e ++ "\nSource:\n" ++ vsource) mErrV+                        , maybe "" (\e -> "A geometry shader compilation failed:\n" ++ e ++ "\nSource:\n" ++ fromJust ogsource) mErrG+                        , maybe "" (\e -> "A fragment shader compilation failed:\n" ++ e ++ "\nSource:\n" ++ fromJust ofsource) mErrF+                        ]+                return $ Left err++    case errorOrProgramName of+        -- Left: the failure.+        Left err -> return $ Left err+        -- Right: the program wrapped in a Render monad.+        Right pName -> Right <$> case (feedbackBuffer drawcall, rasterizationName drawcall) of+            (Nothing, Just rastN) -> createRenderer state (drawcall, unis, ubinds, samps, sbinds) pName rastN+            (Just getTransformFeedbackName, Just geoN) -> createFeedbackRenderer state (drawcall, unis, ubinds, samps, sbinds) pName getTransformFeedbackName geoN+            _ -> error "No rasterization nor feedback!"++-- private+createRenderer :: RenderIOState s -- Interactions between the drawcall and the environment 's'.+    ->  ( Drawcall s -- A drawcall with:+        , [Int] -- its uniform buffers used,+        , [Int] -- its textures units used,+        , [Int] -- its allocated uniforms,+        , [Int] -- its allocated texture units.+        )+    ->  GLuint -- pName+    ->  Int+    ->  IO  ( (IORef GLuint, IO ()) -- The program name and its destructor.+            , s -> Render os () -- The program's renderer as a function on a render (OpenGL) state.+            )+createRenderer state (drawcall, unis, ubinds, samps, sbinds) pName rastN = do+    let fboSetup = drawcallFbo drawcall+        primN = primitiveName drawcall+        inputs = usedInputs drawcall+        pstrUSize = primStrUBufferSize drawcall++    let pstrUSize' = if 0 `elem` unis then pstrUSize else 0+    pstrUBuf <- createUniformBuffer pstrUSize' -- Create uniform buffer for primiveStream uniforms++    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++    let uNameToRenderIOMap = uniformNameToRenderIO state+        uNameToRenderIOMap' = addPrimitiveStreamUniform pstrUBuf pstrUSize' uNameToRenderIOMap++    -- Drawing with the program.+    let renderer = \x -> Render $ do+            rs <- lift $ lift get+            renv <- lift ask+            let (mFboKeyIO, blendIO) = fboSetup x++            let inwin windowId m = do+                    case Map.lookup windowId (perWindowRenderState rs) of+                        Nothing -> return () -- Window deleted+                        Just (ws, doAsync) -> do+                            lift $ lift $ put (rs { renderLastUsedWin = windowId })+                            mErr <- liftIO $ asSync doAsync $ do+                                pName' <- readIORef pNameRef -- Cant use pName, need to touch pNameRef+                                glUseProgram pName'+                                True <- bind uNameToRenderIOMap' (zip unis ubinds) x (const $ return True)+                                isOk <- bind (samplerNameToRenderIO state) (zip samps sbinds) x (return . not . (`Set.member` renderWriteTextures rs))+                                (rasterizationNameToRenderIO state ! rastN) x+                                blendIO+                                mErr2 <- m+                                let mErr = if isOk+                                        then Nothing+                                        else Just $ "Running shader that samples from texture that currently has an image borrowed from it."+                                            ++ "Try run this shader from a separate render call where no images from the same texture are drawn to or cleared.\n"+                                return $ mErr <> mErr2+                            case mErr of+                                Just e -> throwE e+                                Nothing -> return ()++            -- Bind the framebuffer.+            windowId <- case mFboKeyIO of+                Left wid -> do -- Bind correct context+                    inwin wid $ do+                        glBindFramebuffer GL_DRAW_FRAMEBUFFER 0+                        return Nothing+                    return wid+                Right (fboKeyIO, fboIO) -> do+                    -- Off-screen draw call, continue with last context+                    -- (something wrong here?)+                    (cwid, cd, doAsync) <- unRender getLastRenderWin+                    inwin cwid $ 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 $ mkWeakIORef fbo (doAsync $ 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+                    return cwid++            -- Draw each vertex array.+            forM_ (map ($ (inputs, pstrUBuf, pstrUSize)) ((inputArrayToRenderIO state ! primN) x)) $ \ ((keyIO, vaoIO), drawIO) -> do+                case Map.lookup windowId (perWindowRenderState rs) of+                    Nothing -> return () -- Window deleted+                    Just (ws, doAsync) ->+                        liftIO $ do+                            let cd = windowContextData ws+                            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 $ mkWeakIORef vao (doAsync $ with vao' $ glDeleteVertexArrays 1)+                                    setVAO cd key vao+                                    glBindVertexArray vao'+                                    vaoIO+                            drawIO++    let deleter = do+            glDeleteProgram pName+            when (pstrUSize > 0) $ with pstrUBuf (glDeleteBuffers 1)++    return ((pNameRef, deleter), renderer)++-- private+createFeedbackRenderer :: RenderIOState s -- Interactions between the drawcall and the environment 's'.+    ->  ( Drawcall s -- A drawcall with:+        , [Int] -- its uniform buffers used,+        , [Int] -- its textures units used,+        , [Int] -- its allocated uniforms,+        , [Int] -- its allocated texture units.+        )+    ->  GLuint -- program name+    ->  (s -> IO (GLuint, GLuint, GLuint, GLuint)) -- transform feedback stuff+    ->  Int+    ->  IO  ( (IORef GLuint, IO ()) -- The program name and its destructor.+            , s -> Render os () -- The program's renderer as a function on a render (OpenGL) state.+            )+createFeedbackRenderer state (drawcall, unis, ubinds, samps, sbinds) pName getTransformFeedbackName geoN = do+    let fboSetup = drawcallFbo drawcall+        primN = primitiveName drawcall+        inputs = usedInputs drawcall+        pstrUSize = primStrUBufferSize drawcall++    let pstrUSize' = if 0 `elem` unis then pstrUSize else 0+    pstrUBuf <- createUniformBuffer pstrUSize' -- Create uniform buffer for primiveStream uniforms++    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++    let uNameToRenderIOMap = uniformNameToRenderIO state+        uNameToRenderIOMap' = addPrimitiveStreamUniform pstrUBuf pstrUSize' uNameToRenderIOMap++    -- Drawing with the program.+    let renderer = \x -> Render $ do+            rs <- lift $ lift get+            renv <- lift ask+            let (Left windowId, blendIO) = fboSetup x+                transformFeedback = getTransformFeedbackName x++            case Map.lookup windowId (perWindowRenderState rs) of+                Nothing -> return () -- Window deleted+                Just (ws, doAsync) -> do+                    lift $ lift $ put (rs { renderLastUsedWin = windowId })+                    liftIO $ asSync doAsync $ do+                        pName' <- readIORef pNameRef -- Cant use pName, need to touch pNameRef+                        glUseProgram pName'+                        -- Too late: (transformFeedbackToRenderIO state ! geoN) x pName'+                        True <- bind uNameToRenderIOMap' (zip unis ubinds) x (const $ return True)+                        isOk <- bind (samplerNameToRenderIO state) (zip samps sbinds) x (return . not . (`Set.member` renderWriteTextures rs))+                        blendIO++                    -- Draw each vertex array.+                    forM_ (map ($ (inputs, pstrUBuf, pstrUSize)) ((inputArrayToRenderIO state ! primN) x)) $ \ ((keyIO, vaoIO), drawIO) -> liftIO $ do+                        let cd = windowContextData ws+                        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 $ mkWeakIORef vao (doAsync $ with vao' $ glDeleteVertexArrays 1)+                                setVAO cd key vao+                                glBindVertexArray vao'+                                vaoIO+                        (bName, tfName, tfqName, topology) <- transformFeedback+                        glBindTransformFeedback GL_TRANSFORM_FEEDBACK tfName+                        glBindBufferBase GL_TRANSFORM_FEEDBACK_BUFFER 0 bName+                        glBeginQuery GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN tfqName+                        -- liftIO $ hPutStrLn stderr $ "doing transform feedback"+                        glBeginTransformFeedback topology+                        glEnable GL_RASTERIZER_DISCARD+                        drawIO+                        glDisable GL_RASTERIZER_DISCARD+                        glEndTransformFeedback+                        glEndQuery(GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN);+                        {-+                        l <- alloca $ \ptr -> do+                            glGetQueryObjectiv tfqName GL_QUERY_RESULT ptr+                            peek ptr+                        liftIO $ hPutStrLn stderr $ "generated primitive count: " ++ show l+                        -}++    let deleter = do+            glDeleteProgram pName+            when (pstrUSize > 0) $ with pstrUBuf (glDeleteBuffers 1)++    return ((pNameRef, deleter), renderer)++-- private+compileOpenGlShader :: GLuint -> String -> IO (Maybe String)+compileOpenGlShader name source = do+    -- writeFile ("shaders/" ++ show name ++ ".glsl") source -- For debug purposes only.+    withCStringLen source $ \ (ptr, len) ->+                                with ptr $ \ pptr ->+                                    with (fromIntegral len) $ \ plen ->+                                        glShaderSource name 1 pptr plen+    -- putStrLn $ "Compiling shader " ++ show name+    glCompileShader name+    -- putStrLn $ "Compiled shader " ++ show 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+            fmap Just $ allocaArray logLen' $ \ ptr -> do+                glGetShaderInfoLog name logLen nullPtr ptr+                peekCString ptr++-- private+linkProgram :: GLuint -> IO (Maybe String)+linkProgram name = do+    -- putStrLn $ "Linking program " ++ show name+    glLinkProgram name+    -- putStrLn $ "Linked program " ++ show 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+            fmap Just $ allocaArray logLen' $ \ ptr -> do+                glGetProgramInfoLog name logLen nullPtr ptr+                peekCString ptr++-- private+createUniformBuffer :: Integral a => a -> IO GLuint+createUniformBuffer 0 = return undefined+createUniformBuffer uSize = do+    bname <- alloca $ \ ptr -> glGenBuffers 1 ptr >> peek ptr+    glBindBuffer GL_COPY_WRITE_BUFFER bname+    glBufferData GL_COPY_WRITE_BUFFER (fromIntegral uSize) nullPtr GL_STREAM_DRAW+    return bname++-- private+addPrimitiveStreamUniform :: Word32 -> Int -> Map.IntMap (s -> Binding -> IO ()) -> Map.IntMap (s -> Binding -> IO ())+addPrimitiveStreamUniform _ 0 = id+addPrimitiveStreamUniform bname uSize = Map.insert 0 $ \_ bind -> glBindBufferRange GL_UNIFORM_BUFFER (fromIntegral bind) bname 0 (fromIntegral uSize)++-- private+bind :: Map.IntMap (s -> Binding -> IO x)+    -> [(Int, Int)]+    -> s+    -> (x -> IO Bool) -- Used to assert we may use textures bound as render targets+    -> IO Bool+bind iom ((n,b):xs) s a = do+    ok1 <- bind iom xs s a+    ok2 <- (iom ! n) s b >>= a+    return $ ok1 && ok2+bind _ [] _ _ = return True++-- private+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++-- private+oldAllocateWhichGiveStrangeResults :: Int -> [[Int]] -> [[Int]]+oldAllocateWhichGiveStrangeResults 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++{-+Map the input values into [0, mx[ with no gap. Two different values in the+input are mapped to two different values in the output as long as the `mx`+size of the output set is no reach. The `mx+1` nth value and beyond are+mapped to… I can't figure it!. Let's just raise an error instead.++Note that the fact that the values are stored in a list of lists doesn't+matter, we are just mapping a tree of values to another without caring about+the traversed structure.+-}+-- private+allocateConsecutiveIndexes :: Int -> [[Int]] -> [[Int]]+allocateConsecutiveIndexes mx values = evalState (mapM (mapM allocateIndex) values) Map.empty where+    allocateIndex n = do+        mapping <- get+        case Map.lookup n mapping of+            Nothing -> do+                let m = Map.size mapping+                if m < mx+                    then do+                        put $ Map.insert n m mapping+                        return m+                    else error "Not enough indexes available!"+            Just m -> return m++-- public+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"++-- | A 'whenJust' that accepts a monoidal return value.+-- private+whenJust' :: (Monad m, Monoid b) => Maybe a -> (a -> m b) -> m b+whenJust' = flip $ maybe (return mempty)
+ src/Graphics/GPipe/Internal/Context.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE TypeFamilies, RankNTypes, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, GADTs, DeriveDataTypeable #-}++module Graphics.GPipe.Internal.Context+(+    ContextHandler(..),+    ContextT(),+    GPipeException(..),+    runContextT,+    newWindow,+    deleteWindow,+    swapWindowBuffers,+    getFrameBufferSize,+    withContextWindow,+    WindowState(..),+    RenderState(..),+    liftNonWinContextIO,+    liftNonWinContextAsyncIO,+    addContextFinalizer,+    Window(..),+    addVAOBufferFinalizer,+    addFBOTextureFinalizer,+    getVAO, setVAO,+    getFBO, setFBO,+    ContextData,+    VAOKey(..), FBOKey(..), FBOKeys(..),+    Render(..), render,+    registerRenderWriteTexture,+    getLastRenderWin,+    asSync+)+where++import Graphics.GPipe.Internal.Format+import Control.Monad.Exception (MonadException, Exception, MonadAsyncException,bracket)+import Control.Monad.Trans.Reader+import qualified Control.Monad.Fail as MF+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Typeable+import qualified Data.IntSet as Set+import qualified Data.IntMap.Strict as IMap+import Data.IntMap ((!))+import qualified Data.Map.Strict as Map+import Graphics.GL.Core45+import Graphics.GL.Types+import Control.Concurrent.MVar+import Data.IORef+import Control.Monad+import Data.Maybe+import Linear.V2 (V2(V2))+import Control.Monad.Trans.Except+import Control.Exception (throwIO)+import Control.Monad.Trans.State.Strict++-- | Class implementing a window handler that can create openGL contexts, such as GLFW or GLUT+class ContextHandler ctx where+  -- | Implementation specific context handler parameters, eg error handling and event processing policies+  data ContextHandlerParameters ctx+  -- | Implementation specific window type+  type ContextWindow ctx+  -- | Implementation specific window parameters, eg initial size and border decoration+  type WindowParameters ctx+  -- | Create a context handler. Called from the main thread+  contextHandlerCreate :: ContextHandlerParameters ctx -> IO ctx+  -- | Delete the context handler. All contexts created from this handler will be deleted using contextDelete prior to calling this.+  contextHandlerDelete :: ctx -> IO ()+  -- | Create a new context sharing all other contexts created by this ContextHandler. If the parameter is Nothing,+  --   a hidden off-screen context is created, otherwise creates a window with the provided window bits and implementation specific parameters.+  --   Only ever called from the mainthread (i.e. the thread that called contextHandlerCreate).+  createContext :: ctx -> Maybe (WindowBits, WindowParameters ctx) -> IO (ContextWindow ctx)+  -- | Run an OpenGL IO action in this context, that doesn't return any value to the caller. This may be run after contextDelete or contextHandlerDelete has been called.+  --   The thread calling this may not be the same creating the context (for finalizers it is most definetly not).+  --   May also be called on previously deleted windows in the case of finalizers.+  contextDoAsync :: ctx -> Maybe (ContextWindow ctx) -> IO () -> IO ()+  -- | Swap the front and back buffers in the context's default frame buffer.+  --   Only ever called from the mainthread (i.e. the thread that called 'contextHandlerCreate').+  --   Never called on deleted windows.+  contextSwap :: ctx -> ContextWindow ctx -> IO ()+  -- | Get the current size of the context's default framebuffer (which may change if the window is resized).+  --   Only ever called from the mainthread (i.e. the thread that called 'contextHandlerCreate')+  contextFrameBufferSize :: ctx -> ContextWindow ctx -> IO (Int, Int)+  -- | Delete a context and close any associated window.+  --   Only ever called from the mainthread (i.e. the thread that called 'contextHandlerCreate'). Only ever called once per window,+  --   and will always be called for each window before the context is deleted with 'contextHandlerDelete'.+  contextDelete :: ctx -> ContextWindow ctx -> IO ()+++-- | The monad transformer that encapsulates a GPipe context (which wraps an OpenGl context).+--+--   A value of type @ContextT ctx os m a@ is an action on a context with these parameters:+--+--   [@ctx@] The context handler.+--+--   [@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).+--+--   [@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 ctx os m a =+    ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a)+    deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadAsyncException)++data ContextEnv ctx = ContextEnv {+    context :: ctx,+    sharedContextData :: SharedContextDatas+  }++data ContextState ctx = ContextState {+    nextName :: Name,+    perWindowState :: PerWindowState ctx,+    lastUsedWin :: Name -- -1 is no window. 0 is the hidden window. 1.. are visible windows+  }++-- | A monad in which shaders are run.+newtype Render os a = Render { unRender :: ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) a } deriving (Monad, Applicative, Functor)++data RenderEnv = RenderEnv {+    renderSharedContextData :: SharedContextDatas,+    nonWindowDoAsync :: ContextDoAsync+  }++data RenderState = RenderState {+    perWindowRenderState :: PerWindowRenderState,+    renderWriteTextures :: Set.IntSet,+    renderLastUsedWin :: Name+  }++type Name = Int++type ContextDoAsync = IO () -> IO ()++type PerWindowState ctx = IMap.IntMap (WindowState, ContextWindow ctx) -- -1 is no window. 0 is the hidden window. 1.. are visible windows+type PerWindowRenderState = IMap.IntMap (WindowState, ContextDoAsync)+data WindowState = WindowState {+    windowContextData :: !ContextData+  }++-- | Run a 'Render' monad, that may have the effect of windows 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 :: (ContextHandler ctx, MonadIO m, MonadException m) => Render os () -> ContextT ctx os m ()+render (Render m) = do+  void getLastContextWin -- To create hidden window if needed+  ContextT $ do+    ContextEnv ctx cds <- ask+    cs <- lift get+    let wmap' = IMap.map (\(ws,w) -> (ws, contextDoAsync ctx (Just w))) $ perWindowState cs+    (eError, rs) <- liftIO $ runStateT (runReaderT (runExceptT m) (RenderEnv cds (contextDoAsync ctx Nothing))) (RenderState wmap' Set.empty (lastUsedWin cs))+    lift $ put $ cs { lastUsedWin = renderLastUsedWin rs}+    case eError of+      Left s -> liftIO $ throwIO $ GPipeException s+      _ -> return ()++registerRenderWriteTexture :: Int -> Render os ()+registerRenderWriteTexture n = Render $ lift $ lift $ modify $ \ rs -> rs { renderWriteTextures = Set.insert n $ renderWriteTextures rs }++instance MonadTrans (ContextT ctx os) where+    lift = ContextT . lift . lift++instance MonadIO m => MF.MonadFail (ContextT ctx os m) where+    fail = liftIO . MF.fail++-- | Run a 'ContextT' monad transformer that encapsulates an object space.+--   You need an implementation of a 'ContextHandler', which is provided by an auxillary package, such as @GPipe-GLFW@.+runContextT :: (MonadIO m, MonadAsyncException m, ContextHandler ctx) => ContextHandlerParameters ctx -> (forall os. ContextT ctx os m a) -> m a+runContextT chp (ContextT m) = do+    cds <- liftIO newContextDatas+    bracket+     (liftIO $ contextHandlerCreate chp)+     (\ctx -> liftIO $ do+       cds' <- readMVar cds+       mapM_ snd cds' -- Delete all windows not explicitly deleted+       contextHandlerDelete ctx+     )+     (\ctx -> evalStateT (runReaderT m (ContextEnv ctx cds)) (ContextState 1 IMap.empty (-1)))++data Window os c ds = Window { getWinName :: Name }++instance Eq (Window os c ds) where+  (Window a) == (Window b) = a == b++createHiddenWin :: (ContextHandler ctx, MonadIO m) => ContextT ctx os m (ContextWindow ctx)+createHiddenWin = ContextT $ do+  ContextEnv ctx cds <- ask+  ContextState wid _ _ <- lift get -- We need to keep next window id and not start over at 1+  w <- liftIO $ createContext ctx Nothing+  cd <- liftIO $ addContextData (contextDelete ctx w) cds+  let ws = WindowState cd+  lift $ put $ ContextState wid (IMap.singleton 0 (ws,w)) 0+  liftIO $ contextDoAsync ctx (Just w) initGlState+  return w++-- | Creates a window+newWindow :: (ContextHandler ctx, MonadIO m) => WindowFormat c ds -> WindowParameters ctx -> ContextT ctx os m (Window os c ds)+newWindow wf wp = ContextT $ do+  ContextEnv ctx cds <-  ask+  ContextState wid wmap _ <- lift get+  w <- liftIO $ createContext ctx (Just (windowBits wf, wp))+  cd <- liftIO $ addContextData (contextDelete ctx w) cds+  let wid' = wid+1+  let ws = WindowState cd+  lift $ put $ ContextState wid' (IMap.insert wid (ws,w) wmap) wid+  liftIO $ contextDoAsync ctx (Just w) initGlState+  return $ Window wid++-- | Deletes a window. Any rendering to this window will become a noop.+deleteWindow :: (ContextHandler ctx, MonadIO m) => Window os c ds -> ContextT ctx os m ()+deleteWindow (Window wid) = ContextT $ do+  ContextState nid wmap n <- lift get+  case IMap.lookup wid wmap of+    Nothing -> return ()+    Just (ws, w) -> do+      ContextEnv ctx cds <-  ask+      let wmap' = IMap.delete wid wmap+      n' <- if (IMap.null wmap')+              then do+                void $ let ContextT m = createHiddenWin in m -- Create a hidden window before we delete last window+                return 0 -- The hidden window is now Current+              else if n /= wid then return n+                               else return (fst (head (IMap.toList wmap'))) -- always at least one elem+      liftIO $ do removeContextData cds (windowContextData ws)+                  contextDelete ctx w+      lift $ put $ ContextState nid wmap' n'++initGlState :: IO ()+initGlState = do+  glEnable GL_FRAMEBUFFER_SRGB+  glEnable GL_SCISSOR_TEST+  glPixelStorei GL_PACK_ALIGNMENT 1+  glPixelStorei GL_UNPACK_ALIGNMENT 1++asSync :: (IO () -> IO ()) -> IO x -> IO x+asSync f m = do mutVar <- newEmptyMVar+                f (m >>= putMVar mutVar)+                takeMVar mutVar++getLastContextWin :: (ContextHandler ctx, MonadIO m) => ContextT ctx os m (ContextWindow ctx)+getLastContextWin = ContextT $ do+  cs <- lift get+  let wid = lastUsedWin cs+  if wid >= 0+    then return (snd $ perWindowState cs ! wid) -- always exists, since delete context will change lastUsedWin for us+    else let ContextT m = createHiddenWin in m++liftNonWinContextIO :: (ContextHandler ctx, MonadIO m) => IO a -> ContextT ctx os m a+liftNonWinContextIO m = do+  ContextEnv ctx _ <- ContextT ask+  w <- getLastContextWin+  ContextT $ liftIO $ asSync (contextDoAsync ctx (Just w)) m++liftNonWinContextAsyncIO :: (ContextHandler ctx, MonadIO m) => IO () -> ContextT ctx os m ()+liftNonWinContextAsyncIO m = do+  ContextEnv ctx _ <- ContextT ask+  w <- getLastContextWin+  ContextT $ liftIO $ contextDoAsync ctx (Just w) m+++addContextFinalizer :: (ContextHandler ctx, MonadIO m) => IORef a -> IO () -> ContextT ctx os m ()+addContextFinalizer k m = ContextT $ do+  ContextEnv ctx _ <- ask+  liftIO $ void $ mkWeakIORef k $ contextDoAsync ctx Nothing m+++getLastRenderWin = Render $ do+  rs <- lift $ lift get+  let cwid = renderLastUsedWin rs -- There is always a window available since render calls getLastContextWin+  let (ws, doAsync) = perWindowRenderState rs ! cwid+      cd = windowContextData ws+  return (cwid, cd, doAsync)++-- | 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.+swapWindowBuffers :: (ContextHandler ctx, MonadIO m) => Window os c ds -> ContextT ctx os m ()+swapWindowBuffers (Window wid) = ContextT $ do+  wmap <- lift $ gets perWindowState+  case IMap.lookup wid wmap of+    Nothing -> return ()+    Just (_, w) -> do+      ctx <- asks context+      liftIO $ contextSwap ctx w+++-- | 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.+getFrameBufferSize :: (ContextHandler ctx, MonadIO m) => Window os c ds -> ContextT ctx os m (V2 Int)+getFrameBufferSize (Window wid) = ContextT $ do+  wmap <- lift $ gets perWindowState+  case IMap.lookup wid wmap of+    Nothing -> return $ V2 0 0+    Just (_, w) -> do+      ctx <- asks context+      (x,y) <- liftIO $ contextFrameBufferSize ctx w+      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 => Window os c ds -> (Maybe (ContextWindow ctx) -> IO a) -> ContextT ctx os m a+withContextWindow (Window wid) m = ContextT $ do+  wmap <- lift $ gets perWindowState+  liftIO $ m (snd <$> IMap.lookup wid wmap)++-- | 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)+  #-}+-}+--------------------------++-- | The reason we need this is that we need to bind a finalizer to a buffer or texture that removes all references VAOs or FBOs from all+--   known ContextData at a future point, where more Contexts may have been created.+type SharedContextDatas = MVar [(ContextData, IO ())] -- IO to delete windows+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 SharedContextDatas+newContextDatas = newMVar []++addContextData :: IO () -> SharedContextDatas -> IO ContextData+addContextData io r = do cd <- newMVar (Map.empty, Map.empty)+                         modifyMVar_ r $ return . ((cd,io):)+                         return cd++removeContextData :: SharedContextDatas -> ContextData -> IO ()+removeContextData r cd = modifyMVar_ r $ return . remove cd+  where remove x ((k,v):xs) | x == k = xs+        remove x (kv:xs)             = kv : remove x xs+        remove _ []                  = []++addCacheFinalizer :: MonadIO m => (GLuint -> (VAOCache, FBOCache) -> (VAOCache, FBOCache)) -> IORef GLuint -> ContextT ctx os m ()+addCacheFinalizer f r =  ContextT $ do cds <- asks sharedContextData+                                       liftIO $ do n <- readIORef r+                                                   void $ mkWeakIORef r $ do cs' <- readMVar cds+                                                                             mapM_ (\(cd,_) -> modifyMVar_ cd (return . f n)) cs'++-- | Removes a VAO entry from all SharedContextDatas when one of the buffers are deleted. This will in turn make the VAO finalizer to be run.+addVAOBufferFinalizer :: MonadIO m => IORef GLuint -> ContextT ctx os m ()+addVAOBufferFinalizer = addCacheFinalizer deleteVAOBuf+    where deleteVAOBuf n (vao, fbo) = (Map.filterWithKey (\k _ -> all ((/=n) . vaoBname) k) vao, fbo)+++-- | Removes a FBO entry from all SharedContextDatas when one of the textures are deleted. This will in turn make the FBO finalizer to be run.+addFBOTextureFinalizer :: MonadIO m => Bool -> IORef GLuint -> ContextT ctx os 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)+++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)
+ src/Graphics/GPipe/Internal/Debug.hs view
@@ -0,0 +1,33 @@+module Graphics.GPipe.Internal.Debug where++import Control.Monad+import Data.Maybe+import Data.List (intercalate)+import qualified Debug.Trace as Trace+import Graphics.GL.Core45+import Graphics.GL.Types++traceIt :: Show a => String -> a -> a+traceIt t a = Trace.trace (t ++ " = " ++ show a) a++traceList :: Show a => String -> [a] -> [a]+traceList t as = Trace.trace (t ++ " = [\n\t" ++ intercalate "\n\t" (map show as) ++ "\n]") as++checkGlError :: String -> IO ()+checkGlError title = do+    e <- glGetError+    when (e /= GL_NO_ERROR) $ do+        error $ "[" ++ title ++ "] GL error -> " ++ getErrorMessage e++getErrorMessage :: GLenum -> String+getErrorMessage errorCode = fromMaybe ("Unknown error code " ++ show errorCode) $ lookup errorCode+    [ (GL_NO_ERROR, "GL_NO_ERROR")+    , (GL_INVALID_ENUM, "GL_INVALID_ENUM")+    , (GL_INVALID_VALUE, "GL_INVALID_VALUE")+    , (GL_INVALID_OPERATION, "GL_INVALID_OPERATION")+    , (GL_STACK_OVERFLOW, "GL_STACK_OVERFLOW")+    , (GL_STACK_UNDERFLOW, "GL_STACK_UNDERFLOW")+    , (GL_OUT_OF_MEMORY, "GL_OUT_OF_MEMORY")+    , (GL_INVALID_FRAMEBUFFER_OPERATION, "GL_INVALID_FRAMEBUFFER_OPERATION")+    , (GL_CONTEXT_LOST, "GL_CONTEXT_LOST")+    ]
+ src/Graphics/GPipe/Internal/Expr.hs view
@@ -0,0 +1,1412 @@+{-# LANGUAGE GADTs, EmptyDataDecls, NoMonomorphismRestriction, TypeFamilies, ScopedTypeVariables, FlexibleInstances, RankNTypes, MultiParamTypeClasses, FlexibleContexts, OverloadedStrings, ViewPatterns, RecordWildCards #-}++module Graphics.GPipe.Internal.Expr where++import Prelude hiding ((.), id, (<*))+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.Maybe+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 (liftA, liftA2, liftA3)+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 Linear.Conjugate+import Data.Foldable (Foldable(toList))+import Data.Int+import Data.Word+import Data.Bits -- (FiniteBits(finiteBitSize))++type NextTempVar = Int+type NextGlobal = Int++data SType = STypeFloat | STypeInt | STypeBool | STypeUInt | STypeDyn String | STypeMat Int Int | STypeVec Int | STypeIVec Int | STypeUVec Int | STypeGenerativeGeometry++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+stypeName STypeGenerativeGeometry = "bool" -- A generative geometry is inherently a write-only value. The 'bool' type is simply here as a crude workaround (hardly a solution).++stypeSize :: SType -> Int+stypeSize (STypeVec n) = n * 4+stypeSize (STypeIVec n) = n * 4+stypeSize (STypeUVec n) = n * 4+stypeSize _ = 4++-- A functional shader expression.+type ExprM = SNMapReaderT+    [String] -- Cached GLSL source code.+    (StateT+        ExprState -- Shader inputs.+        (WriterT+            String -- Generated GLSL source code.+            (StateT+                NextTempVar -- Next unique variable name.+                IO -- IO to create stable names.+            )+        )+    )++type GlobDeclM = Writer String++data ExprState = ExprState+    {   shaderUsedUniformBlocks :: Map.IntMap (GlobDeclM ())+    ,   shaderUsedSamplers :: Map.IntMap (GlobDeclM ())+    ,   shaderUsedInput :: Map.IntMap -- (For vertex shaders, the value is always undefined and the int is the parameter name, for later shader stages it uses some name local to the transition instead)+        (   GlobDeclM () -- Input declarations for the current shader+        ,   (   ExprM () -- Output assignement required in the previous shader (obviously undefined for the first shader - see comment below.)+            ,   GlobDeclM () -- Output declaration required in the previous shader.+            ) -- Requirements for the previous shader.+        )+    ,   shaderGeometry :: Maybe (GlobDeclM ()) -- Input/ouput layout declarations for current shader (if it is a geometry shader).+    }++data ExprResult = ExprResult+    { finalSource :: String -- Shader source produced.+    , unis        :: [Int] -- Uniforms used in this shader.+    , samps       :: [Int] -- Samplers used in this shader.+    , inps        :: [Int] -- Inputs used in this shader (only varying or uniforms too?).+    , prevDecls   :: GlobDeclM () -- Output declarations required in the previous shader (how it differs from the inputs used?).+    , prevSs      :: ExprM () -- Expression to construct in the previous shader.+    }++{- Rough idea:++    makeDrawcall (sh, shd, _) =+        do  (fsource, funis, fsamps, _, prevDecls1, prevS1) <- runExprM shd sh+            (gsource, gunis, gsamps, _, prevDecls2, prevS2) <- runExprM prevDecls1 prevS1+            (vsource, vunis, vsamps, vinps, _, _) <- runExprM prevDecls2 prevS2+            return $ Drawcall _ _ _ vsource gsource fsource vinps vunis vsamps gunis gsamps funis fsamps _++    A sN expression's leafs are literals and input variables from the previous+    shader (shaders are evaluated here in reverse order). Evaluationg a sN+    expression produces a source and a sN+1 expression to be evaluated in the+    previous shader. This sN+1 expression obtained when evaluating a sN+    expression basically contains the values transformed by the matching arrow+    (ToVertex, ToFragment...). In this regard, the evaluation is the inverse+    arrow with the side effect of outputting the shader source.+-}+runExprM+    :: GlobDeclM () -- output declarations to include in this shader+    -> ExprM () -- expression to construct in this shader (including assignements to the output variables)+    -> IO ExprResult+runExprM d m = do+    (st, body) <- evalStateT (runWriterT (execStateT (runSNMapReaderT m) (ExprState Map.empty Map.empty Map.empty Nothing))) 0+    let (unis, uniDecls) = unzip $ Map.toAscList (shaderUsedUniformBlocks st)+        (samps, sampDecls) = unzip $ Map.toAscList (shaderUsedSamplers st)+        (inps, inpDescs) = unzip $ Map.toAscList (shaderUsedInput st)+        geoDescs = shaderGeometry st+        (inpDecls, prevDesc) = unzip inpDescs+        (sequence_ -> prevSs, sequence_ -> prevDecls) = unzip prevDesc+        decls = do+            d+            when (isJust geoDescs) (fromJust geoDescs)+            sequence_ uniDecls+            sequence_ sampDecls+            sequence_ inpDecls+        finalSource = mconcat+            [ "#version 450\n"+            , execWriter decls+            , "void main() {\n"+            , body+            , "}\n"+            ]+    return ExprResult{..}++--------------------------------------------------------------------------------+-- The section below is just an unused draft.+--------------------------------------------------------------------------------++data ShaderStageInput = ShaderStageInput+    {    -- The output declarations to include in the shader's source.+        outputDeclarations :: GlobDeclM ()+        -- The expression to evaluate as a source using variables to be provided+        -- by a previous shader (or buffer object). The top level of this+        -- expression is expected (how exactly?) to assign a value to the output+        -- variables declared above.+    ,   expression :: ExprM ()+    }++data ShaderStageOutput = ShaderStageOutput+    {   source :: String -- ^ The shader GLSL source to be compiled.+    ,   uniforms :: [Int] -- ^ The uniforms used in this shader.+    ,   samplers :: [Int] -- ^ The samplers used in this shader.+    ,   inputs :: [Int] -- ^ The input variables used in this shader.+    ,   previousDeclarations :: GlobDeclM () -- ^ The output declations to include in the previous shader to provide the needed input variables.+    ,   prevExpression :: ExprM () -- ^ The expression to evaluate in order to produce the previous shader.+    }++evaluateExpression :: [ExprM ()] -> ExprM () -> GlobDeclM () -> IO ShaderStageOutput+evaluateExpression staticExpressions expression requiredOutputDeclarations = do+    ExprResult s u ss is pds pe <- runExprM requiredOutputDeclarations expression+    case staticExpressions of+        (se:ses) -> evaluateExpression ses (pe >> se) pds+        [] -> return $ ShaderStageOutput s u ss is pds pe++--------------------------------------------------------------------------------++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++-- | Phantom type used as first argument in @'S' 'F' a@ that denotes that the shader value is a fragment value+data F++-- | We reuse V for geometry shader, which simplify things and makes sense save the GenerativeGeometry…+type G = V+newtype GenerativeGeometry p a = GenerativeGeometry a++type VFloat = S V Float+type VInt = S V Int+type VWord = S V Word+type VBool = S V Bool++type GGenerativeGeometry p a = S G (GenerativeGeometry p a)++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++useGInput :: String -> SType -> Int -> Int -> ExprM String -> ExprM String+useGInput qual stype i n v = do+    s <- T.lift get+    T.lift $ put $ s { shaderUsedInput = Map.insert n (gDeclIn, (assignOutput, gDeclOut)) $ shaderUsedInput s }+    return $ prefix ++ show n ++ "[" ++ show i ++ "]"+    where+        prefix = "vg"++        -- Output assignement in the previous shader+        assignOutput = do+            val <- v+            let name = prefix ++ show n+            tellAssignment' name val++        -- Output declaration in the previous shader.+        gDeclOut = do+            tellGlobal $ qual ++ " out "+            tellGlobal $ stypeName stype+            tellGlobal $ ' ':prefix+            tellGlobalLn $ show n++        -- Input declaration in the current shader.+        gDeclIn = do+            tellGlobal $ qual ++ " in "+            tellGlobal $ stypeName stype+            tellGlobal $ ' ':prefix+            tellGlobal $ show n+            tellGlobalLn $ "[]"++useFInputFromG :: String -> SType -> Int -> ExprM String -> ExprM String+useFInputFromG qual stype i v = do+    s <- T.lift get+    val :: Int <- read <$> v+    T.lift $ put $ s { shaderUsedInput = Map.insert i (gDecl val (qual ++ " in "), (return (), gDecl val (qual ++ " out "))) $ shaderUsedInput s }+    return $ prefix ++ show val+    where+        prefix = "vgf"++        gDecl val s = do+            tellGlobal s+            tellGlobal $ stypeName stype+            tellGlobal $ ' ':prefix+            tellGlobalLn $ show val++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++declareGeometryLayout :: String -> String -> Int -> ExprM ()+declareGeometryLayout inputPrimitive outputPrimitive maxVertices = T.lift $ modify $ \ s -> s { shaderGeometry = Just gDeclBlock }+    where+        gDeclBlock = do+            tellGlobalLn $ "layout(" ++ inputPrimitive ++ ") in"+            tellGlobalLn $ "layout(" ++ outputPrimitive ++ ", max_vertices = " ++ show maxVertices ++ ") out"++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++-----------------------++-- | An opaque type+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+    ShaderBaseGenerativeGeometry :: S x (GenerativeGeometry p a) -> ShaderBase (S x (GenerativeGeometry p a)) 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'+shaderbaseDeclare (ShaderBaseGenerativeGeometry _) = ShaderBaseGenerativeGeometry <$> shaderbaseDeclareDef STypeGenerativeGeometry++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+shaderbaseAssign (ShaderBaseGenerativeGeometry a) = shaderbaseAssignDef a++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'+shaderbaseReturn (ShaderBaseGenerativeGeometry _) = ShaderBaseGenerativeGeometry <$> shaderbaseReturnDef++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 x a) -> StateT [String] ExprM ()+shaderbaseAssignDef (S shaderM) = do+    ul <- T.lift shaderM+    xs <- get+    put $ tail xs+    T.lift $ tellAssignment' (head xs) ul+    return ()++shaderbaseReturnDef :: ReaderT (ExprM [String]) (State Int) (S x a)+shaderbaseReturnDef = do+    i <- T.lift getNext+    m <- ask+    return $ S $ fmap (!!i) m++-- | Constraint for types that may pass in and out of shader control structures. Define your own instances in terms of others and make sure to+--   make toBase as lazy as possible.+class ShaderType a x where+    -- | A base type that this type can convert into. Use the 'ShaderBaseType' function on an existing instance of 'ShaderType' to define this in your instance.+    type ShaderBaseType a+    -- | Convert this type to the shader base type. Make sure this is as lazy as possible (e.g. use tilde (@~@) on each pattern match).+    toBase :: x -> a -> ShaderBase (ShaderBaseType a) x+    -- | Convert back from the shader base type to this type.+    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 (S x (GenerativeGeometry p a)) x where+    type ShaderBaseType (S x (GenerativeGeometry p a)) = (S x (GenerativeGeometry p a))+    toBase _ = ShaderBaseGenerativeGeometry+    fromBase _ (ShaderBaseGenerativeGeometry a) = a++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)+instance (ShaderType a x, ShaderType b x, ShaderType c x, ShaderType d x, ShaderType e x) => ShaderType (a,b,c,d,e) x where+    type ShaderBaseType (a,b,c,d,e) = (ShaderBaseType a, (ShaderBaseType b, (ShaderBaseType c, (ShaderBaseType d, ShaderBaseType e))))+    toBase x ~(a,b,c,d,e) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (ShaderBaseProd (toBase x d) (toBase x e))))+    fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c (ShaderBaseProd d e)))) = (fromBase x a, fromBase x b, fromBase x c, fromBase x d, fromBase x e)+instance (ShaderType a x, ShaderType b x, ShaderType c x, ShaderType d x, ShaderType e x, ShaderType f x) => ShaderType (a,b,c,d,e,f) x where+    type ShaderBaseType (a,b,c,d,e,f) = (ShaderBaseType a, (ShaderBaseType b, (ShaderBaseType c, (ShaderBaseType d, (ShaderBaseType e, ShaderBaseType f)))))+    toBase x ~(a,b,c,d,e,f) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (ShaderBaseProd (toBase x d) (ShaderBaseProd (toBase x e) (toBase x f)))))+    fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c (ShaderBaseProd d (ShaderBaseProd e f))))) = (fromBase x a, fromBase x b, fromBase x c, fromBase x d, fromBase x e, fromBase x f)+instance (ShaderType a x, ShaderType b x, ShaderType c x, ShaderType d x, ShaderType e x, ShaderType f x, ShaderType g x) => ShaderType (a,b,c,d,e,f,g) x where+    type ShaderBaseType (a,b,c,d,e,f,g) = (ShaderBaseType a, (ShaderBaseType b, (ShaderBaseType c, (ShaderBaseType d, (ShaderBaseType e, (ShaderBaseType f, ShaderBaseType g))))))+    toBase x ~(a,b,c,d,e,f,g) = ShaderBaseProd (toBase x a) (ShaderBaseProd (toBase x b) (ShaderBaseProd (toBase x c) (ShaderBaseProd (toBase x d) (ShaderBaseProd (toBase x e) (ShaderBaseProd (toBase x f) (toBase x g))))))+    fromBase x (ShaderBaseProd a (ShaderBaseProd b (ShaderBaseProd c (ShaderBaseProd d (ShaderBaseProd e (ShaderBaseProd f g)))))) = (fromBase x a, fromBase x b, fromBase x c, fromBase x d, fromBase x e, fromBase x f, fromBase x g)++-- | Works just like 'ifB', return second argument if first is 'true' otherwise return third argument.+--+-- The difference from 'ifB' is that it in most cases generate more efficient code when @a@ is a compound type (e.g. a tuple or a vector).+-- For simple types such as @S x Float@, @ifThenElse' == ifB@.+ifThenElse' :: forall a x. (ShaderType a x) => S x Bool -> a -> a -> a+ifThenElse' b t e = ifThenElse b (const t) (const e) ()++-- | @ifThenElse c f g x@ will return @f x@ if @c@ evaluates to 'true' or @g x@ otherwise.+--+--   In most cases functionally equivalent to 'ifThenElse'' but+--   usually generate smaller shader code since the last argument is not inlined into the two branches, which also would affect implicit derivates (e.g. 'dFdx', 'dFdy' or sampling using @SampleAuto@)+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 :: ExprM [String]+                ifM = memoizeM $ do+                    boolStr <- unS bool+                    (lifted, aDecls) <- runWriterT $ shaderbaseDeclare (toBase x (errShaderType :: a))+                    void $ evalStateT (shaderbaseAssign a) aDecls+                    decls <- execWriterT $ shaderbaseDeclare (toBase x (errShaderType :: b))+                    tellIf boolStr+                    scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls+                    T.lift $ T.lift $ tell "} else {\n"+                    scopedM $ void $ evalStateT (shaderbaseAssign $ els lifted) decls+                    T.lift $ T.lift $ tell "}\n"+                    return decls+            in  evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: b))) ifM) 0++-- | @ifThen c f x@ will return @f x@ if @c@ evaluates to 'true' or @x@ otherwise.+--+--   In most cases functionally equivalent to 'ifThenElse'' but+--   usually generate smaller shader code since the last argument is not inlined into the two branches, which also would affect implicit derivates (e.g. 'dFdx', 'dFdy' or sampling using @SampleAuto@)+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 (errShaderType :: a))+                    void $ evalStateT (shaderbaseAssign a) decls+                    tellIf boolStr+                    scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls+                    T.lift $ T.lift $ tell "}\n"+                    return decls+            in  evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: a))) ifM) 0++tellIf :: RValue -> ExprM ()+tellIf boolStr = T.lift $ T.lift $ tell $ mconcat ["if(", boolStr, "){\n" ]++-- | @while f g x@ will iteratively transform @x@ with @g@ as long as @f@ generates 'true'.+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 (errShaderType :: 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+                    scopedM $ do+                        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 (errShaderType :: a))) whileM) 0++errShaderType = error "toBase in an instance of ShaderType is not lazy enough! Make sure you use tilde (~) for each pattern match on a data constructor."++--------------------------------------------------------------------------------------------------------------------------------+++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 . ("float(" ++) . (++ ")") . 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' Int32 where+    div' = div+    mod' = mod+instance Integral' Int16 where+    div' = div+    mod' = mod+instance Integral' Int8 where+    div' = div+    mod' = mod+instance Integral' Word where+    div' = div+    mod' = mod+instance Integral' Word32 where+    div' = div+    mod' = mod+instance Integral' Word16 where+    div' = div+    mod' = mod+instance Integral' Word8 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 Integral' a => Integral' (V0 a) where+    div' = liftA2 div'+    mod' = liftA2 mod'+instance Integral' a => Integral' (V1 a) where+    div' = liftA2 div'+    mod' = liftA2 mod'+instance Integral' a => Integral' (V2 a) where+    div' = liftA2 div'+    mod' = liftA2 mod'+instance Integral' a => Integral' (V3 a) where+    div' = liftA2 div'+    mod' = liftA2 mod'+instance Integral' a => Integral' (V4 a) where+    div' = liftA2 div'+    mod' = liftA2 mod'++class Bits' a where+    and' :: a -> a -> a+    or' :: a -> a -> a+    xor' :: a -> a -> a+    complement' :: a -> a+    shiftL' :: a -> a -> a+    shiftR' :: a -> a -> a+    bitSize' :: a -> Int++instance Bits' (S a Int) where+    and' = bini "&"+    or' = bini "|"+    xor' = bini "^"+    complement' = fun1i "~"+    shiftL' = bini "<<"+    shiftR' = bini ">>"+    bitSize' = pure (finiteBitSize (undefined :: Int))+instance Bits' (S a Word) where+    and' = binu "&"+    or' = binu "|"+    xor' = binu "^"+    complement' = fun1u "~"+    shiftL' = binu "<<"+    shiftR' = binu ">>"+    bitSize' = pure (finiteBitSize (undefined :: Word))++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++instance Eq x => EqB (S a x) where+  (==*) = bin STypeBool "=="+  (/=*) = bin STypeBool "!="++instance Ord x => OrdB (S a x) where+  (<*) = bin STypeBool "<"+  (<=*) = bin STypeBool "<="+  (>=*) = bin STypeBool ">="+  (>*) = bin STypeBool ">"++instance IfB (S a Float) where ifB = ifThenElse'+instance IfB (S a Int) where ifB = ifThenElse'+instance IfB (S a Word) where ifB = ifThenElse'+instance IfB (S a Bool) where ifB = ifThenElse'+instance IfB (S a (GenerativeGeometry p b)) where ifB = ifThenElse'++instance Conjugate (S a Float)+instance Conjugate (S a Int)+instance Conjugate (S a Word)+instance TrivialConjugate  (S a Float)+instance TrivialConjugate  (S a Int)+instance TrivialConjugate  (S a Word)++-- | 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.+class 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+  mix :: a -> a -> a-> a+  atan2' :: a -> a -> a++  rsqrt = (1/) . sqrt+  exp2 = (2**)+  log2 = logBase 2+  mix x y a = x*(1-a)+y*a+  fract' x = x - floor' x+  mod'' x y = x - y* floor' (x/y)+  floor' x = -ceiling' (-x)+  ceiling' x = -floor' (-x)++  {-# MINIMAL (floor' | ceiling') , atan2' #-}++instance Real' Float where+  floor' = fromIntegral . floor+  ceiling' = fromIntegral . ceiling+  atan2' = atan2++instance Real' Double where+  floor' = fromIntegral . floor+  ceiling' = fromIntegral . ceiling+  atan2' = atan2++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"+  mix = fun3f "mix"+  atan2' = fun2f "atan"++instance (Real' a) => Real' (V0 a) where+  rsqrt = liftA rsqrt+  exp2 = liftA exp2+  log2 = liftA log2+  floor' = liftA floor'+  ceiling' = liftA ceiling'+  fract' = liftA fract'+  mod'' = liftA2 mod''+  mix = liftA3 mix+  atan2' = liftA2 atan2'+instance (Real' a) => Real' (V1 a) where+  rsqrt = liftA rsqrt+  exp2 = liftA exp2+  log2 = liftA log2+  floor' = liftA floor'+  ceiling' = liftA ceiling'+  fract' = liftA fract'+  mod'' = liftA2 mod''+  mix = liftA3 mix+  atan2' = liftA2 atan2'+instance (Real' a) => Real' (V2 a) where+  rsqrt = liftA rsqrt+  exp2 = liftA exp2+  log2 = liftA log2+  floor' = liftA floor'+  ceiling' = liftA ceiling'+  fract' = liftA fract'+  mod'' = liftA2 mod''+  mix = liftA3 mix+  atan2' = liftA2 atan2'+instance (Real' a) => Real' (V3 a) where+  rsqrt = liftA rsqrt+  exp2 = liftA exp2+  log2 = liftA log2+  floor' = liftA floor'+  ceiling' = liftA ceiling'+  fract' = liftA fract'+  mod'' = liftA2 mod''+  mix = liftA3 mix+  atan2' = liftA2 atan2'+instance (Real' a) => Real' (V4 a) where+  rsqrt = liftA rsqrt+  exp2 = liftA exp2+  log2 = liftA log2+  floor' = liftA floor'+  ceiling' = liftA ceiling'+  fract' = liftA fract'+  mod'' = liftA2 mod''+  mix = liftA3 mix+  atan2' = liftA2 atan2'++-- | This class provides various order comparing functions+class (IfB a, OrdB a, Floating a) => FloatingOrd a where+  clamp :: a -> a -> a -> a+  saturate :: a -> a+  step :: a -> a -> a+  smoothstep :: a -> a -> a -> a+  clamp x a = minB (maxB x a)+  saturate x = clamp x 0 1+  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)++instance FloatingOrd Float+instance FloatingOrd Double+instance FloatingOrd (S x Float) where+  clamp = fun3f "clamp"+  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 = fun2f "min"+maxS :: S x Float -> S x Float -> S x Float+maxS = fun2f "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)
+ src/Graphics/GPipe/Internal/Format.hs view
@@ -0,0 +1,520 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeSynonymInstances, EmptyDataDecls #-}++module Graphics.GPipe.Internal.Format where++import Graphics.GL.Core45+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 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 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 WindowFormat c ds where+    WindowFormatColor :: ContextColorFormat c => Format c -> WindowFormat c ()+    WindowFormatColorDepth :: ContextColorFormat c => Format c -> Format Depth -> WindowFormat c Depth+    WindowFormatColorStencil :: ContextColorFormat c => Format c -> Format Stencil -> WindowFormat c Stencil+    WindowFormatColorDepthStencilSeparate :: ContextColorFormat c => Format c -> Format Depth -> Format Stencil -> WindowFormat c DepthStencil+    WindowFormatColorDepthStencilCombined :: ContextColorFormat c => Format c -> Format DepthStencil -> WindowFormat c DepthStencil+    WindowFormatDepth :: Format Depth -> WindowFormat () Depth+    WindowFormatStencil :: Format Stencil -> WindowFormat () Stencil+    WindowFormatDepthStencilSeparate :: Format Depth -> Format Stencil -> WindowFormat () DepthStencil+    WindowFormatDepthStencilCombined :: Format DepthStencil -> WindowFormat () DepthStencil++type WindowBits = ((Int,Int,Int,Int,Bool),Int,Int)++windowBits :: WindowFormat c ds -> WindowBits+windowBits (WindowFormatColor c) = (colorBits c, 0, 0)+windowBits (WindowFormatColorDepth c d) = (colorBits c, depthBits d, 0)+windowBits (WindowFormatColorStencil c s) = (colorBits c, 0, stencilBits s)+windowBits (WindowFormatColorDepthStencilSeparate c d s) = (colorBits c, depthBits d, stencilBits s)+windowBits (WindowFormatColorDepthStencilCombined c ds) = let (d,s) = depthStencilBits ds in (colorBits c, d, s)+windowBits (WindowFormatDepth d) = ((0,0,0,0, False), depthBits d, 0)+windowBits (WindowFormatStencil s) = ((0,0,0,0, False), 0, stencilBits s)+windowBits (WindowFormatDepthStencilSeparate d s) = ((0,0,0,0, False), depthBits d, stencilBits s)+windowBits (WindowFormatDepthStencilCombined ds) = let (d,s) = depthStencilBits ds in ((0,0,0,0, False), d, s)
+ src/Graphics/GPipe/Internal/FragmentStream.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, Arrows, FlexibleContexts  #-}+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 Control.Monad.Trans.State.Lazy+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup (Semigroup(..))+#endif+import Data.Boolean+import Data.IntMap.Lazy (insert)+import Linear.V4+import Linear.V3+import Linear.V2+import Linear.V1+import Linear.V0+import Linear.Plucker (Plucker(..))+import Linear.Quaternion (Quaternion(..))+import Linear.Affine (Point(..))++import Graphics.GL.Core45+import Data.Maybe (isJust)++type VPos = V4 VFloat++type ExprPos = ExprM ()+type RasterizationName = Int+data FragmentStreamData = FragmentStreamData RasterizationName Bool 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 (Semigroup, 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, PolygonMode, ViewPort, DepthRange))+          -> PrimitiveStream p (VPos, a)+          -> Shader os s (FragmentStream (FragmentFormat a))+rasterize sf (PrimitiveStream xs) = Shader $ do+        n <- getNewName+        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),(ps, s)) = (evalState (m x) 0, FragmentStreamData n False (makePos p >> makePointSize ps) 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'++")"+        makePointSize Nothing = return ()+        makePointSize (Just (S ps)) = ps >>= tellAssignment' "gl_PointSize"+        io s =+            let (side, polygonMode, 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+                            setGlPolygonMode polygonMode+                            glScissor (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)+                            glViewport (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)+                            glDepthRange (realToFrac dmin) (realToFrac dmax)+                            setGLPointSize++        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++        setGlPolygonMode PolygonFill      = glPolygonMode GL_FRONT_AND_BACK GL_FILL+        setGlPolygonMode PolygonPoint     = do+            glEnable GL_PROGRAM_POINT_SIZE+            glPolygonMode GL_FRONT_AND_BACK GL_POINT+        setGlPolygonMode (PolygonLine lw) = do+            glLineWidth (realToFrac lw)+            glPolygonMode GL_FRONT_AND_BACK GL_LINE++        setGLPointSize = if any (isJust.fst.snd) xs then glEnable GL_PROGRAM_POINT_SIZE else glDisable GL_PROGRAM_POINT_SIZE++-- | Defines which side to rasterize. Non triangle primitives only has a front side.+data Side = Front | Back | FrontAndBack+-- | Defines whether to fill the polygon or to show points or wireframes.+data PolygonMode = PolygonFill | PolygonLine Float | PolygonPoint+-- | 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 x1 x2 x3 x4 x5) = (a,FragmentStreamData x1 x2 x3 x4 (x5 &&* 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')++instance (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d, FragmentInput e) => FragmentInput (a,b,c,d,e) where+    type FragmentFormat (a,b,c,d,e) = (FragmentFormat a, FragmentFormat b, FragmentFormat c, FragmentFormat d, FragmentFormat e)+    toFragment = proc ~(a,b,c,d,e) -> do a' <- toFragment -< a+                                         b' <- toFragment -< b+                                         c' <- toFragment -< c+                                         d' <- toFragment -< d+                                         e' <- toFragment -< e+                                         returnA -< (a', b', c', d', e')++instance (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d, FragmentInput e, FragmentInput f) => FragmentInput (a,b,c,d,e,f) where+    type FragmentFormat (a,b,c,d,e,f) = (FragmentFormat a, FragmentFormat b, FragmentFormat c, FragmentFormat d, FragmentFormat e, FragmentFormat f)+    toFragment = proc ~(a,b,c,d,e,f) -> do a' <- toFragment -< a+                                           b' <- toFragment -< b+                                           c' <- toFragment -< c+                                           d' <- toFragment -< d+                                           e' <- toFragment -< e+                                           f' <- toFragment -< f+                                           returnA -< (a', b', c', d', e', f')++instance (FragmentInput a, FragmentInput b, FragmentInput c, FragmentInput d, FragmentInput e, FragmentInput f, FragmentInput g) => FragmentInput (a,b,c,d,e,f,g) where+    type FragmentFormat (a,b,c,d,e,f,g) = (FragmentFormat a, FragmentFormat b, FragmentFormat c, FragmentFormat d, FragmentFormat e, FragmentFormat f, FragmentFormat g)+    toFragment = proc ~(a,b,c,d,e,f,g) -> do a' <- toFragment -< a+                                             b' <- toFragment -< b+                                             c' <- toFragment -< c+                                             d' <- toFragment -< d+                                             e' <- toFragment -< e+                                             f' <- toFragment -< f+                                             g' <- toFragment -< g+                                             returnA -< (a', b', c', d', e', f', g')++instance FragmentInput a => FragmentInput (Quaternion a) where+    type FragmentFormat (Quaternion a) = Quaternion (FragmentFormat a)+    toFragment = proc ~(Quaternion a v) -> do+                a' <- toFragment -< a+                v' <- toFragment -< v+                returnA -< Quaternion a' v'++instance (FragmentInput (f a), FragmentInput a, FragmentFormat (f a) ~ f (FragmentFormat a)) => FragmentInput (Point f a) where+    type FragmentFormat (Point f a) = Point f (FragmentFormat a)+    toFragment = proc ~(P a) -> do+                a' <- toFragment -< a+                returnA -< P a'++instance FragmentInput a => FragmentInput (Plucker a) where+    type FragmentFormat (Plucker a) = Plucker (FragmentFormat a)+    toFragment = proc ~(Plucker a b c d e f) -> do+                a' <- toFragment -< a+                b' <- toFragment -< b+                c' <- toFragment -< c+                d' <- toFragment -< d+                e' <- toFragment -< e+                f' <- toFragment -< f+                returnA -< Plucker a' b' c' d' e' f'
+ src/Graphics/GPipe/Internal/FrameBuffer.hs view
@@ -0,0 +1,671 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Graphics.GPipe.Internal.FrameBuffer where+import Control.Monad (void, when)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.State.Lazy+import qualified Control.Monad.Trans.State.Strict as StrictState+import Control.Monad.Trans.Writer.Lazy+import Data.IORef+import qualified Data.IntMap as IMap+import Data.List (intercalate)+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array (withArray)+import Foreign.Marshal.Utils+import Foreign.Ptr (nullPtr)+import Foreign.Storable (peek)+import Graphics.GL.Core45+import Graphics.GL.Types+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 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 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 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 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 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  ( Right (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  ( Right+                    ( 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  ( Right+                    ( 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  ( Right+                    ( 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 window.+drawWindowColor :: forall os s c ds. ContextColorFormat c+    => (s -> (Window os c ds, ContextColorOption c))+    -> FragmentStream (FragColor c) -> Shader os s ()++-- | Perform a depth test for each fragment from a 'FragmentStream' in the window. This doesn't draw any color values and only affects the depth buffer.+drawWindowDepth :: forall os s c ds. DepthRenderable ds+    => (s -> (Window os c ds, DepthOption))+    -> FragmentStream FragDepth -> Shader os 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 window.+drawWindowColorDepth :: forall os s c ds. (ContextColorFormat c, DepthRenderable ds)+    => (s -> (Window os c ds, ContextColorOption c, DepthOption))+    -> FragmentStream (FragColor c, FragDepth) -> Shader os s ()++-- | Perform a stencil test for each fragment from a 'FragmentStream' in the window. This doesn't draw any color values and only affects the stencil buffer.+drawWindowStencil :: forall os s c ds. StencilRenderable ds+    => (s -> (Window os c ds, StencilOptions))+    -> FragmentStream () -> Shader os 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 window.+drawWindowColorStencil :: forall os s c ds. (ContextColorFormat c, StencilRenderable ds)+    => (s -> (Window os c ds, ContextColorOption c, StencilOptions))+    -> FragmentStream (FragColor c) -> Shader os s ()++-- | Perform a stencil test and depth test (in that order) for each fragment from a 'FragmentStream' in the window. This doesnt draw any color values and only affects the depth and stencil buffer.+drawWindowDepthStencil :: forall os s c ds. (DepthRenderable ds, StencilRenderable ds)+    => (s -> (Window os c ds, DepthStencilOption))+    -> FragmentStream FragDepth -> Shader os 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 window.+drawWindowColorDepthStencil :: forall os s c ds. (ContextColorFormat c, DepthRenderable ds, StencilRenderable ds)+    => (s -> (Window os c ds, ContextColorOption c, DepthStencilOption))+    -> FragmentStream (FragColor c, FragDepth) -> Shader os s ()++drawWindowColor sf fs = Shader $ tellDrawcalls fs $ \a -> make3 (setColor cf 0 a) io+    where+        io s = let (w, op) = sf s in (Left (getWinName w), glDisable GL_DEPTH_TEST >> glDisable GL_STENCIL_TEST >> setGlContextColorOptions cf op)+        cf = undefined :: c++drawWindowDepth sf fs = Shader $ tellDrawcalls fs $ \a -> (setDepth a, return (), io)+    where+        io s = let (w, op) = sf s in (Left (getWinName w), glDisable GL_STENCIL_TEST >> setGlDepthOptions op)++drawWindowColorDepth sf fs = Shader $ tellDrawcalls fs $ \(c, d) -> let (s, g) = setColor cf 0 c in (s >> setDepth d, g, io)+    where+        io s = let (w, cop, dop) = sf s in (Left (getWinName w), glDisable GL_STENCIL_TEST >> setGlContextColorOptions cf cop >> setGlDepthOptions dop)+        cf = undefined :: c++drawWindowStencil sf fs = Shader $ tellDrawcalls fs $ const (return (), return (), io)+    where+        io s = let (w, op) = sf s in (Left (getWinName w), glDisable GL_DEPTH_TEST >> setGlStencilOptions op OpZero OpZero)++drawWindowColorStencil sf fs = Shader $ tellDrawcalls fs $ \a -> make3 (setColor cf 0 a) io+    where+        io s = let (w, cop, dop) = sf s in (Left (getWinName w), glDisable GL_DEPTH_TEST >> setGlContextColorOptions cf cop >> setGlStencilOptions dop OpZero OpZero)+        cf = undefined :: c++drawWindowDepthStencil sf fs = Shader $ tellDrawcalls fs $ \a -> (setDepth a, return (), io)+    where+        io s = let (w, op) = sf s in (Left (getWinName w), setGlDepthStencilOptions op)++drawWindowColorDepthStencil sf fs = Shader $ tellDrawcalls fs $ \(c, d) -> let (s, g) = setColor cf 0 c in (s >> setDepth d, g, io)+    where+        io s = let (w, cop, dop) = sf s in (Left (getWinName w), setGlContextColorOptions cf cop >> setGlDepthStencilOptions dop)+        cf = undefined :: c++tellDrawcalls :: FragmentStream a -> (a -> (ExprM (), GlobDeclM (), s -> (Either WinId (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 (), -- sh - shader+        GlobDeclM (), -- shd - shader declarations+        s -> (Either WinId (IO FBOKeys, IO ()), IO ()) -- wOrIo - where to draw, as a window ID or a FBO (only this second case seems to be used)+    ) ->+    FragmentStreamData ->+    IO (Drawcall s)+makeDrawcall (sh, shd, wOrIo) (FragmentStreamData rastN False shaderpos (PrimitiveStreamData primN ubuff) keep) =+    do+        ExprResult fsource funis fsamps _ prevDecls prevS <- runExprM shd (discard keep >> sh)+        ExprResult vsource vunis vsamps vinps _ _ <- runExprM prevDecls (prevS >> shaderpos)+        return $ Drawcall wOrIo Nothing primN (Just rastN) vsource Nothing (Just fsource) vinps vunis vsamps [] [] funis fsamps ubuff+makeDrawcall (sh, shd, wOrIo) (FragmentStreamData rastN True shaderpos (PrimitiveStreamData primN ubuff) keep) =+    do+        ExprResult fsource funis fsamps _ prevDecls prevS <- runExprM shd (discard keep >> sh)+        ExprResult gsource gunis gsamps _ prevDecls2 prevS2 <- runExprM prevDecls (prevS >> shaderpos)+        ExprResult vsource vunis vsamps vinps _ _ <- runExprM prevDecls2 prevS2+        return $ Drawcall wOrIo Nothing primN (Just rastN) vsource (Just gsource) (Just fsource) vinps vunis vsamps gunis gsamps funis fsamps ubuff++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+clearImageColor :: forall c os. ColorRenderable c => Image (Format c) -> Color c (ColorElement c) -> Render os ()+clearImageColor i c = do+    (cwid, cd, doAsync) <- getLastRenderWin+    key <- Render $ lift $ lift $ lift $ getImageFBOKey i+    let fbokey = FBOKeys [key] Nothing Nothing+    mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey+    case mfbo of+        Just fbo -> Render $ liftIO $ doAsync $ do+            fbo' <- readIORef fbo+            glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'+        Nothing -> Render $ maybeThrow $ liftIO $ asSync doAsync $ do+            fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)+            fbo <- newIORef fbo'+            void $ mkWeakIORef fbo (doAsync $ 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 $ liftIO $ doAsync $ do+        glDisable GL_SCISSOR_TEST+        glColorMask glTrue glTrue glTrue glTrue+        clearColor (undefined :: c) c+        glEnable GL_SCISSOR_TEST++-- | Fill a depth image with a constant depth value (in the range [0,1])+clearImageDepth :: DepthRenderable d => Image (Format d) -> Float -> Render os ()+clearImageDepth i d = do+    (cwid, cd, doAsync) <- getLastRenderWin+    key <- Render $ lift $ lift $ lift $ getImageFBOKey i+    let fbokey = FBOKeys [] (Just key) Nothing+    mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey+    case mfbo of+        Just fbo -> Render $+            liftIO $+                doAsync $ do+                    fbo' <- readIORef fbo+                    glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'+        Nothing -> Render $+            maybeThrow $+                liftIO $+                    asSync doAsync $ do+                        fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)+                        fbo <- newIORef fbo'+                        void $ mkWeakIORef fbo (doAsync $ 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 $+        liftIO $+            doAsync $ do+                glDisable GL_SCISSOR_TEST+                glDepthMask glTrue+                with (realToFrac d) $ glClearBufferfv GL_DEPTH 0+                glEnable GL_SCISSOR_TEST++-- | Fill a depth image with a constant stencil value+clearImageStencil :: StencilRenderable s => Image (Format s) -> Int -> Render os ()+clearImageStencil i s = do+    (cwid, cd, doAsync) <- getLastRenderWin+    key <- Render $ lift $ lift $ lift $ getImageFBOKey i+    let fbokey = FBOKeys [] Nothing (Just key)+    mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey+    case mfbo of+        Just fbo -> Render $+            liftIO $+                doAsync $ do+                    fbo' <- readIORef fbo+                    glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'+        Nothing -> Render $+            maybeThrow $+                liftIO $+                    asSync doAsync $ do+                        fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)+                        fbo <- newIORef fbo'+                        void $ mkWeakIORef fbo (doAsync $ 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 $+        liftIO $+            doAsync $ do+                glDisable GL_SCISSOR_TEST+                glStencilMask maxBound+                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+clearImageDepthStencil :: Image (Format DepthStencil) -> Float -> Int -> Render os ()+clearImageDepthStencil i d s = do+    (cwid, cd, doAsync) <- getLastRenderWin+    key <- Render $ lift $ lift $ lift $ getImageFBOKey i+    let fbokey = FBOKeys [] Nothing (Just key)+    mfbo <- Render $ lift $ lift $ lift $ getFBO cd fbokey+    case mfbo of+        Just fbo -> Render $+            liftIO $+                doAsync $ do+                    fbo' <- readIORef fbo+                    glBindFramebuffer GL_DRAW_FRAMEBUFFER fbo'+        Nothing -> Render $+            maybeThrow $+                liftIO $+                    asSync doAsync $ do+                        fbo' <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr)+                        fbo <- newIORef fbo'+                        void $ mkWeakIORef fbo (doAsync $ 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 $+        liftIO $+            doAsync $ do+                glDisable GL_SCISSOR_TEST+                glDepthMask glTrue+                glStencilMask maxBound+                glClearBufferfi GL_DEPTH_STENCIL 0 (realToFrac d) (fromIntegral s)+                glEnable GL_SCISSOR_TEST++inWin w m = Render $ do+    rs <- lift $ lift StrictState.get+    case IMap.lookup (getWinName w) (perWindowRenderState rs) of+        Nothing -> return () -- Window deleted, do nothing+        Just (_, doAsync) -> liftIO $ doAsync m++-- | Fill the window's back buffer with a constant color value+clearWindowColor :: forall os c ds. ContextColorFormat c => Window os c ds -> Color c Float -> Render os ()+clearWindowColor w c = inWin w $ do+    glBindFramebuffer GL_DRAW_FRAMEBUFFER 0+    glDisable GL_SCISSOR_TEST+    glColorMask glTrue glTrue glTrue glTrue+    withArray (map realToFrac (fromColor (undefined :: c) c ++ replicate 3 0 :: [Float])) $ glClearBufferfv GL_COLOR 0+    glEnable GL_SCISSOR_TEST++-- | Fill the window's back depth buffer with a constant depth value (in the range [0,1])+clearWindowDepth :: DepthRenderable ds => Window os c ds -> Float -> Render os ()+clearWindowDepth w d = inWin w $ do+    glBindFramebuffer GL_DRAW_FRAMEBUFFER 0+    glDisable GL_SCISSOR_TEST+    glDepthMask glTrue+    with (realToFrac d) $ glClearBufferfv GL_DEPTH 0+    glEnable GL_SCISSOR_TEST++-- | Fill the window's back stencil buffer with a constant stencil value+clearWindowStencil :: StencilRenderable ds => Window os c ds -> Int -> Render os ()+clearWindowStencil w s = inWin w $ do+    glBindFramebuffer GL_DRAW_FRAMEBUFFER 0+    glDisable GL_SCISSOR_TEST+    glStencilMask maxBound+    with (fromIntegral s) $ glClearBufferiv GL_STENCIL 0+    glEnable GL_SCISSOR_TEST++-- | Fill the window's back depth and stencil buffers with a constant depth value (in the range [0,1]) and a constant stencil value+clearWindowDepthStencil :: Window os c DepthStencil -> Float -> Int -> Render os ()+clearWindowDepthStencil w d s = inWin w $ do+    glBindFramebuffer GL_DRAW_FRAMEBUFFER 0+    glDisable GL_SCISSOR_TEST+    glDepthMask glTrue+    glStencilMask maxBound+    glClearBufferfi GL_DEPTH_STENCIL 0 (realToFrac d) (fromIntegral s)+    glEnable GL_SCISSOR_TEST++maybeThrow :: Monad m => ExceptT e m (Maybe e) -> ExceptT e m ()+maybeThrow m = do+    mErr <- m+    case mErr of+        Just err -> throwE err+        Nothing -> return ()++---------------+glTrue :: Num n => n+glTrue = fromBool True++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
+ src/Graphics/GPipe/Internal/GeometryStream.hs view
@@ -0,0 +1,812 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, Arrows, GeneralizedNewtypeDeriving, GADTs, MultiParamTypeClasses #-}++module Graphics.GPipe.Internal.GeometryStream where++import Control.Arrow+import Control.Category+import Control.Monad.Trans.State.Lazy+import qualified Control.Monad.Trans.Class as T (lift)+import Control.Monad.Trans.Writer (tell)+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup (Semigroup(..))+#endif+import Prelude hiding (length, id, (.))++import Graphics.GPipe.Internal.Expr+import Graphics.GPipe.Internal.Shader+import Graphics.GPipe.Internal.Compiler+import Graphics.GPipe.Internal.PrimitiveArray+import Graphics.GPipe.Internal.PrimitiveStream+import Graphics.GPipe.Internal.FragmentStream++import Graphics.GL.Core45++import Data.Boolean+import Data.IntMap.Lazy (insert)+import Linear.V4+import Linear.V3+import Linear.V2+import Linear.V1+import Linear.V0+import Linear.Plucker (Plucker(..))+import Linear.Quaternion (Quaternion(..))+import Linear.Affine (Point(..))++------------------------------------------------------------------------------------------------------------------------------------++type GeometrizationName = Int++type LayoutName = String++data GeometryStreamData = GeometryStreamData GeometrizationName LayoutName PrimitiveStreamData++newtype GeometryStream a = GeometryStream [(a, GeometryStreamData)] deriving (Semigroup, Monoid)++instance Functor GeometryStream where+    fmap f (GeometryStream xs) = GeometryStream $ map (first f) xs++newtype ToGeometry a b = ToGeometry (Kleisli (State (Int, Int)) a b) deriving (Category, Arrow)++-- TODO Merge PrimitiveTopology and GeometryInput?+class (AnotherVertexInput a, PrimitiveTopology p) => GeometryInput p a where+    toGeometry :: ToGeometry a (Geometry p a)++newtype ToAnotherVertex a b = ToAnotherVertex (Kleisli (State (Int, Int)) (Int, a) b)++instance Category ToAnotherVertex where+    {-# INLINE id #-}+    id = ToAnotherVertex $ proc ~(i, x) -> do+        returnA -< x+    {-# INLINE (.) #-}+    ToAnotherVertex g . ToAnotherVertex f = ToAnotherVertex $ proc ~(i, x) -> do+        y <- f -< (i, x)+        z <- g -< (i, y)+        returnA -< z++instance Arrow ToAnotherVertex where+    {-# INLINE arr #-}+    arr f = ToAnotherVertex (arr (f . (\(_, c) -> c)))+    {-# INLINE first #-}+    first (ToAnotherVertex f) = ToAnotherVertex $ proc ~(i, (x, z)) -> do+        y <- f -< (i, x)+        returnA -< (y, z)++class AnotherVertexInput a where+    toAnotherVertex :: ToAnotherVertex a a++instance AnotherVertexInput a => GeometryInput Points a where+    toGeometry = ToGeometry $ Kleisli $ \x -> do+        let ToAnotherVertex (Kleisli m) = toAnotherVertex :: ToAnotherVertex a a+        x0 <- m (0, x)+        return $ Point x0++instance AnotherVertexInput a => GeometryInput Lines a where+    toGeometry = ToGeometry $ Kleisli $ \x -> do+        let ToAnotherVertex (Kleisli m) = toAnotherVertex :: ToAnotherVertex a a+        x0 <- m (0, x)+        x1 <- m (1, x)+        return $ Line x0 x1++instance AnotherVertexInput a => GeometryInput LinesWithAdjacency a where+    toGeometry = ToGeometry $ Kleisli $ \x -> do+        let ToAnotherVertex (Kleisli m) = toAnotherVertex :: ToAnotherVertex a a+        x0 <- m (0, x)+        x1 <- m (1, x)+        x2 <- m (2, x)+        x3 <- m (3, x)+        return $ LineWithAdjacency x0 x1 x2 x3++instance AnotherVertexInput a => GeometryInput Triangles a where+    toGeometry = ToGeometry $ Kleisli $ \x -> do+        let ToAnotherVertex (Kleisli m) = toAnotherVertex :: ToAnotherVertex a a+        x0 <- m (0, x)+        x1 <- m (1, x)+        x2 <- m (2, x)+        return $ Triangle x0 x1 x2++instance AnotherVertexInput a => GeometryInput TrianglesWithAdjacency a where+    toGeometry = ToGeometry $ Kleisli $ \x -> do+        let ToAnotherVertex (Kleisli m) = toAnotherVertex :: ToAnotherVertex a a+        x0 <- m (0, x)+        x1 <- m (1, x)+        x2 <- m (2, x)+        x3 <- m (3, x)+        x4 <- m (4, x)+        x5 <- m (5, x)+        return $ TriangleWithAdjacency x0 x1 x2 x3 x4 x5++------------------------------------------------------------------------------------------------------------------------------------++-- makeAnotherVertex :: String -> SType -> ((S c a) -> ExprM String) -> ToAnotherVertex (S c a) (S c a)+makeAnotherVertex :: String -> SType -> (b -> ExprM String) -> (S c a -> b) -> ToAnotherVertex b b+makeAnotherVertex qual styp f f' = ToAnotherVertex $ Kleisli $ \ (i, x) -> do+    (j, n) <- get+    let n' = if i == j then n else 0 -- reset when index change+    put (i, n'+1)+    return $ f' $ S $ useGInput qual styp i n' $ f x++instance AnotherVertexInput () where+    toAnotherVertex = arr (const ())++instance AnotherVertexInput VFloat where+    toAnotherVertex = makeAnotherVertex "" STypeFloat unS id++instance AnotherVertexInput FlatVFloat where+    toAnotherVertex = makeAnotherVertex "flat" STypeFloat (unS . unFlat) Flat++instance AnotherVertexInput NoPerspectiveVFloat where+    toAnotherVertex = makeAnotherVertex "noperspective" STypeFloat (unS . unNPersp) NoPerspective++instance AnotherVertexInput VInt where+    toAnotherVertex = makeAnotherVertex "flat" STypeInt unS id++instance AnotherVertexInput VWord where+    toAnotherVertex = makeAnotherVertex "flat" STypeUInt unS id++instance AnotherVertexInput VBool where+    toAnotherVertex = proc b -> do+        i <- toAnotherVertex -< ifB b 1 0 :: VInt+        returnA -< i ==* 1++instance (AnotherVertexInput a) => AnotherVertexInput (V0 a) where+    toAnotherVertex = arr (const V0)++instance (AnotherVertexInput a) => AnotherVertexInput (V1 a) where+    toAnotherVertex = proc ~(V1 a) -> do+        a' <- toAnotherVertex -< a+        returnA -< V1 a'++instance (AnotherVertexInput a) => AnotherVertexInput (V2 a) where+    toAnotherVertex = proc ~(V2 a b) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        returnA -< V2 a' b'++instance (AnotherVertexInput a) => AnotherVertexInput (V3 a) where+    toAnotherVertex = proc ~(V3 a b c) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        c' <- toAnotherVertex -< c+        returnA -< V3 a' b' c'++instance (AnotherVertexInput a) => AnotherVertexInput (V4 a) where+    toAnotherVertex = proc ~(V4 a b c d) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        c' <- toAnotherVertex -< c+        d' <- toAnotherVertex -< d+        returnA -< V4 a' b' c' d'++instance (AnotherVertexInput a, AnotherVertexInput b) => AnotherVertexInput (a,b) where+    toAnotherVertex = proc ~(a,b) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        returnA -< (a', b')++instance (AnotherVertexInput a, AnotherVertexInput b, AnotherVertexInput c) => AnotherVertexInput (a,b,c) where+    toAnotherVertex = proc ~(a,b,c) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        c' <- toAnotherVertex -< c+        returnA -< (a', b', c')++instance (AnotherVertexInput a, AnotherVertexInput b, AnotherVertexInput c, AnotherVertexInput d) => AnotherVertexInput (a,b,c,d) where+    toAnotherVertex = proc ~(a,b,c,d) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        c' <- toAnotherVertex -< c+        d' <- toAnotherVertex -< d+        returnA -< (a', b', c', d')++instance (AnotherVertexInput a, AnotherVertexInput b, AnotherVertexInput c, AnotherVertexInput d, AnotherVertexInput e) => AnotherVertexInput (a,b,c,d,e) where+    toAnotherVertex = proc ~(a,b,c,d,e) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        c' <- toAnotherVertex -< c+        d' <- toAnotherVertex -< d+        e' <- toAnotherVertex -< e+        returnA -< (a', b', c', d', e')++instance (AnotherVertexInput a, AnotherVertexInput b, AnotherVertexInput c, AnotherVertexInput d, AnotherVertexInput e, AnotherVertexInput f) => AnotherVertexInput (a,b,c,d,e,f) where+    toAnotherVertex = proc ~(a,b,c,d,e,f) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        c' <- toAnotherVertex -< c+        d' <- toAnotherVertex -< d+        e' <- toAnotherVertex -< e+        f' <- toAnotherVertex -< f+        returnA -< (a', b', c', d', e', f')++instance (AnotherVertexInput a, AnotherVertexInput b, AnotherVertexInput c, AnotherVertexInput d, AnotherVertexInput e, AnotherVertexInput f, AnotherVertexInput g) => AnotherVertexInput (a,b,c,d,e,f,g) where+    toAnotherVertex = proc ~(a,b,c,d,e,f,g) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        c' <- toAnotherVertex -< c+        d' <- toAnotherVertex -< d+        e' <- toAnotherVertex -< e+        f' <- toAnotherVertex -< f+        g' <- toAnotherVertex -< g+        returnA -< (a', b', c', d', e', f', g')++instance AnotherVertexInput a => AnotherVertexInput (Quaternion a) where+    toAnotherVertex = proc ~(Quaternion a v) -> do+        a' <- toAnotherVertex -< a+        v' <- toAnotherVertex -< v+        returnA -< Quaternion a' v'++instance AnotherVertexInput a => AnotherVertexInput (Plucker a) where+    toAnotherVertex = proc ~(Plucker a b c d e f) -> do+        a' <- toAnotherVertex -< a+        b' <- toAnotherVertex -< b+        c' <- toAnotherVertex -< c+        d' <- toAnotherVertex -< d+        e' <- toAnotherVertex -< e+        f' <- toAnotherVertex -< f+        returnA -< Plucker a' b' c' d' e' f'++------------------------------------------------------------------------------------------------------------------------------------++geometrize :: forall p a s os f. GeometryInput p a => PrimitiveStream p a -> Shader os s (GeometryStream (Geometry p a))+geometrize (PrimitiveStream xs) = Shader $ do+        n <- getNewName+        modifyRenderIO (\s -> s { transformFeedbackToRenderIO = insert n io (transformFeedbackToRenderIO s) } )+        return (GeometryStream $ map (f n) xs)+    where+        ToGeometry (Kleisli m) = toGeometry :: ToGeometry a (Geometry p a)+        f :: GeometrizationName -> (a, (Maybe PointSize, PrimitiveStreamData)) -> (Geometry p a, GeometryStreamData)+        f n (x, (_, s)) = (evalState (m x) (0, 0), GeometryStreamData n (toLayoutIn (undefined :: p)) s)+        io _ _ = return ()++------------------------------------------------------------------------------------------------------------------------------------++notMeantToBeRead = "false" -- error "a generative geometry is inherently a write-only value"++generativePoints :: FragmentInput a => GGenerativeGeometry Points a+generativePoints = S $ return notMeantToBeRead++generativeLineStrip :: FragmentInput a => GGenerativeGeometry Lines a+generativeLineStrip = S $ return notMeantToBeRead++generativeTriangleStrip :: FragmentInput a => GGenerativeGeometry Triangles a+generativeTriangleStrip = S $ return notMeantToBeRead++emitVertex :: GeometryExplosive a => a -> GGenerativeGeometry p a -> GGenerativeGeometry p a+emitVertex a g = S $ do+    g' <- unS g+    exploseGeometry a 0+    T.lift $ T.lift $ tell "EmitVertex();\n"+    return notMeantToBeRead++emitVertexPosition :: GeometryExplosive a => (VPos, a) -> GGenerativeGeometry p (VPos, a) -> GGenerativeGeometry p (VPos, a)+emitVertexPosition (V4 x y z w, a) g = S $ do+    g' <- unS g+    x' <- unS x+    y' <- unS y+    z' <- unS z+    w' <- unS w+    tellAssignment' "gl_Position" $ "vec4("++x'++',':y'++',':z'++',':w'++")"+    exploseGeometry a 0+    T.lift $ T.lift $ tell "EmitVertex();\n"+    return notMeantToBeRead++emitVertexLayer :: GeometryExplosive a => (VInt, a) -> GGenerativeGeometry p (VInt, a) -> GGenerativeGeometry p (VInt, a)+emitVertexLayer (i, a) g = S $ do+    g' <- unS g+    i' <- unS i+    tellAssignment' "gl_Layer" $ i'+    T.lift $ T.lift $ tell "EmitVertex();\n"+    return notMeantToBeRead++emitVertexPositionAndLayer :: GeometryExplosive a => ((VPos, VInt), a) -> GGenerativeGeometry p ((VPos, VInt), a) -> GGenerativeGeometry p ((VPos, VInt), a)+emitVertexPositionAndLayer ((V4 x y z w, i), a) g = S $ do+    g' <- unS g+    x' <- unS x+    y' <- unS y+    z' <- unS z+    w' <- unS w+    tellAssignment' "gl_Position" $ "vec4("++x'++',':y'++',':z'++',':w'++")"+    exploseGeometry a 0+    i' <- unS i+    tellAssignment' "gl_Layer" $ i'+    T.lift $ T.lift $ tell "EmitVertex();\n"+    return notMeantToBeRead++endPrimitive :: GGenerativeGeometry p a -> GGenerativeGeometry p a+endPrimitive g = S $ do+    g' <- unS g+    T.lift $ T.lift $ tell "EndPrimitive();\n"+    return notMeantToBeRead++------------------------------------------------------------------------------------------------------------------------------------++class FragmentInput a => GeometryExplosive a where+    exploseGeometry :: a -> Int -> ExprM Int+    declareGeometry :: a -> State Int (GlobDeclM ())+    enumerateVaryings :: a -> State Int [String]++defaultExploseGeometry f x n = do+    let name = "vgf" ++ show n+    x' <- unS (f x)+    tellAssignment' name x'+    return (n + 1)++defaultDeclareGeometry t x = do+    n <- get+    put (n + 1)+    let name = "vgf" ++ show n+    return $ do+        tellGlobal $ "out "+        tellGlobal $ stypeName t+        tellGlobalLn $ ' ':name++defaultEnumerateVaryings x = do+    n <- get+    put (n + 1)+    return ["vgf" ++ show n]++instance GeometryExplosive () where+    exploseGeometry _ n = return n+    declareGeometry _ = return (return ())+    enumerateVaryings _ = return []++instance GeometryExplosive VFloat where+    exploseGeometry = defaultExploseGeometry id+    declareGeometry = defaultDeclareGeometry STypeFloat+    enumerateVaryings = defaultEnumerateVaryings++instance GeometryExplosive FlatVFloat where+    exploseGeometry = defaultExploseGeometry unFlat+    declareGeometry = defaultDeclareGeometry STypeFloat+    enumerateVaryings = defaultEnumerateVaryings++instance GeometryExplosive NoPerspectiveVFloat where+    exploseGeometry = defaultExploseGeometry unNPersp+    declareGeometry = defaultDeclareGeometry STypeFloat+    enumerateVaryings = defaultEnumerateVaryings++instance GeometryExplosive VInt where+    exploseGeometry = defaultExploseGeometry id+    declareGeometry = defaultDeclareGeometry STypeInt+    enumerateVaryings = defaultEnumerateVaryings++instance GeometryExplosive VWord where+    exploseGeometry = defaultExploseGeometry id+    declareGeometry = defaultDeclareGeometry STypeUInt+    enumerateVaryings = defaultEnumerateVaryings++instance GeometryExplosive VBool where+    exploseGeometry = defaultExploseGeometry id+    declareGeometry = defaultDeclareGeometry STypeBool+    enumerateVaryings = defaultEnumerateVaryings++instance (GeometryExplosive a) => GeometryExplosive (V0 a) where+    exploseGeometry V0 = return+    declareGeometry V0 = return (return ())+    enumerateVaryings V0 = return []++instance (GeometryExplosive a) => GeometryExplosive (V1 a) where+    exploseGeometry (V1 x) n = do+        exploseGeometry x n+    declareGeometry ~(V1 x) = do+        declareGeometry x+    enumerateVaryings ~(V1 x) =+        enumerateVaryings x++instance (GeometryExplosive a) => GeometryExplosive (V2 a) where+    exploseGeometry (V2 x y) n = do+        exploseGeometry x n >>= exploseGeometry y+    declareGeometry ~(V2 x y) = do+        ws <- sequence [declareGeometry x, declareGeometry y]+        return $ sequence_ ws+    enumerateVaryings ~(V2 x y) =+        concat <$> sequence [enumerateVaryings x, enumerateVaryings y]++instance (GeometryExplosive a) => GeometryExplosive (V3 a) where+    exploseGeometry (V3 x y z) n = do+        exploseGeometry x n >>= exploseGeometry y >>= exploseGeometry z+    declareGeometry ~(V3 x y z) = do+        ws <- sequence [declareGeometry x, declareGeometry y, declareGeometry z]+        return $ sequence_ ws+    enumerateVaryings ~(V3 x y z) =+        concat <$> sequence [enumerateVaryings x, enumerateVaryings y, enumerateVaryings z]++instance (GeometryExplosive a) => GeometryExplosive (V4 a) where+    exploseGeometry (V4 x y z w) n =+        exploseGeometry x n >>= exploseGeometry y >>= exploseGeometry z >>= exploseGeometry w+    declareGeometry ~(V4 x y z w) = do+        ws <- sequence [declareGeometry x, declareGeometry y, declareGeometry z, declareGeometry w]+        return $ sequence_ ws+    enumerateVaryings ~(V4 x y z w) =+        concat <$> sequence [enumerateVaryings x, enumerateVaryings y, enumerateVaryings z, enumerateVaryings w]++instance (GeometryExplosive a, GeometryExplosive b) => GeometryExplosive (a,b) where+    exploseGeometry (x, y) n =+        exploseGeometry x n >>= exploseGeometry y+    declareGeometry ~(x, y) = do+        ws <- sequence [declareGeometry x, declareGeometry y]+        return $ sequence_ ws+    enumerateVaryings ~(x, y) =+        concat <$> sequence [enumerateVaryings x, enumerateVaryings y]++instance (GeometryExplosive a, GeometryExplosive b, GeometryExplosive c) => GeometryExplosive (a,b,c) where+    exploseGeometry (x, y, z) n =+        exploseGeometry x n >>= exploseGeometry y >>= exploseGeometry z+    declareGeometry ~(x, y, z) = do+        ws <- sequence [declareGeometry x, declareGeometry y, declareGeometry z]+        return $ sequence_ ws+    enumerateVaryings ~(x, y, z) =+        concat <$> sequence [enumerateVaryings x, enumerateVaryings y, enumerateVaryings z]++instance (GeometryExplosive a, GeometryExplosive b, GeometryExplosive c, GeometryExplosive d) => GeometryExplosive (a,b,c,d) where+    exploseGeometry (x, y, z, w) n =+        exploseGeometry x n >>= exploseGeometry y >>= exploseGeometry z >>= exploseGeometry w+    declareGeometry ~(x, y, z, w) = do+        ws <- sequence [declareGeometry x, declareGeometry y, declareGeometry z, declareGeometry w]+        return $ sequence_ ws+    enumerateVaryings ~(x, y, z, w) =+        concat <$> sequence [enumerateVaryings x, enumerateVaryings y, enumerateVaryings z, enumerateVaryings w]++instance (GeometryExplosive a, GeometryExplosive b, GeometryExplosive c, GeometryExplosive d, GeometryExplosive e) => GeometryExplosive (a,b,c,d,e) where+    exploseGeometry (x, y, z, w, r) n =+        exploseGeometry x n >>= exploseGeometry y >>= exploseGeometry z >>= exploseGeometry w >>= exploseGeometry r+    declareGeometry ~(x, y, z, w, r) = do+        ws <- sequence [declareGeometry x, declareGeometry y, declareGeometry z, declareGeometry w, declareGeometry r]+        return $ sequence_ ws+    enumerateVaryings ~(x, y, z, w, r) =+        concat <$> sequence [enumerateVaryings x, enumerateVaryings y, enumerateVaryings z, enumerateVaryings w, enumerateVaryings r]++instance (GeometryExplosive a, GeometryExplosive b, GeometryExplosive c, GeometryExplosive d, GeometryExplosive e, GeometryExplosive f) => GeometryExplosive (a,b,c,d,e,f) where+    exploseGeometry (x, y, z, w, r, s) n =+        exploseGeometry x n >>= exploseGeometry y >>= exploseGeometry z >>= exploseGeometry w >>= exploseGeometry r >>= exploseGeometry s+    declareGeometry ~(x, y, z, w, r, s) = do+        ws <- sequence [declareGeometry x, declareGeometry y, declareGeometry z, declareGeometry w, declareGeometry r, declareGeometry s]+        return $ sequence_ ws+    enumerateVaryings ~(x, y, z, w, r, s) =+        concat <$> sequence [enumerateVaryings x, enumerateVaryings y, enumerateVaryings z, enumerateVaryings w, enumerateVaryings r, enumerateVaryings s]++instance (GeometryExplosive a, GeometryExplosive b, GeometryExplosive c, GeometryExplosive d, GeometryExplosive e, GeometryExplosive f, GeometryExplosive g) => GeometryExplosive (a,b,c,d,e,f,g) where+    exploseGeometry (x, y, z, w, r, s, t) n =+        exploseGeometry x n >>= exploseGeometry y >>= exploseGeometry z >>= exploseGeometry w >>= exploseGeometry r >>= exploseGeometry s >>= exploseGeometry t+    declareGeometry ~(x, y, z, w, r, s, t) = do+        ws <- sequence [declareGeometry x, declareGeometry y, declareGeometry z, declareGeometry w, declareGeometry r, declareGeometry s, declareGeometry t]+        return $ sequence_ ws+    enumerateVaryings ~(x, y, z, w, r, s, t) =+        concat <$> sequence [enumerateVaryings x, enumerateVaryings y, enumerateVaryings z, enumerateVaryings w, enumerateVaryings r, enumerateVaryings s, enumerateVaryings t]++------------------------------------------------------------------------------------------------------------------------------------++newtype ToFragmentFromGeometry a b = ToFragmentFromGeometry (Kleisli (State Int) a b) deriving (Category, Arrow)++class FragmentInputFromGeometry p a where+    toFragmentFromGeometry :: ToFragmentFromGeometry (GGenerativeGeometry p (b, a)) (FragmentFormat a)++instance FragmentCreator a => FragmentInputFromGeometry Triangles a where+    toFragmentFromGeometry = ToFragmentFromGeometry $ Kleisli $ \x -> do+        let ToAnotherFragment (Kleisli m) = toFragment2 :: ToAnotherFragment a (FragmentFormat a)+        m (evalState (createFragment :: State Int a) 0)++-- Note: from other constraint, b happens to be VPos or (VPos, VInt).+generateAndRasterize :: forall p b a s os f. (FragmentInputFromGeometry p a, PrimitiveTopology p)+        => (s -> (Side, PolygonMode, ViewPort, DepthRange))+        -> Int+        -> GeometryStream (GGenerativeGeometry p (b, a))+        -> Shader os s (FragmentStream (FragmentFormat a))+generateAndRasterize sf maxVertices (GeometryStream xs) = Shader $ do+        n <- getNewName+        modifyRenderIO (\s -> s { rasterizationNameToRenderIO = insert n io (rasterizationNameToRenderIO s) } )+        return (FragmentStream $ map (f n) xs)+    where+        ToFragmentFromGeometry (Kleisli m) = toFragmentFromGeometry :: ToFragmentFromGeometry (GGenerativeGeometry p (b, a)) (FragmentFormat a)+        f :: Int -> (GGenerativeGeometry p (b, a), GeometryStreamData) -> (FragmentFormat a, FragmentStreamData)+        f n (x, GeometryStreamData name layout psd) = (evalState (m x) 0, FragmentStreamData n True (makePrims layout x) psd true)++        makePrims a x = do+            declareGeometryLayout a (toLayoutOut (undefined :: p)) maxVertices+            x' <- unS x+            return ()++        io s =+            let (side, polygonMode, 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+                            setGlPolygonMode polygonMode+                            glScissor (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)+                            glViewport (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)+                            glDepthRange (realToFrac dmin) (realToFrac dmax)+                            setGLPointSize++        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++        setGlPolygonMode PolygonFill      = glPolygonMode GL_FRONT_AND_BACK GL_FILL+        setGlPolygonMode PolygonPoint     = do+            glEnable GL_PROGRAM_POINT_SIZE+            glPolygonMode GL_FRONT_AND_BACK GL_POINT+        setGlPolygonMode (PolygonLine lw) = do+            glLineWidth (realToFrac lw)+            glPolygonMode GL_FRONT_AND_BACK GL_LINE++        setGLPointSize = glDisable GL_PROGRAM_POINT_SIZE++------------------------------------------------------------------------------------------------------------------------------------++newtype ToAnotherFragment a b = ToAnotherFragment (Kleisli (State Int) a b) deriving (Category, Arrow)++class FragmentInput a => AnotherFragmentInput a where+    toFragment2 :: ToAnotherFragment a (FragmentFormat a)++makeAnotherFragment :: String -> SType -> (a -> ExprM String) -> ToAnotherFragment a (S c a1)+makeAnotherFragment qual styp f = ToAnotherFragment $ Kleisli $ \ x -> do+        n <- get+        put (n + 1)+        return $ S $ useFInputFromG qual styp n $ f x++instance AnotherFragmentInput () where+    toFragment2 = arr (const ())++instance AnotherFragmentInput VFloat where+    toFragment2 = makeAnotherFragment "" STypeFloat unS++instance AnotherFragmentInput FlatVFloat where+    toFragment2 = makeAnotherFragment "flat" STypeFloat (unS . unFlat)++instance AnotherFragmentInput NoPerspectiveVFloat where+    toFragment2 = makeAnotherFragment "noperspective" STypeFloat (unS . unNPersp)++instance AnotherFragmentInput VInt where+    toFragment2 = makeAnotherFragment "flat" STypeInt unS++instance AnotherFragmentInput VWord where+    toFragment2 = makeAnotherFragment "flat" STypeUInt unS++instance AnotherFragmentInput VBool where+    toFragment2 = proc b -> do+        i <- toFragment2 -< ifB b 1 0 :: VInt+        returnA -< i ==* 1++instance (AnotherFragmentInput a) => AnotherFragmentInput (V0 a) where+    toFragment2 = arr (const V0)++instance (AnotherFragmentInput a) => AnotherFragmentInput (V1 a) where+    toFragment2 = proc ~(V1 a) -> do+        a' <- toFragment2 -< a+        returnA -< V1 a'++instance (AnotherFragmentInput a) => AnotherFragmentInput (V2 a) where+    toFragment2 = proc ~(V2 a b) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        returnA -< V2 a' b'++instance (AnotherFragmentInput a) => AnotherFragmentInput (V3 a) where+    toFragment2 = proc ~(V3 a b c) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        c' <- toFragment2 -< c+        returnA -< V3 a' b' c'++instance (AnotherFragmentInput a) => AnotherFragmentInput (V4 a) where+    toFragment2 = proc ~(V4 a b c d) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        c' <- toFragment2 -< c+        d' <- toFragment2 -< d+        returnA -< V4 a' b' c' d'++instance (AnotherFragmentInput a, AnotherFragmentInput b) => AnotherFragmentInput (a,b) where+    toFragment2 = proc ~(a,b) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        returnA -< (a', b')++instance (AnotherFragmentInput a, AnotherFragmentInput b, AnotherFragmentInput c) => AnotherFragmentInput (a,b,c) where+    toFragment2 = proc ~(a,b,c) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        c' <- toFragment2 -< c+        returnA -< (a', b', c')++instance (AnotherFragmentInput a, AnotherFragmentInput b, AnotherFragmentInput c, AnotherFragmentInput d) => AnotherFragmentInput (a,b,c,d) where+    toFragment2 = proc ~(a,b,c,d) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        c' <- toFragment2 -< c+        d' <- toFragment2 -< d+        returnA -< (a', b', c', d')++instance (AnotherFragmentInput a, AnotherFragmentInput b, AnotherFragmentInput c, AnotherFragmentInput d, AnotherFragmentInput e) => AnotherFragmentInput (a,b,c,d,e) where+    toFragment2 = proc ~(a,b,c,d,e) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        c' <- toFragment2 -< c+        d' <- toFragment2 -< d+        e' <- toFragment2 -< e+        returnA -< (a', b', c', d', e')++instance (AnotherFragmentInput a, AnotherFragmentInput b, AnotherFragmentInput c, AnotherFragmentInput d, AnotherFragmentInput e, AnotherFragmentInput f) => AnotherFragmentInput (a,b,c,d,e,f) where+    toFragment2 = proc ~(a,b,c,d,e,f) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        c' <- toFragment2 -< c+        d' <- toFragment2 -< d+        e' <- toFragment2 -< e+        f' <- toFragment2 -< f+        returnA -< (a', b', c', d', e', f')++instance (AnotherFragmentInput a, AnotherFragmentInput b, AnotherFragmentInput c, AnotherFragmentInput d, AnotherFragmentInput e, AnotherFragmentInput f, AnotherFragmentInput g) => AnotherFragmentInput (a,b,c,d,e,f,g) where+    toFragment2 = proc ~(a,b,c,d,e,f,g) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        c' <- toFragment2 -< c+        d' <- toFragment2 -< d+        e' <- toFragment2 -< e+        f' <- toFragment2 -< f+        g' <- toFragment2 -< g+        returnA -< (a', b', c', d', e', f', g')++instance AnotherFragmentInput a => AnotherFragmentInput (Quaternion a) where+    toFragment2 = proc ~(Quaternion a v) -> do+        a' <- toFragment2 -< a+        v' <- toFragment2 -< v+        returnA -< Quaternion a' v'++instance (AnotherFragmentInput (f a), AnotherFragmentInput a, FragmentFormat (f a) ~ f (FragmentFormat a)) => AnotherFragmentInput (Point f a) where+    toFragment2 = proc ~(P a) -> do+        a' <- toFragment2 -< a+        returnA -< P a'++instance AnotherFragmentInput a => AnotherFragmentInput (Plucker a) where+    toFragment2 = proc ~(Plucker a b c d e f) -> do+        a' <- toFragment2 -< a+        b' <- toFragment2 -< b+        c' <- toFragment2 -< c+        d' <- toFragment2 -< d+        e' <- toFragment2 -< e+        f' <- toFragment2 -< f+        returnA -< Plucker a' b' c' d' e' f'++------------------------------------------------------------------------------------------------------------------------------------++class AnotherFragmentInput a => FragmentCreator a where+    createFragment :: State Int a++instance FragmentCreator () where+    createFragment = return ()++instance FragmentCreator VFloat where+    createFragment = do+        n <- get+        put (n + 1)+        return $ S (return $ show n)++instance FragmentCreator FlatVFloat where+    createFragment = do+        n <- get+        put (n + 1)+        return $ Flat $ S (return $ show n)++instance FragmentCreator NoPerspectiveVFloat where+    createFragment = do+        n <- get+        put (n + 1)+        return $ NoPerspective $ S (return $ show n)++instance FragmentCreator VInt where+    createFragment = do+        n <- get+        put (n + 1)+        return $ S (return $ show n)++instance FragmentCreator VWord where+    createFragment = do+        n <- get+        put (n + 1)+        return $ S (return $ show n)++instance FragmentCreator VBool where+    createFragment = do+        n <- get+        put (n + 1)+        return $ S (return $ show n)++instance (FragmentCreator a) => FragmentCreator (V0 a) where+    createFragment = return V0++instance (FragmentCreator a) => FragmentCreator (V1 a) where+    createFragment = createFragment >>= return . V1++instance (FragmentCreator a) => FragmentCreator (V2 a) where+    createFragment = do+        x <- createFragment+        y <- createFragment+        return (V2 x y)++instance (FragmentCreator a) => FragmentCreator (V3 a) where+    createFragment = do+        x <- createFragment+        y <- createFragment+        z <- createFragment+        return (V3 x y z)++instance (FragmentCreator a) => FragmentCreator (V4 a) where+    createFragment = do+        x <- createFragment+        y <- createFragment+        z <- createFragment+        w <- createFragment+        return (V4 x y z w)++instance (FragmentCreator a, FragmentCreator b) => FragmentCreator (a,b) where+    createFragment = do+        x <- createFragment+        y <- createFragment+        return (x, y)++instance (FragmentCreator a, FragmentCreator b, FragmentCreator c) => FragmentCreator (a,b,c) where+    createFragment = do+        x <- createFragment+        y <- createFragment+        z <- createFragment+        return (x, y, z)++instance (FragmentCreator a, FragmentCreator b, FragmentCreator c, FragmentCreator d) => FragmentCreator (a,b,c,d) where+    createFragment = do+        x <- createFragment+        y <- createFragment+        z <- createFragment+        w <- createFragment+        return (x, y, z, w)++instance (FragmentCreator a, FragmentCreator b, FragmentCreator c, FragmentCreator d, FragmentCreator e) => FragmentCreator (a,b,c,d,e) where+    createFragment = do+        x <- createFragment+        y <- createFragment+        z <- createFragment+        w <- createFragment+        r <- createFragment+        return (x, y, z, w, r)++instance (FragmentCreator a, FragmentCreator b, FragmentCreator c, FragmentCreator d, FragmentCreator e, FragmentCreator f) => FragmentCreator (a,b,c,d,e,f) where+    createFragment = do+        x <- createFragment+        y <- createFragment+        z <- createFragment+        w <- createFragment+        r <- createFragment+        s <- createFragment+        return (x, y, z, w, r, s)++instance (FragmentCreator a, FragmentCreator b, FragmentCreator c, FragmentCreator d, FragmentCreator e, FragmentCreator f, FragmentCreator g) => FragmentCreator (a,b,c,d,e,f,g) where+    createFragment = do+        x <- createFragment+        y <- createFragment+        z <- createFragment+        w <- createFragment+        r <- createFragment+        s <- createFragment+        t <- createFragment+        return (x, y, z, w, r, s, t)++instance FragmentCreator a => FragmentCreator (Quaternion a) where+    createFragment = do+        a <- createFragment+        v <- createFragment+        return (Quaternion a v)++instance (FragmentCreator (f a), FragmentCreator a, FragmentFormat (f a) ~ f (FragmentFormat a)) => FragmentCreator (Point f a) where+    createFragment = do+        a <- createFragment+        return (P a)++instance FragmentCreator a => FragmentCreator (Plucker a) where+    createFragment = do+        a <- createFragment+        b <- createFragment+        c <- createFragment+        d <- createFragment+        e <- createFragment+        f <- createFragment+        return (Plucker a b c d e f)
+ src/Graphics/GPipe/Internal/Linear.hs view
@@ -0,0 +1,42 @@+module Graphics.GPipe.Internal.Linear where++import           Control.Lens ((^.))+import           Linear+++lookAt :: Floating a => V3 a -> V3 a -> V3 a -> V4 (V4 a)+lookAt eye center up =+  V4 (V4 (xa^._x)  (xa^._y)  (xa^._z)  xd)+     (V4 (ya^._x)  (ya^._y)  (ya^._z)  yd)+     (V4 (-za^._x) (-za^._y) (-za^._z) zd)+     (V4 0         0         0          1)+  where za = signorm $ center - eye+        xa = signorm $ cross za up+        ya = cross xa za+        xd = -dot xa eye+        yd = -dot ya eye+        zd = dot za eye+++rotMatrixX :: Floating a => a -> M44 a+rotMatrixX phi = V4+    (V4 1          0          0          0)+    (V4 0          ( cos phi) (-sin phi) 0)+    (V4 0          ( sin phi) ( cos phi) 0)+    (V4 0          0          0          1)+++rotMatrixY :: Floating a => a -> M44 a+rotMatrixY phi = V4+    (V4 ( cos phi) 0          ( sin phi) 0)+    (V4 0          1          0          0)+    (V4 (-sin phi) 0          ( cos phi) 0)+    (V4 0          0          0          1)+++rotMatrixZ :: Floating a => a -> M44 a+rotMatrixZ phi = V4+    (V4 ( cos phi) (-sin phi) 0          0)+    (V4 ( sin phi) ( cos phi) 0          0)+    (V4 0          0          1          0)+    (V4 0          0          0          1)
+ src/Graphics/GPipe/Internal/Orphans.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+module Graphics.GPipe.Internal.Orphans where++import Data.Boolean+import Linear.V0+import Linear.V1+import Linear.V2+import Linear.V3+import Linear.V4+import Linear.Plucker (Plucker(..))+import Linear.Quaternion (Quaternion(..))+import Linear.Affine (Point(..))++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+type instance BooleanOf (Plucker a) = BooleanOf a+type instance BooleanOf (Quaternion a) = BooleanOf a+type instance BooleanOf (Point f a) = BooleanOf (f a)++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 EqB a => EqB (Quaternion a) where+  Quaternion a v ==* Quaternion b u = a ==* b &&* v ==* u+  Quaternion a v /=* Quaternion b u = a /=* b ||* v /=* u+instance EqB a => EqB (Plucker a) where+  Plucker a b c d e f ==* Plucker x y z w u v = a ==* x &&* b ==* y &&* c ==* z &&* d ==* w &&* e ==* u &&* f ==* v+  Plucker a b c d e f /=* Plucker x y z w u v= a /=* x ||* b /=* y ||* c /=* z ||* d /=* w ||* e /=* u ||* f /=* v+instance EqB (f a) => EqB (Point f a) where+  P a ==* P x = a ==* x+  P a /=* P x = a /=* x+  +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) +instance IfB a => IfB (Quaternion a) where+        ifB q (Quaternion a v) (Quaternion b u) = Quaternion (ifB q a b) (ifB q v u)+instance IfB a => IfB (Plucker a) where+        ifB q (Plucker a b c d e f) (Plucker x y z w u v) = Plucker (ifB q a x) (ifB q b y) (ifB q c z) (ifB q d w) (ifB q e u) (ifB q f v)+instance IfB (f a) => IfB (Point f a) where+        ifB q (P a) (P x) = P (ifB q a x)
+ src/Graphics/GPipe/Internal/PrimitiveArray.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, EmptyDataDecls, TypeFamilies, GADTs #-}+module Graphics.GPipe.Internal.PrimitiveArray where++import Graphics.GPipe.Internal.Buffer+import Graphics.GPipe.Internal.Shader+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup+#endif+import Data.IORef++import Data.Word++import           Graphics.GL.Core45+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,+    vertexArraySkip :: 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 (VertexArray t a)+newVertexArray buffer = Render $ return $ VertexArray (bufferLength buffer) 0 $ bufBElement buffer++instance Functor (VertexArray t) where+    fmap f (VertexArray n s g) = VertexArray n s (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 s f) (VertexArray m t g) = VertexArray (min n m) totSkip newArrFun+    where totSkip = min s t+          newArrFun x = let baseSkip = bInSkipElems x - totSkip in h (f x { bInSkipElems = baseSkip + s}) (g x { bInSkipElems = baseSkip + t})++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 l s f) = VertexArray (min (max n 0) l) s 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 l s f) = VertexArray (l - n') (s+n') f where n' = min (max n 0) l++-- | @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 l s f) = VertexArray (n * l) s (\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 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 (max 0 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 = l - n', offset = offset i + n' }+    where+        l = indexArrayLength i+        n' = min (max n 0) l++data Points = PointList+data Lines = LineLoop | LineStrip | LineList+data LinesWithAdjacency = LineListAdjacency | LineStripAdjacency+data Triangles = TriangleList | TriangleStrip+data TrianglesWithAdjacency = TriangleListAdjacency | TriangleStripAdjacency++class PrimitiveTopology p where+    toGLtopology :: p -> GLuint+    toPrimitiveSize :: p -> Int+    toGeometryShaderOutputTopology :: p -> GLuint+    toLayoutIn :: p -> String+    toLayoutOut :: p -> String+    data Geometry p a++instance PrimitiveTopology Points where+    toGLtopology PointList = GL_POINTS+    toPrimitiveSize _= 1+    toGeometryShaderOutputTopology _ = GL_POINTS+    toLayoutIn _ = "points"+    toLayoutOut _ = "points"+    data Geometry Points a = Point a++instance PrimitiveTopology Lines where+    toGLtopology LineList = GL_LINES+    toGLtopology LineLoop = GL_LINE_LOOP+    toGLtopology LineStrip = GL_LINE_STRIP+    toPrimitiveSize _= 2+    toGeometryShaderOutputTopology _ = GL_LINES+    toLayoutIn _ = "lines"+    toLayoutOut _ = "line_strip"+    data Geometry Lines a = Line a a++instance PrimitiveTopology LinesWithAdjacency where+    toGLtopology LineListAdjacency = GL_LINES_ADJACENCY+    toGLtopology LineStripAdjacency = GL_LINE_STRIP_ADJACENCY+    toPrimitiveSize _= 2+    toGeometryShaderOutputTopology _ = GL_LINES+    toLayoutIn _ = "lines_adjacency"+    toLayoutOut _ = "line_strip"+    data Geometry LinesWithAdjacency a = LineWithAdjacency a a a a++instance PrimitiveTopology Triangles where+    toGLtopology TriangleList = GL_TRIANGLES+    toGLtopology TriangleStrip = GL_TRIANGLE_STRIP+    toPrimitiveSize _= 3+    toGeometryShaderOutputTopology _ = GL_TRIANGLES+    toLayoutIn _ = "triangles"+    toLayoutOut _ = "triangle_strip"+    data Geometry Triangles a = Triangle a a a++instance PrimitiveTopology TrianglesWithAdjacency where+    toGLtopology TriangleListAdjacency = GL_TRIANGLES_ADJACENCY+    toGLtopology TriangleStripAdjacency = GL_TRIANGLE_STRIP_ADJACENCY+    toPrimitiveSize _= 3+    toGeometryShaderOutputTopology _ = GL_TRIANGLES+    toLayoutIn _ = "triangles_adjacency"+    toLayoutOut _ = "triangle_strip"+    data Geometry TrianglesWithAdjacency a = TriangleWithAdjacency a a a a a a++type InstanceCount = Int+type BaseVertex = Int++-- PrimitiveTopology p =>+data PrimitiveArrayInt p a = PrimitiveArraySimple p Int BaseVertex a+                           | PrimitiveArrayIndexed p IndexArray BaseVertex a+                           | PrimitiveArrayInstanced p InstanceCount Int BaseVertex a+                           | PrimitiveArrayIndexedInstanced p IndexArray InstanceCount BaseVertex a++-- | An array of primitives+newtype PrimitiveArray p a = PrimitiveArray {getPrimitiveArray :: [PrimitiveArrayInt p a]}++instance Semigroup (PrimitiveArray p a) where+    PrimitiveArray a <> PrimitiveArray b = PrimitiveArray (a ++ b)++instance Monoid (PrimitiveArray p a) where+    mempty = PrimitiveArray []+#if __GLASGOW_HASKELL__ < 804+    mappend = (<>)+#endif++instance Functor (PrimitiveArray p) where+    fmap f (PrimitiveArray xs) = PrimitiveArray $ fmap g xs+        where g (PrimitiveArraySimple p l s a) = PrimitiveArraySimple p l s (f a)+              g (PrimitiveArrayIndexed p i s a) = PrimitiveArrayIndexed p i s (f a)+              g (PrimitiveArrayInstanced p il l s a) = PrimitiveArrayInstanced p il l s (f a)+              g (PrimitiveArrayIndexedInstanced p i il s a) = PrimitiveArrayIndexedInstanced p i il s (f a)++toPrimitiveArray :: PrimitiveTopology p => p -> VertexArray () a -> PrimitiveArray p a+toPrimitiveArray p va = PrimitiveArray [PrimitiveArraySimple p (vertexArrayLength va) (vertexArraySkip va) (bArrBFunc va (BInput 0 0))]+toPrimitiveArrayIndexed :: PrimitiveTopology p => p -> IndexArray -> VertexArray () a -> PrimitiveArray p a+toPrimitiveArrayIndexed p ia va = PrimitiveArray [PrimitiveArrayIndexed p ia (vertexArraySkip va) (bArrBFunc va (BInput 0 0))]+toPrimitiveArrayInstanced :: PrimitiveTopology p => p -> (a -> b -> c) -> VertexArray () a -> VertexArray t b -> PrimitiveArray p c+toPrimitiveArrayInstanced p f va ina = PrimitiveArray [PrimitiveArrayInstanced p (vertexArrayLength ina) (vertexArrayLength va) (vertexArraySkip va) (f (bArrBFunc va $ BInput 0 0) (bArrBFunc ina $ BInput (vertexArraySkip ina) 1))] -- Base instance not supported in GL < 4, so need to burn in+toPrimitiveArrayIndexedInstanced :: PrimitiveTopology p => 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) (vertexArraySkip va) (f (bArrBFunc va $ BInput 0 0) (bArrBFunc ina $ BInput (vertexArraySkip ina) 1))] -- Base instance not supported in GL < 4, so need to burn in
+ src/Graphics/GPipe/Internal/PrimitiveStream.hs view
@@ -0,0 +1,591 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, Arrows, GeneralizedNewtypeDeriving, PatternSynonyms #-}++module Graphics.GPipe.Internal.PrimitiveStream where++import Control.Arrow+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader+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+-- This import is only needed for the unused uniform alternate implementation.+import Graphics.GPipe.Internal.Uniform+import Control.Category+import Control.Arrow+import Control.Monad (void, when)+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup (Semigroup(..))+#endif+import Data.IntMap.Lazy (insert)+import Data.Word+import Data.Int+import Foreign.Marshal (alloca)+import Foreign.Storable+import Foreign.Ptr+import qualified Data.IntMap as Map++import Graphics.GL.Core45+import Graphics.GL.Types+import Foreign.Marshal.Utils+import Data.IORef+import Linear.V4+import Linear.V3+import Linear.V2+import Linear.V1+import Linear.V0+import Linear.Plucker (Plucker(..))+import Linear.Quaternion (Quaternion(..))+import Linear.Affine (Point(..))+import Data.Maybe (fromMaybe)+import System.IO+import Control.Monad.IO.Class++import Graphics.GPipe.Internal.Debug++-- Originally named DrawCallName and later in the code as PrimN. I've sticked+-- with the latter, because it's more logical.+type PrimitiveName = Int++-- The size of the special uniform buffer object used for uniform inputs No such+-- buffer is allocated if not used and it is only used when literal values are+-- used in a primitive stream transmitted using a dedicated uniform buffer+-- object.+type USize = Int++data PrimitiveStreamData = PrimitiveStreamData PrimitiveName USize++-- Should be renamed as VertexStream. There a reason why the underlying VAO+-- behind is called a VAO. Beside, it forces me to name GeometryStream the real+-- PrimitiveStream. I don’t need why 't' was carried alongside but it is now+-- required for adding Geometry shaders.+--+-- | 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, (Maybe PointSize, PrimitiveStreamData))] deriving (Semigroup, 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 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)++type UniOffset = Int++-- | The arrow type for 'toVertex'.+data ToVertex a b = ToVertex++    -- To set the uniform buffer content.+    -- It is only used by the "uniform vertex" which is deprecated/experimental (see toUniformVertex).+    -- As it, it is not currently in use.+    -- Note: output value 'b' is not relevant.+    !(  Kleisli+        (   StateT (Ptr ()) IO+        ) a b)++    -- To declare the input variable in the shader.+    !(  Kleisli+        (   StateT+            (   Int -- The number of components in the stored type (eg. would 2 for a B2/V2).+            ,   UniOffset -- Offset to the uniform?+            ,   OffsetToSType -- Offset -> SType?+            )+            (   Reader+                (   Int {- offset -} -> ExprM String -- Ends up calling useVInput and returning the input variable name (eg. 'in123').+                )+            )+        ) a b)++    -- To bind the underlying VAO for the vertex buffer (see PrimitiveArray).+    -- Note: output value 'b' is not relevant.+    !(  Kleisli+        (   State+            [   Binding -> (IO VAOKey, IO ())+            ]+        ) a b)++instance Category ToVertex where+    {-# INLINE id #-}+    id = ToVertex id id id+    {-# INLINE (.) #-}+    ToVertex a b c . ToVertex x y z = ToVertex (a.x) (b.y) (c.z)++instance Arrow ToVertex where+    {-# INLINE arr #-}+    arr f = ToVertex (arr f) (arr f) (arr f)+    {-# INLINE first #-}+    first (ToVertex a b c) = ToVertex (first a) (first b) (first c)++-- | Create a primitive stream from a primitive array provided from the shader environment.+-- TODO No way to constraint 'b' a bit more?+toPrimitiveStream :: forall os f s a p. (PrimitiveTopology p, VertexInput a) => (s -> PrimitiveArray p a) -> Shader os s (PrimitiveStream p (VertexFormat a))+toPrimitiveStream = toPrimitiveStream' Nothing++toPrimitiveStream' :: forall os f s a b p. (PrimitiveTopology p, VertexInput a) => Maybe (s -> Buffer os b) -> (s -> PrimitiveArray p a) -> Shader os s (PrimitiveStream p (VertexFormat a))+toPrimitiveStream' getFeedbackBuffer sf = Shader $ do++    -- Get a unique (OpenGL) name for this shader by updating the 'ShaderState' (a pair of the next name and a 'RenderIOState s') from the ReaderT/WriterT/ListM/State.+    n <- getNewName++    -- Get the RO uniform alignment from the ReaderT+    uniAl <- askUniformAlignment -- uniAl is not used around…++    let+        -- The explosive input value is only here to ensure that the mf arrow is lazy.+        err = error "toPrimitiveStream is creating values that are dependant on the actual HostFormat values, this is not allowed since it doesn't allow static creation of shaders"+        -- Is 'offToStype' really built this way or it is not used at all?+        (x, (_, uSize, offToStype)) = runReader+            (runStateT (makeV err) (0, 0, mempty))+            (useUniform (buildUDecl offToStype) 0) -- 0 is special blockname for the one used by primitive stream++    -- Register the actual OpenGL bind and draw commands for this shader name.+    doForInputArray n $ \s ->+        let+            fb = getFeedbackBuffer >>= \g -> return (g s)+            ps = getPrimitiveArray (sf s)+        in+            map drawcall (map (\p -> (fb, p)) ps)++    return $ PrimitiveStream [(x, (Nothing, PrimitiveStreamData n uSize))]++    where+        ToVertex+            (Kleisli uWriter) -- To set the uniform content (for the literal values, not the one buffered).+            (Kleisli makeV) -- To create (and declare) the input variable in the shader.+            (Kleisli makeBind) -- To construct the VAO.+            = toVertex :: ToVertex a (VertexFormat a) -- Select the ToVertex to translate 'a' into a 'VertexFormat a'.++        drawcall (Just feedbackBuffer, PrimitiveArraySimple p l s a) binds = (attribs a binds, do+            -- liftIO $ hPutStrLn stderr $ "drawcall 1"+            Just (tfName, tfqName) <- readIORef (bufTransformFeedback feedbackBuffer)+            if False+                -- The bigger the amount of vertice, the faster a "*ERROR* Waiting for fences timed out!" will happen…+                -- For small amounts, works fine.+                then glDrawTransformFeedback (toGLtopology p) tfName+                else do+                    -- Is it costly too do it repeatedly?+                    l' <- (fromIntegral (toPrimitiveSize p) *) <$> (alloca $ \ptr -> do+                        glGetQueryObjectiv tfqName GL_QUERY_RESULT ptr+                        peek ptr)+                    -- liftIO $ hPutStrLn stderr $ "queried vertice count: " ++ show l'+                    when (l' > 0) $ do+                        glDrawArrays (toGLtopology p) (fromIntegral s) l'+            )+        drawcall (Just feedbackBuffer, PrimitiveArrayInstanced p il l s a) binds = (attribs a binds, do+            -- liftIO $ hPutStrLn stderr $ "drawcall 2"+            Just (tfName, _) <- readIORef (bufTransformFeedback feedbackBuffer)+            glDrawTransformFeedbackInstanced (toGLtopology p) tfName (fromIntegral il))++        drawcall (Nothing, PrimitiveArraySimple p l s a) binds = (attribs a binds, do+            -- liftIO $ hPutStrLn stderr $ "drawcall 3"+            glDrawArrays (toGLtopology p) (fromIntegral s) (fromIntegral l))+        drawcall (Nothing, PrimitiveArrayIndexed p i s a) binds = (attribs a binds, do+            -- liftIO $ hPutStrLn stderr $ "drawcall 4"+            bindIndexBuffer i+            glDrawElementsBaseVertex (toGLtopology p) (fromIntegral $ indexArrayLength i) (indexType i) (intPtrToPtr $ fromIntegral $ offset i * glSizeOf (indexType i)) (fromIntegral s))+        drawcall (Nothing, PrimitiveArrayInstanced p il l s a) binds = (attribs a binds, do+            -- liftIO $ hPutStrLn stderr $ "drawcall 5"+            glDrawArraysInstanced (toGLtopology p) (fromIntegral s) (fromIntegral l) (fromIntegral il))+        drawcall (Nothing, PrimitiveArrayIndexedInstanced p i il s a) binds = (attribs a binds, do+            -- liftIO $ hPutStrLn stderr $ "drawcall 6"+            bindIndexBuffer i+            glDrawElementsInstancedBaseVertex (toGLtopology p) (fromIntegral $ indexArrayLength i) (indexType i) (intPtrToPtr $ fromIntegral $ offset i * glSizeOf (indexType i)) (fromIntegral il) (fromIntegral s))++        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+        glSizeOf GL_UNSIGNED_INT = 4+        glSizeOf GL_UNSIGNED_SHORT = 2+        glSizeOf GL_UNSIGNED_BYTE = 1+        glSizeOf _ = error "toPrimitiveStream: Unknown indexArray type"++        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, uBname, uSize) = let+                              bindsAssoc = execState (makeBind a) [] -- (_,bindsAssoc) = runState (makeBind a) []+                              (ioVaokeys, ios) = unzip $ assignIxs 0 0 binds $ reverse bindsAssoc+                          in (writeUBuffer uBname uSize a >> sequence ioVaokeys, sequence_ ios)++        -- Modify the (OpenGL) shader state which is the set of OpenGL commands to run to draw this shader.+        doForInputArray :: Int -> (s -> [([Binding], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())]) -> ShaderM s ()+        doForInputArray n io = modifyRenderIO (\s -> s { inputArrayToRenderIO = insert n io (inputArrayToRenderIO s) } ) -- modifyRenderIO changes the ShaderState++        writeUBuffer _ 0 _ = return () -- If the uniform buffer is size 0 there is no buffer+        writeUBuffer bname size a = do+            error "Cannot happen!"+            glBindBuffer GL_COPY_WRITE_BUFFER bname+            ptr <- glMapBufferRange GL_COPY_WRITE_BUFFER 0 (fromIntegral size) (GL_MAP_WRITE_BIT + GL_MAP_INVALIDATE_BUFFER_BIT)+            void $ runStateT (uWriter a) ptr+            void $ glUnmapBuffer GL_COPY_WRITE_BUFFER++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")))++type PointSize = VFloat+-- | Like 'fmap', but where each point's size is provided as arguments as well, and a new point size is set for each point in addition to the new vertex value.+--+--   When a 'PrimitiveStream' of 'Points' is created, all points will have the default size of 1.+withPointSize :: (a -> PointSize -> (b, PointSize)) -> PrimitiveStream Points a -> PrimitiveStream Points b+withPointSize f (PrimitiveStream xs) = PrimitiveStream $ map (\(a, (ps, d)) -> let (b, ps') = f a (fromMaybe (scalarS' "1") ps) in (b, (Just ps', d))) xs++append :: Monad m => a -> StateT [a] m ()+append x = modify (x:)++-- Why x which is not needed? Is n < x true?+makeVertexF x f styp _ = do+    (n, uoffset, m) <- get+    put (n + 1, uoffset, m)+    return (f styp $ useVInput styp n)++makeBindVertexFx norm x typ b = do+    let combOffset = bStride b * bSkipElems b + bOffset b+    append (\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 undefined++makeBindVertexFnorm = makeBindVertexFx True+makeBindVertexF = makeBindVertexFx False++makeVertexI x f styp _ = do+    (n, uoffset,m) <- get+    put (n + 1, uoffset,m)+    return (f styp $ useVInput styp n)++makeBindVertexI x typ b = do+    let combOffset = bStride b * bSkipElems b + bOffset b+    append (\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 undefined++noWriter = Kleisli (const $ return undefined)++-- Uniform vertex values? Some kind of alternate implementation for uniforms not+-- currently used (the regular uniforms are handled in the Uniform module). It+-- don’t know if it is something deprecated or experimental. I don’t even know+-- how it could be used. Obviously, a buffer cannot contains both varying and+-- uniform data…+--+-- [begin]+toUniformVertex :: forall a b. Storable a => SType -> ToVertex a (S V b)+toUniformVertex styp = ToVertex (Kleisli uWriter) (Kleisli makeV) (Kleisli makeBind)+    where+        size = sizeOf (undefined :: a)+        uWriter a = do+            ptr <- get+            put (ptr `plusPtr` size)+            lift $ poke (castPtr ptr) a+            return undefined+        makeV a = do+            (n, uoffset,m) <- get+            put (n, uoffset + size, Map.insert uoffset styp m)+            useF <- lift ask+            return $ S $ useF uoffset+        makeBind a =+            return undefined++instance VertexInput Float where+    type VertexFormat Float = VFloat+    toVertex = toUniformVertex STypeFloat++instance VertexInput Int32 where+    type VertexFormat Int32 = VInt+    toVertex = toUniformVertex STypeInt++instance VertexInput Word32 where+    type VertexFormat Word32 = VWord+    toVertex = toUniformVertex STypeUInt+-- [end]++-- scalars++unBnorm :: Normalized t -> t+unBnorm (Normalized a) = a++instance VertexInput (B Float) where+    type VertexFormat (B Float) = VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 1 (const S) STypeFloat) (Kleisli $ makeBindVertexF 1 GL_FLOAT)+instance VertexInput (Normalized (B Int32)) where+    type VertexFormat (Normalized (B Int32)) = VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 1 (const S) STypeFloat . unBnorm) (Kleisli $ makeBindVertexFnorm 1 GL_INT . unBnorm)+instance VertexInput (Normalized (B Word32)) where+    type VertexFormat (Normalized (B Word32)) = VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 1 (const S) STypeFloat . unBnorm) (Kleisli $ makeBindVertexFnorm 1 GL_UNSIGNED_INT . unBnorm)+instance VertexInput (B Int32) where+    type VertexFormat (B Int32) = VInt+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 1 (const S) STypeInt) (Kleisli $ makeBindVertexI 1 GL_INT)+instance VertexInput (B Word32) where+    type VertexFormat (B Word32) = VWord+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 1 (const S) STypeUInt) (Kleisli $ makeBindVertexI 1 GL_UNSIGNED_INT)+++-- B2++instance VertexInput (B2 Float) where+    type VertexFormat (B2 Float) = V2 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2) (Kleisli $ makeBindVertexF 2 GL_FLOAT . unB2)+instance VertexInput (Normalized (B2 Int32)) where+    type VertexFormat (Normalized (B2 Int32)) = V2 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2 . unBnorm) (Kleisli $ makeBindVertexFnorm 2 GL_INT . unB2 . unBnorm)+instance VertexInput (Normalized (B2 Int16)) where+    type VertexFormat (Normalized (B2 Int16)) = V2 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2 . unBnorm) (Kleisli $ makeBindVertexFnorm 2 GL_SHORT . unB2 . unBnorm)+instance VertexInput (Normalized (B2 Word32)) where+    type VertexFormat (Normalized (B2 Word32)) = V2 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2 . unBnorm) (Kleisli $ makeBindVertexFnorm 2 GL_UNSIGNED_INT . unB2 . unBnorm)+instance VertexInput (Normalized (B2 Word16)) where+    type VertexFormat (Normalized (B2 Word16)) = V2 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 2 vec2S (STypeVec 2) . unB2 . unBnorm) (Kleisli $ makeBindVertexFnorm 2 GL_UNSIGNED_SHORT . unB2 . unBnorm)+instance VertexInput (B2 Int32) where+    type VertexFormat (B2 Int32) = V2 VInt+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 2 vec2S (STypeIVec 2) . unB2) (Kleisli $ makeBindVertexI 2 GL_INT . unB2)+instance VertexInput (B2 Int16) where+    type VertexFormat (B2 Int16) = V2 VInt+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 2 vec2S (STypeIVec 2) . unB2) (Kleisli $ makeBindVertexI 2 GL_SHORT . unB2)+instance VertexInput (B2 Word32) where+    type VertexFormat (B2 Word32) = V2 VWord+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 2 vec2S (STypeUVec 2) . unB2) (Kleisli $ makeBindVertexI 2 GL_UNSIGNED_INT . unB2)+instance VertexInput (B2 Word16) where+    type VertexFormat (B2 Word16) = V2 VWord+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 2 vec2S (STypeUVec 2) . unB2) (Kleisli $ makeBindVertexI 2 GL_UNSIGNED_SHORT . unB2)++-- B3++instance VertexInput (B3 Float) where+    type VertexFormat (B3 Float) = V3 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3) (Kleisli $ makeBindVertexF 3 GL_FLOAT . unB3)+instance VertexInput (Normalized (B3 Int32)) where+    type VertexFormat (Normalized (B3 Int32)) = V3 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_INT . unB3 . unBnorm)+instance VertexInput (Normalized (B3 Int16)) where+    type VertexFormat (Normalized (B3 Int16)) = V3 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_SHORT . unB3 . unBnorm)+instance VertexInput (Normalized (B3 Int8)) where+    type VertexFormat (Normalized (B3 Int8)) = V3 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_BYTE . unB3 . unBnorm)+instance VertexInput (Normalized (B3 Word32)) where+    type VertexFormat (Normalized (B3 Word32)) = V3 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_UNSIGNED_INT . unB3 . unBnorm)+instance VertexInput (Normalized (B3 Word16)) where+    type VertexFormat (Normalized (B3 Word16)) = V3 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_UNSIGNED_SHORT . unB3 . unBnorm)+instance VertexInput (Normalized (B3 Word8)) where+    type VertexFormat (Normalized (B3 Word8)) = V3 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 3 vec3S (STypeVec 3) . unB3 . unBnorm) (Kleisli $ makeBindVertexFnorm 3 GL_UNSIGNED_BYTE . unB3 . unBnorm)+instance VertexInput (B3 Int32) where+    type VertexFormat (B3 Int32) = V3 VInt+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_INT . unB3)+instance VertexInput (B3 Int16) where+    type VertexFormat (B3 Int16) = V3 VInt+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_SHORT . unB3)+instance VertexInput (B3 Int8) where+    type VertexFormat (B3 Int8) = V3 VInt+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeIVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_BYTE . unB3)+instance VertexInput (B3 Word32) where+    type VertexFormat (B3 Word32) = V3 VWord+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_UNSIGNED_INT . unB3)+instance VertexInput (B3 Word16) where+    type VertexFormat (B3 Word16) = V3 VWord+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_UNSIGNED_SHORT . unB3)+instance VertexInput (B3 Word8) where+    type VertexFormat (B3 Word8) = V3 VWord+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 3 vec3S (STypeUVec 3) . unB3) (Kleisli $ makeBindVertexI 3 GL_UNSIGNED_BYTE . unB3)++-- B4++instance VertexInput (B4 Float) where+    type VertexFormat (B4 Float) = V4 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4) (Kleisli $ makeBindVertexF 4 GL_FLOAT . unB4)+instance VertexInput (Normalized (B4 Int32)) where+    type VertexFormat (Normalized (B4 Int32)) = V4 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_INT . unB4 . unBnorm)+instance VertexInput (Normalized (B4 Int16)) where+    type VertexFormat (Normalized (B4 Int16)) = V4 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_SHORT . unB4 . unBnorm)+instance VertexInput (Normalized (B4 Int8)) where+    type VertexFormat (Normalized (B4 Int8)) = V4 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_BYTE . unB4 . unBnorm)+instance VertexInput (Normalized (B4 Word32)) where+    type VertexFormat (Normalized (B4 Word32)) = V4 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_UNSIGNED_INT . unB4 . unBnorm)+instance VertexInput (Normalized (B4 Word16)) where+    type VertexFormat (Normalized (B4 Word16)) = V4 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_UNSIGNED_SHORT . unB4 . unBnorm)+instance VertexInput (Normalized (B4 Word8)) where+    type VertexFormat (Normalized (B4 Word8)) = V4 VFloat+    toVertex = ToVertex noWriter (Kleisli $ makeVertexF 4 vec4S (STypeVec 4) . unB4 . unBnorm) (Kleisli $ makeBindVertexFnorm 4 GL_UNSIGNED_BYTE . unB4 . unBnorm)+instance VertexInput (B4 Int32) where+    type VertexFormat (B4 Int32) = V4 VInt+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_INT . unB4)+instance VertexInput (B4 Int16) where+    type VertexFormat (B4 Int16) = V4 VInt+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_SHORT . unB4)+instance VertexInput (B4 Int8) where+    type VertexFormat (B4 Int8) = V4 VInt+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeIVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_BYTE . unB4)+instance VertexInput (B4 Word32) where+    type VertexFormat (B4 Word32) = V4 VWord+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_UNSIGNED_INT . unB4)+instance VertexInput (B4 Word16) where+    type VertexFormat (B4 Word16) = V4 VWord+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_UNSIGNED_SHORT . unB4)+instance VertexInput (B4 Word8) where+    type VertexFormat (B4 Word8) = V4 VWord+    toVertex = ToVertex noWriter (Kleisli $ makeVertexI 4 vec4S (STypeUVec 4) . unB4) (Kleisli $ makeBindVertexI 4 GL_UNSIGNED_BYTE . unB4)++instance VertexInput () where+    type VertexFormat () = ()+    toVertex = arr (const ())++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 b, VertexInput c, VertexInput d, VertexInput e) => VertexInput (a,b,c,d,e) where+    type VertexFormat (a,b,c,d,e) = (VertexFormat a, VertexFormat b, VertexFormat c, VertexFormat d, VertexFormat e)+    toVertex = proc ~(a,b,c,d,e) -> do a' <- toVertex -< a+                                       b' <- toVertex -< b+                                       c' <- toVertex -< c+                                       d' <- toVertex -< d+                                       e' <- toVertex -< e+                                       returnA -< (a', b', c', d', e')++instance (VertexInput a, VertexInput b, VertexInput c, VertexInput d, VertexInput e, VertexInput f) => VertexInput (a,b,c,d,e,f) where+    type VertexFormat (a,b,c,d,e,f) = (VertexFormat a, VertexFormat b, VertexFormat c, VertexFormat d, VertexFormat e, VertexFormat f)+    toVertex = proc ~(a,b,c,d,e,f) -> do a' <- toVertex -< a+                                         b' <- toVertex -< b+                                         c' <- toVertex -< c+                                         d' <- toVertex -< d+                                         e' <- toVertex -< e+                                         f' <- toVertex -< f+                                         returnA -< (a', b', c', d', e', f')++instance (VertexInput a, VertexInput b, VertexInput c, VertexInput d, VertexInput e, VertexInput f, VertexInput g) => VertexInput (a,b,c,d,e,f,g) where+    type VertexFormat (a,b,c,d,e,f,g) = (VertexFormat a, VertexFormat b, VertexFormat c, VertexFormat d, VertexFormat e, VertexFormat f, VertexFormat g)+    toVertex = proc ~(a,b,c,d,e,f,g) -> do a' <- toVertex -< a+                                           b' <- toVertex -< b+                                           c' <- toVertex -< c+                                           d' <- toVertex -< d+                                           e' <- toVertex -< e+                                           f' <- toVertex -< f+                                           g' <- toVertex -< g+                                           returnA -< (a', b', c', d', e', f', g')++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'+++instance VertexInput a => VertexInput (Quaternion a) where+    type VertexFormat (Quaternion a) = Quaternion (VertexFormat a)+    toVertex = proc ~(Quaternion a v) -> do+                a' <- toVertex -< a+                v' <- toVertex -< v+                returnA -< Quaternion a' v'++instance (VertexInput (f a), VertexInput a, HostFormat (f a) ~ f (HostFormat a), VertexFormat (f a) ~ f (VertexFormat a)) => VertexInput (Point f a) where+    type VertexFormat (Point f a) = Point f (VertexFormat a)+    toVertex = proc ~(P a) -> do+                a' <- toVertex -< a+                returnA -< P a'++instance VertexInput a => VertexInput (Plucker a) where+    type VertexFormat (Plucker a) = Plucker (VertexFormat a)+    toVertex = proc ~(Plucker a b c d e f) -> do+                a' <- toVertex -< a+                b' <- toVertex -< b+                c' <- toVertex -< c+                d' <- toVertex -< d+                e' <- toVertex -< e+                f' <- toVertex -< f+                returnA -< Plucker a' b' c' d' e' f'
+ src/Graphics/GPipe/Internal/Shader.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts,+  RankNTypes, ExistentialQuantification, GeneralizedNewtypeDeriving,+  FlexibleInstances, GADTs #-}++module Graphics.GPipe.Internal.Shader (+    Shader(..),+    ShaderM(..),+    ShaderState(..),+    CompiledShader,+    Render(..),+    getNewName,+    tellDrawcall,+    askUniformAlignment,+    modifyRenderIO,+    compileShader,+    mapShader,+    guard',+    maybeShader,+    chooseShader,+    silenceShader+) where+++import Graphics.GPipe.Internal.Compiler+import Graphics.GPipe.Internal.Context+import Graphics.GPipe.Internal.Buffer+import Control.Monad+import Control.Monad.Trans.State+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer.Lazy (tell, WriterT(..), execWriterT)+import Control.Monad.Exception (MonadException)+import Control.Applicative (Alternative, (<|>))+import Control.Monad.Trans.Class (lift)+import Data.Maybe (fromJust, isJust, isNothing)+import Control.Monad.Trans.List (ListT(..))+import Data.Monoid (All(..))+import Data.Either+import Control.Monad.Trans.Reader+import Data.List (find)++{- Some wording & structure:++    Shader (with a majuscule) = "GPipeShader" => [(OpenGL program made of OpenGL shaders, condition)]++    When a Shader is compiled, it means that it is translated into OpenGl shader+    sources (with a context) which are compiled then linked in programs when+    wrapped into a rendering action which select the appropriate shader at+    runtime.+-}++-- More a "GPipeShaderEnvironmentContextConnector".+data ShaderState s = ShaderState+    Int -- Next name.+    (RenderIOState s)++newShaderState :: ShaderState s+newShaderState = ShaderState 1 newRenderIOState++{-+I'm not a big fan of the ShaderM monad, because its important part is its side+effects. A the end of the day, we always end up with a ShaderM os () and are+only interested in the 'told' drawcalls with the 'put' ShaderState. When a+ShaderM is not returning a () value, there are no drawcall (yet), the returned+value is mostly a work in progress constructed and the context of the ShaderM is+not really used (WriterT is not used in any cases). I'm probably talking outside+my level of profiency here, but I suspect it would have been cleaner & clearer+to separate the WriterT.+-}+newtype ShaderM s a = ShaderM+    (ReaderT+        UniformAlignment -- Meant to be retrieved using askUniformAlignment.+        (WriterT+            (   [IO (Drawcall s)] -- Produce a list of drawcalls (the IO is only here for SNMap)+            ,   s -> All -- Condition to execute the drawcalls (need to be a monoid such as the tuple could be too).+            )+            (ListT -- Needed to automatically derive MonadPlus and Application, but what else?+                (State+                    (ShaderState s)+                )+            )+        )+        a+    )+    deriving (MonadPlus, Monad, Alternative, Applicative, Functor)++-- Return a new name to be used as a key in RenderIOState. for a program,+-- shader, uniform, texture unit (sampler)… or something not related to a named+-- OpenGL object.+getNewName :: ShaderM s Int+getNewName = do+    ShaderState n r <- ShaderM $ lift $ lift $ lift get+    ShaderM $ lift $ lift $ lift $ put $ ShaderState (n+1) r+    return n++askUniformAlignment :: ShaderM s UniformAlignment+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 drawcall = ShaderM $ lift $ tell ([drawcall], mempty)++-- | The monad in which all GPU computations are done. 'Shader os s a' lives in+-- an object space 'os' and a context with format 'f', closing over an+-- environent of type 's'.+newtype Shader os 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 s' a -> Shader os s a+mapShader f (Shader (ShaderM m)) = Shader $ ShaderM $ do+    uniAl <- ask+    lift $ WriterT $ ListT $ do+        ShaderState x s <- get+        let (conditionalDrawcalls, ShaderState x' s') = runState (runListT (runWriterT (runReaderT m uniAl))) (ShaderState x newRenderIOState)+        put $ ShaderState x' (mapRenderIOState f s' s)+        return $ map (\(a, (drawcalls, test)) -> (a, (map (>>= (return . mapDrawcall f)) drawcalls, test . f))) conditionalDrawcalls++-- | Conditionally run the effects of a shader when a 'Maybe' value is 'Just'+-- something.+maybeShader :: (s -> Maybe s') -> Shader os s' () -> Shader os s ()+maybeShader f m = (guard' (isJust . f) >> mapShader (fromJust . f) m) <|> guard' (isNothing . f)++-- | Select one of two 'Shader' actions based on whether an 'Either' value is+-- 'Left' or 'Right'.+chooseShader :: (s -> Either s' s'') -> Shader os s' a -> Shader os s'' a -> Shader os 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.+silenceShader :: Shader os s a -> Shader os s a+silenceShader (Shader (ShaderM m)) = Shader $ ShaderM $ do+    uniAl <- ask+    lift $ WriterT $ ListT $ do+        s <- get+        let (conditionalDrawcalls, s') = runState (runListT (runWriterT (runReaderT m uniAl))) s+        put s'+        return $ map (\ (a, (_, test)) -> (a, ([], test))) conditionalDrawcalls++-- | 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 s ()+guard' f = Shader $ ShaderM $ lift $ tell (mempty, All . f)++-- | A compiled shader is just a function that takes an environment and returns+-- a 'Render' action It could have been called 'CompiledDrawcall' or 'Renderer'+-- because it is the same thing.+type CompiledShader os s = s -> Render os ()++-- | 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)+compileShader :: (ContextHandler ctx, MonadIO m, MonadException m) => Shader os s () -> ContextT ctx os m (CompiledShader os s)+compileShader (Shader (ShaderM m)) = do++    uniformAlignment <- liftNonWinContextIO getUniformAlignment+    let (conditionalDrawcalls, ShaderState _ state) = runState (runListT (execWriterT (runReaderT m uniformAlignment))) newShaderState+    conditionalRenderers <- forM conditionalDrawcalls $ \ (drawcalls, test) -> do+        renderer <- compileDrawcalls drawcalls state+        return (renderer, test)++    -- Return a wrapping renderer which select the first renderer for the+    -- environment before using it. Remember: renderer <=> CompiledDrawcall <=> CompiledShader+    return $ \ environment -> case find (\ (_, test) -> getAll (test environment)) conditionalRenderers of+        Nothing -> error "render: Shader evaluated to mzero (no Shader selected)"+        Just (renderer, _) -> renderer environment
+ src/Graphics/GPipe/Internal/Texture.hs view
@@ -0,0 +1,1254 @@+{-# 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.Core45+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.Monad.Exception (bracket, MonadAsyncException)+import Linear.V4+import Linear.V3+import Linear.V2+import Control.Exception (throwIO)+import Control.Monad.Trans.Class (lift)++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 ctx w os f c m. (ContextHandler ctx, ColorSampleable c, MonadIO m) => Format c -> Size1 -> MaxLevels -> ContextT ctx os m (Texture1D os (Format c))+newTexture1DArray :: forall ctx w os f c m. (ContextHandler ctx, ColorSampleable c, MonadIO m) => Format c -> Size2 -> MaxLevels -> ContextT ctx os m (Texture1DArray os (Format c))+newTexture2D :: forall ctx w os f c m. (ContextHandler ctx, TextureFormat c, MonadIO m) => Format c -> Size2 -> MaxLevels -> ContextT ctx os m (Texture2D os (Format c))+newTexture2DArray :: forall ctx w os f c m. (ContextHandler ctx, ColorSampleable c, MonadIO m) => Format c -> Size3 -> MaxLevels -> ContextT ctx os m (Texture2DArray os (Format c))+newTexture3D :: forall ctx w os f c m. (ContextHandler ctx, ColorRenderable c, MonadIO m) => Format c -> Size3 -> MaxLevels -> ContextT ctx os m (Texture3D os (Format c))+newTextureCube :: forall ctx w os f c m. (ContextHandler ctx, ColorSampleable c, MonadIO m) => Format c -> Size1 -> MaxLevels -> ContextT ctx os 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 than 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+                            liftNonWinContextAsyncIO $ 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 than 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+                                liftNonWinContextAsyncIO $ 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 than maximum supported by graphics driver"+                                  else do+                                    t <- makeRenderBuff+                                    liftNonWinContextAsyncIO $+                                       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 than 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+                                    liftNonWinContextAsyncIO $ 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 than 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+                        liftNonWinContextAsyncIO $ 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 than 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+                        liftNonWinContextAsyncIO $ 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 than 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+                            liftNonWinContextAsyncIO $ 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 :: (ContextHandler ctx, MonadIO m) =>  GLenum -> ContextT ctx os m Int+getGlValue enum = liftNonWinContextIO $ alloca (\ptr -> fmap 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 :: (ContextHandler ctx, MonadIO m) => ContextT ctx os m TexName+makeTex = do+    name <- liftNonWinContextIO $ alloca (\ptr -> glGenTextures 1 ptr >> peek ptr)+    tex <- liftIO $ newIORef name+    addContextFinalizer tex $ with name (glDeleteTextures 1)+    addFBOTextureFinalizer False tex+    return tex++makeRenderBuff :: (ContextHandler ctx, MonadIO m) => ContextT ctx os m TexName+makeRenderBuff = do+    name <- liftNonWinContextIO $ 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 Int+useTex texNameRef t bind = do glActiveTexture (GL_TEXTURE0 + fromIntegral bind)+                              n <- readIORef texNameRef+                              glBindTexture t n+                              return (fromIntegral 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+                     void $ 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 ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTexture1DArray :: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTexture2D      :: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTexture2DArray :: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTexture3D      :: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTextureCube    :: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()++writeTexture1DFromBuffer     :: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTexture1DArrayFromBuffer:: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTexture2DFromBuffer     :: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTexture2DArrayFromBuffer:: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTexture3DFromBuffer     :: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+writeTextureCubeFromBuffer   :: forall ctx b c h w os f m. (ContextHandler ctx, 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 ctx os m ()+++readTexture1D      :: forall ctx a b c h w os f m. (ContextHandler ctx, 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 ctx os m a) -> a -> ContextT ctx os m a+readTexture1DArray :: forall ctx a b c h w os f m. (ContextHandler ctx, 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 ctx os m a) -> a -> ContextT ctx os m a+readTexture2D      :: forall ctx a b c h w os f m. (ContextHandler ctx, 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 ctx os m a) -> a -> ContextT ctx os m a+readTexture2DArray :: forall ctx a b c h w os f m. (ContextHandler ctx, 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 ctx os m a) -> a -> ContextT ctx os m a+readTexture3D      :: forall ctx a b c h w os f m. (ContextHandler ctx, 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 ctx os m a) -> a -> ContextT ctx os m a+readTextureCube    :: forall ctx a b c h w os f m. (ContextHandler ctx, 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 ctx os m a) -> a -> ContextT ctx os m a++readTexture1DToBuffer     :: forall ctx b c w os f m. (ContextHandler ctx, 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 ctx os m ()+readTexture1DArrayToBuffer:: forall ctx b c w os f m. (ContextHandler ctx, 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 ctx os m ()+readTexture2DToBuffer     :: forall ctx b c w os f m. (ContextHandler ctx, 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 ctx os m ()+readTexture2DArrayToBuffer:: forall ctx b c w os f m. (ContextHandler ctx, 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 ctx os m ()+readTexture3DToBuffer     :: forall ctx b c w os f m. (ContextHandler ctx, 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 ctx os m ()+readTextureCubeToBuffer   :: forall ctx b c w os f m. (ContextHandler ctx, 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 ctx os 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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+                   (liftNonWinContextIO $ 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+                   (liftNonWinContextIO $ 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+                   (liftNonWinContextIO $ 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+                   (liftNonWinContextIO $ 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+                   (liftNonWinContextIO $ 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+                   (liftNonWinContextIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 = liftNonWinContextAsyncIO $ 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 :: (ContextHandler ctx, MonadIO m) => Texture1D os f -> ContextT ctx os m ()+generateTexture1DArrayMipmap :: (ContextHandler ctx, MonadIO m) => Texture1DArray os f -> ContextT ctx os m ()+generateTexture2DMipmap :: (ContextHandler ctx, MonadIO m) => Texture2D os f -> ContextT ctx os m ()+generateTexture2DArrayMipmap :: (ContextHandler ctx, MonadIO m) => Texture2DArray os f -> ContextT ctx os m ()+generateTexture3DMipmap :: (ContextHandler ctx, MonadIO m) => Texture3D os f -> ContextT ctx os m ()+generateTextureCubeMipmap :: (ContextHandler ctx, MonadIO m) => TextureCube os f -> ContextT ctx os m ()++genMips texn target = liftNonWinContextAsyncIO $ 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 s c. ColorSampleable c => (s -> (Texture1D os (Format c), SamplerFilter c, (EdgeMode,  BorderColor c))) -> Shader os s (Sampler1D (Format c))+newSampler1DArray :: forall os s c. ColorSampleable c => (s -> (Texture1DArray os (Format c), SamplerFilter c, (EdgeMode, BorderColor c))) -> Shader os s (Sampler1DArray (Format c))+newSampler2D :: forall os s c. ColorSampleable c => (s -> (Texture2D os (Format c), SamplerFilter c, (EdgeMode2, BorderColor c))) -> Shader os s (Sampler2D (Format c))+newSampler2DArray :: forall os s c. ColorSampleable c => (s -> (Texture2DArray os (Format c), SamplerFilter c, (EdgeMode2, BorderColor c))) -> Shader os s (Sampler2DArray (Format c))+newSampler3D :: forall os s c. ColorRenderable c => (s -> (Texture3D os (Format c), SamplerFilter c, (EdgeMode3, BorderColor c))) -> Shader os s (Sampler3D (Format c))+newSamplerCube :: forall os s c. ColorSampleable c => (s -> (TextureCube os (Format c), SamplerFilter c)) -> Shader os s (SamplerCube (Format c))++newSampler1DShadow :: forall os s d. DepthRenderable d => (s -> (Texture1D os (Format d), SamplerFilter d, (EdgeMode, BorderColor d), ComparisonFunction)) -> Shader os s (Sampler1D Shadow)+newSampler1DArrayShadow :: forall os s d. DepthRenderable d => (s -> (Texture1DArray os (Format d), SamplerFilter d, (EdgeMode, BorderColor d), ComparisonFunction)) -> Shader os s (Sampler1DArray Shadow)+newSampler2DShadow :: forall os s d. DepthRenderable d => (s -> (Texture2D os d, SamplerFilter (Format d), (EdgeMode2, BorderColor d), ComparisonFunction)) -> Shader os s (Sampler2D Shadow)+newSampler2DArrayShadow :: forall os s d. DepthRenderable d => (s -> (Texture2DArray os (Format d), SamplerFilter d, (EdgeMode2, BorderColor d), ComparisonFunction)) -> Shader os s (Sampler2DArray Shadow)+newSamplerCubeShadow :: forall os s d. DepthRenderable d => (s -> (TextureCube os (Format d), SamplerFilter d, ComparisonFunction)) -> Shader os s (SamplerCube Shadow)++newSampler1D sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (Texture1D tn _ _, filt, (ex, ec)) = sf s+                                                    in  do n <- 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 n+                   return $ Sampler1D sampId False (samplerPrefix (undefined :: c))+newSampler1DArray sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (Texture1DArray tn _ _, filt, (ex, ec)) = sf s+                                                    in  do n <- 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 n+                   return $ Sampler1DArray sampId False (samplerPrefix (undefined :: c))+newSampler2D sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (Texture2D tn _ _, filt, (V2 ex ey, ec)) = sf s+                                                    in  do n <- 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 n+                   return $ Sampler2D sampId False (samplerPrefix (undefined :: c))+newSampler2DArray sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (Texture2DArray tn _ _, filt, (V2 ex ey, ec)) = sf s+                                                    in  do n <- 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 n+                   return $ Sampler2DArray sampId False (samplerPrefix (undefined :: c))+newSampler3D sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (Texture3D tn _ _, filt, (V3 ex ey ez, ec)) = sf s+                                                    in  do n <- 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 n+                   return $ Sampler3D sampId False (samplerPrefix (undefined :: c))+newSamplerCube sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (TextureCube tn _ _, filt) = sf s+                                                    in  do n <- useTex tn GL_TEXTURE_CUBE_MAP bind+                                                           setNoShadowMode GL_TEXTURE_CUBE_MAP+                                                           setSamplerFilter GL_TEXTURE_CUBE_MAP filt+                                                           return n+                   return $ SamplerCube sampId False (samplerPrefix (undefined :: c))+++newSampler1DShadow sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (Texture1D tn _ _, filt, (ex, ec), cf) = sf s+                                                    in  do n <- 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 n+                   return $ Sampler1D sampId True ""+newSampler1DArrayShadow sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (Texture1DArray tn _ _, filt, (ex, ec), cf) = sf s+                                                    in  do n <- 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 n+                   return $ Sampler1DArray sampId True ""+newSampler2DShadow sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (Texture2D tn _ _, filt, (V2 ex ey, ec), cf) = sf s+                                                    in  do n <- 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 n+                   return $ Sampler2D sampId True ""+newSampler2DArrayShadow sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (Texture2DArray tn _ _, filt, (V2 ex ey, ec), cf) = sf s+                                                    in  do n <- 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 n+                   return $ Sampler2DArray sampId True ""+newSamplerCubeShadow sf = Shader $ do+                   sampId <- getNewName+                   doForSampler sampId $ \s bind -> let (TextureCube tn _ _, filt, cf) = sf s+                                                    in  do n <- useTex tn GL_TEXTURE_CUBE_MAP bind+                                                           setShadowFunc GL_TEXTURE_CUBE_MAP cf+                                                           setSamplerFilter GL_TEXTURE_CUBE_MAP filt+                                                           return n+                   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 Int) -> 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 $ "texelFetch" ++ 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 (Image f)+getTexture1DArrayImage :: Texture1DArray os f -> Level -> Int -> Render os (Image f)+getTexture2DImage :: Texture2D os f -> Level -> Render os (Image f)+getTexture2DArrayImage :: Texture2DArray os f -> Level -> Int -> Render os (Image f)+getTexture3DImage :: Texture3D os f -> Level -> Int -> Render os (Image f)+getTextureCubeImage :: TextureCube os f -> Level -> CubeSide -> Render os (Image f)+getLayeredTextureImage :: Texture3D os f -> MaxLevels -> Render os (Image f)++registerRenderWriteTextureName tn = Render (lift $ lift $ lift $ readIORef tn) >>= registerRenderWriteTexture . fromIntegral++getTexture1DImage t@(Texture1D tn _ ls) l' =+    let l = min ls l'+    in do+        registerRenderWriteTextureName tn+        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 do+        registerRenderWriteTextureName tn+        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 do+        registerRenderWriteTextureName tn+        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 do+        registerRenderWriteTextureName tn+        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 do+        registerRenderWriteTextureName tn+        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 do+        registerRenderWriteTextureName tn+        return $ Image tn (fromIntegral s') l (V2 x x) $ \attP -> do+            n <- readIORef tn+            glFramebufferTexture2D GL_DRAW_FRAMEBUFFER attP s' n (fromIntegral l)++-- Experimental. Meant to be used with a geometry shader and emitVertex(PositionAnd)Layer.+getLayeredTextureImage t@(Texture3D tn _ ls) l' =+    let l = min ls l'+        V3 x y _ = texture3DSizes t !! l+    in  do+        registerRenderWriteTextureName tn+        return $ Image tn 0 l (V2 x y) $ \attP -> do+            n <- readIORef tn+            glFramebufferTexture GL_DRAW_FRAMEBUFFER attP 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
+ src/Graphics/GPipe/Internal/TransformFeedback.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, Arrows, GeneralizedNewtypeDeriving, GADTs, MultiParamTypeClasses, FlexibleContexts #-}++module Graphics.GPipe.Internal.TransformFeedback where++import Graphics.GPipe.Internal.Compiler+import Graphics.GPipe.Internal.Context+import Graphics.GPipe.Internal.Expr+import Graphics.GPipe.Internal.GeometryStream+import Graphics.GPipe.Internal.PrimitiveStream+import Graphics.GPipe.Internal.PrimitiveArray+import Graphics.GPipe.Internal.Buffer+import Graphics.GPipe.Internal.Shader+import Graphics.GPipe.Internal.Debug++import Graphics.GL.Core45+import Graphics.GL.Types++import Data.IORef+import Data.IntMap.Lazy (insert)+import Foreign.C.String+import Foreign.Marshal+import Foreign.Storable+import Control.Monad.Trans.State++drawNothing :: forall p a s c ds os f. (PrimitiveTopology p, VertexInput a, GeometryExplosive (VertexFormat a))+    => Window os c ds+    -- Output feedback buffers should remain black boxes until synchronized+    -- which won't be necessary when using glDrawTransformFeedback (add a flag+    -- for it?).+    -> (s -> Buffer os a)+    -- maxVertices+    -> Int+    -- We should use a primitive (vertex) stream too, but the way we deal+    -- currently with modular stages is not flexible enough and we stick with+    -- geometry stream.+    -> GeometryStream (GGenerativeGeometry p (VertexFormat a))+    -> Shader os s ()+drawNothing w getTransformFeedbackBuffer maxVertices gs = Shader $ tellDrawcalls w gs getTransformFeedbackBuffer maxVertices++tellDrawcalls :: forall p a s c ds os. (PrimitiveTopology p, VertexInput a, GeometryExplosive (VertexFormat a))+    => Window os c ds+    -> GeometryStream (GGenerativeGeometry p (VertexFormat a))+    -> (s -> Buffer os a)+    -> Int+    -> ShaderM s ()+tellDrawcalls w (GeometryStream xs) getTransformFeedbackBuffer maxVertices =  mapM_ f xs where+    f (x, gsd@(GeometryStreamData n layoutName _)) = do++        let shaderDeclarations = (evalState (declareGeometry (undefined :: VertexFormat a)) 0)+            varyings = evalState (enumerateVaryings (undefined :: VertexFormat a)) 0+            varyingCount = length varyings+            bufferMode = GL_INTERLEAVED_ATTRIBS+            io s pName = do+                names <- mapM newCString varyings+                withArray names $ \a -> do+                    glTransformFeedbackVaryings pName (fromIntegral varyingCount) a bufferMode+                mapM_ free names+            topology = toGeometryShaderOutputTopology (undefined :: p)++        tellDrawcall $ makeDrawcall w getTransformFeedbackBuffer topology gsd shaderDeclarations $ do+            declareGeometryLayout layoutName (toLayoutOut (undefined :: p)) maxVertices+            x' <- unS x+            return ()++        modifyRenderIO (\s -> s { transformFeedbackToRenderIO = insert n io (transformFeedbackToRenderIO s) } )++makeDrawcall :: forall a s c ds os. (VertexInput a)+    => Window os c ds+    -> (s -> Buffer os a)+    -> GLuint+    -> GeometryStreamData+    -> GlobDeclM ()+    -> ExprM ()+    -> IO (Drawcall s)+makeDrawcall w getTransformFeedbackBuffer topology (GeometryStreamData geoN _ (PrimitiveStreamData primN ubuff)) shaderDeclarations shader = do+    ExprResult gsource gunis gsamps _ prevShaderDeclarations prevShader <- runExprM shaderDeclarations shader+    ExprResult vsource vunis vsamps vinps _ _ <- runExprM prevShaderDeclarations prevShader++    let getTransformFeedbackBufferName = \s -> do+            let buffer = getTransformFeedbackBuffer s+            bName <- readIORef (bufName buffer)+            let tfRef = bufTransformFeedback buffer+            tf <- readIORef tfRef+            (tfName, tfqName) <- case tf of+                Just names -> return names+                Nothing -> do+                    tfName <- alloca $ \ptr -> do+                        glGenTransformFeedbacks 1 ptr+                        peek ptr+                    tfqName <- alloca $ \ptr -> do+                        glGenQueries 1 ptr+                        peek ptr+                    writeIORef tfRef (Just (tfName, tfqName))+                    --liftNonWinContextIO $ (addContextFinalizer tfRef $ with name (glDeleteTransformFeedbacks 1))+                    return (tfName, tfqName)+            return (bName, tfName, tfqName, topology)++    return $ Drawcall+        (const (Left (getWinName w), return ()))+        (Just getTransformFeedbackBufferName)+        primN+        (Just geoN)+        vsource (Just gsource) Nothing+        vinps+        vunis vsamps+        gunis gsamps+        [] []+        ubuff
+ src/Graphics/GPipe/Internal/Uniform.hs view
@@ -0,0 +1,232 @@+{-# 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.Core45+import Data.IORef+import Data.Int+import Linear.V4+import Linear.V3+import Linear.V2+import Linear.V1+import Linear.V0+import Linear.Plucker (Plucker(..))+import Linear.Quaternion (Quaternion(..))++-- | 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. UBO are obviously used here and there is no way to use "classic"+-- uniform.+getUniform :: forall os s b x. (UniformInput b) => (s -> (Buffer os (Uniform b), Int)) -> Shader os s (UniformFormat b x)+getUniform sf = Shader $ do+    uniAl <- askUniformAlignment+    blockId <- getNewName+    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+        V2 a' b' <- toUniform -< V2 a 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+        V3 a' b' c' <- toUniform -< V3 a b c+        d' <- toUniform -< d+        returnA -< V4 a' b' c' d'++instance UniformInput () where+    type UniformFormat () x = ()+    toUniform = arr (const ())++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', b') <- toUniform -< (a, 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', b', c') <- toUniform -< (a, b, c)+        d' <- toUniform -< d+        returnA -< (a', b', c', d')++instance (UniformInput a, UniformInput b, UniformInput c, UniformInput d, UniformInput e) => UniformInput (a,b,c,d,e) where+    type UniformFormat (a,b,c,d,e) x = (UniformFormat a x, UniformFormat b x, UniformFormat c x, UniformFormat d x, UniformFormat e x)+    toUniform = proc ~(a,b,c,d,e) -> do+        (a',b',c',d') <- toUniform -< (a,b,c,d)+        e' <- toUniform -< e+        returnA -< (a', b', c', d', e')++instance (UniformInput a, UniformInput b, UniformInput c, UniformInput d, UniformInput e, UniformInput f) => UniformInput (a,b,c,d,e,f) where+    type UniformFormat (a,b,c,d,e,f) x = (UniformFormat a x, UniformFormat b x, UniformFormat c x, UniformFormat d x, UniformFormat e x, UniformFormat f x)+    toUniform = proc ~(a,b,c,d,e,f) -> do+        (a',b',c',d',e') <- toUniform -< (a,b,c,d,e)+        f' <- toUniform -< f+        returnA -< (a', b', c', d', e', f')++instance (UniformInput a, UniformInput b, UniformInput c, UniformInput d, UniformInput e, UniformInput f, UniformInput g) => UniformInput (a,b,c,d,e,f,g) where+    type UniformFormat (a,b,c,d,e,f,g) x = (UniformFormat a x, UniformFormat b x, UniformFormat c x, UniformFormat d x, UniformFormat e x, UniformFormat f x, UniformFormat g x)+    toUniform = proc ~(a,b,c,d,e,f,g) -> do+        (a',b',c',d',e',f') <- toUniform -< (a,b,c,d,e,f)+        g' <- toUniform -< g+        returnA -< (a', b', c', d', e', f', g')++instance UniformInput a => UniformInput (Quaternion a) where+    type UniformFormat (Quaternion a) x = Quaternion (UniformFormat a x)+    toUniform = proc ~(Quaternion a v) -> do+        (a',v') <- toUniform -< (a,v)+        returnA -< Quaternion a' v'++instance UniformInput a => UniformInput (Plucker a) where+    type UniformFormat (Plucker a) x = Plucker (UniformFormat a x)+    toUniform = proc ~(Plucker a b c d e f) -> do+        (a',b',c',d',e',f') <- toUniform -< (a,b,c,d,e,f)+        returnA -< Plucker a' b' c' d' e' f'
+ src/Graphics/GPipe/Linear.hs view
@@ -0,0 +1,7 @@+module Graphics.GPipe.Linear+    ( module Graphics.GPipe.Internal.Linear+    , module Linear+    ) where++import           Graphics.GPipe.Internal.Linear+import           Linear                         hiding (lookAt)
+ src/Graphics/GPipe/Orphans.hs view
@@ -0,0 +1,18 @@+-----------------------------------------------------------------------------+--+-- Module      :  Graphics.GPipe.Orphans+-- Copyright   :  Tobias Bexelius+-- License     :  MIT+--+-- Maintainer  :  Tobias Bexelius+-- Stability   :  Experimental+-- Portability :  Portable+--+-- |+-- Orphan boolean instances for linear types. These are placed in a separate module so you can choose to not import them+-- (in that case, do not import the @Graphics.GPipe@ conveniance module but take all sub modules instead, leaving this one out). +-----------------------------------------------------------------------------++module Graphics.GPipe.Orphans where++import Graphics.GPipe.Internal.Orphans
+ src/Graphics/GPipe/PrimitiveArray.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+--+-- 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(..),+    Points(..),+    Lines(..),+    LinesWithAdjacency(..),+    Triangles(..),+    TrianglesWithAdjacency(..),+    Geometry(..),+    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
+ src/Graphics/GPipe/PrimitiveStream.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------+--+-- 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,+    toPrimitiveStream',++    -- * Various PrimitiveStream operations+    withInputIndices,+    InputIndices(..),+    withPointSize,+    PointSize+)+where++import Graphics.GPipe.Internal.PrimitiveStream
+ src/Graphics/GPipe/Sampler.hs view
@@ -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+
+ src/Graphics/GPipe/Shader.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+--+-- 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,+    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
+ src/Graphics/GPipe/Texture.hs view
@@ -0,0 +1,104 @@+-----------------------------------------------------------------------------+--+-- 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
+ src/Graphics/GPipe/TransformFeedback.hs view
@@ -0,0 +1,6 @@+module Graphics.GPipe.TransformFeedback (+    drawNothing+)+where++import Graphics.GPipe.Internal.TransformFeedback
+ src/Graphics/GPipe/Uniform.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+--+-- Module      :  Graphics.GPipe.Uniform+-- Copyright   :  Tobias Bexelius+-- License     :  MIT+--+-- Maintainer  :  Tobias Bexelius+-- Stability   :  Experimental+-- Portability :  Portable+--+-- |+-- Uniform values are constants that you can combine with all vertices or fragments of a 'PrimitiveStream' or 'FragmentStream'.+-- They are loaded from a 'Buffer' and OpenGl uniform blocks are used under the hood.  +-----------------------------------------------------------------------------++module Graphics.GPipe.Uniform (+    UniformInput(..),+    ToUniform(),+    getUniform,   +    Uniform(..), +)+where++import Graphics.GPipe.Internal.Uniform+import Graphics.GPipe.Internal.Buffer
+ test/Graphics/GPipe/ExprSpec.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE OverloadedStrings #-}+module Graphics.GPipe.ExprSpec where++import           Test.Hspec                   (Spec, describe, it, shouldBe)++import qualified Data.Text                    as T+import           Graphics.GPipe               (V4 (..), identity, ifB, norm,+                                               (==*))+import           Graphics.GPipe.Internal.Expr+import           Graphics.GPipe.Linear        ((!*))++wrap :: FFloat -> IO ExprResult+wrap expr = runExprM (tellGlobal "") $ unS expr >>= tellAssignment' "result"+++golden :: String -> IO ()+golden = mapM_ (\l -> putStrLn $ "                , " ++ show l) . lines+++spec :: Spec+spec = do+    describe "(+)" $ do+        it "should be able to add two numbers" $ do+            let a = 1+                b = 2+                c = a + b+            res <- wrap c+            finalSource res `shouldBe` unlines+                [ "#version 450"+                , "void main() {"+                , "float t0 = (1+2);"+                , "result = t0;"+                , "}"+                ]++        it "should be able to add many numbers" $ do+            let (a, b, c, d) = (1, 2, 3, 4)+                result = a + b + c + d+            res <- wrap result+            finalSource res `shouldBe` unlines+                [ "#version 450"+                , "void main() {"+                , "float t0 = (1+2);"+                , "float t1 = (t0+3);"+                , "float t2 = (t1+4);"+                , "result = t2;"+                , "}"+                ]++        it "should reuse already computed values" $ do+            let (a, b, c, d) = (1, 2, 3, 4)+                e = a + b + c + d+                result = e + e+            res <- wrap result+            finalSource res `shouldBe` unlines+                [ "#version 450"+                , "void main() {"+                , "float t0 = (1+2);"+                , "float t1 = (t0+3);"+                , "float t2 = (t1+4);"+                , "float t3 = (t2+t2);"+                , "result = t3;"+                , "}"+                ]+++    describe "ifB" $ do+        it "should produce 4 separate 'if's for V4 branch values" $ do+            let a = V4 1 2 3 4+                b = V4 5 6 7 8+                c = a ==* b+                result = norm (ifB c a b)+            res <- wrap result+            finalSource res `shouldBe` unlines+                [ "#version 450"+                , "void main() {"+                , "bool t0 = (1==5);"+                , "bool t1 = (2==6);"+                , "bool t2 = (3==7);"+                , "bool t3 = (4==8);"+                , "bool t4 = (t2&&t3);"+                , "bool t5 = (t1&&t4);"+                , "bool t6 = (t0&&t5);"+                , "float t7;"+                , "if(t6){"+                , "t7 = 1;"+                , "} else {"+                , "t7 = 5;"+                , "}"+                , "float t8;"+                , "if(t6){"+                , "t8 = 2;"+                , "} else {"+                , "t8 = 6;"+                , "}"+                , "float t9;"+                , "if(t6){"+                , "t9 = 3;"+                , "} else {"+                , "t9 = 7;"+                , "}"+                , "float t10;"+                , "if(t6){"+                , "t10 = 4;"+                , "} else {"+                , "t10 = 8;"+                , "}"+                , "float t11 = length(vec4(t7,t8,t9,t10));"+                , "result = t11;"+                , "}"+                ]+++    describe "ifThenElse'" $ do+        it "should produce only 2 'if's for V4 branch values" $ do+            let a = V4 1 2 3 4+                b = V4 5 6 7 8+                c = a ==* b+                result = norm $ ifThenElse' c a b+            res <- wrap result+            finalSource res `shouldBe` unlines+                [ "#version 450"+                , "void main() {"+                , "bool t0 = (1==5);"+                , "bool t1 = (2==6);"+                , "bool t2 = (3==7);"+                , "bool t3 = (4==8);"+                , "bool t4 = (t2&&t3);"+                , "bool t5 = (t1&&t4);"+                , "bool t6 = (t0&&t5);"+                , "float t7;"+                , "float t8;"+                , "float t9;"+                , "float t10;"+                , "if(t6){"+                , "t7 = 1;"+                , "t8 = 2;"+                , "t9 = 3;"+                , "t10 = 4;"+                , "} else {"+                , "t7 = 5;"+                , "t8 = 6;"+                , "t9 = 7;"+                , "t10 = 8;"+                , "}"+                , "float t11 = length(vec4(t7,t8,t9,t10));"+                , "result = t11;"+                , "}"+                ]+++    describe "!*" $ do+        it "should compile to GLSL multiplication operator '*'" $ do+            let m = identity+                v = V4 5 6 7 8+                result = norm $ m !* v+            res <- wrap result+            golden $ finalSource res+            finalSource res `shouldBe` unlines+                [ "#version 450"+                , "void main() {"+                , "vec4 t0 = (vec4(5,6,7,8)*mat4x4(vec4(1,0,0,0),vec4(0,1,0,0),vec4(0,0,1,0),vec4(0,0,0,1)));"+                , "float t1 = length(vec4(t0[0],t0[1],t0[2],t0[3]));"+                , "result = t1;"+                , "}"+                ]
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}