GPipe-Core 0.2.3.0 → 0.2.3.1

raw patch · 40 files changed

+1699/−1088 lines, 40 filesdep +criteriondep +unordered-containersdep −hashtablesdep ~basedep ~lensdep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: criterion, unordered-containers

Dependencies removed: hashtables

Dependency ranges changed: base, lens, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• GPipe-Core.cabal +28/−3
• bench/Graphics/GPipe/ExprBench.hs +49/−0
• bench/LambdaRay/Config.hs +53/−0
• bench/LambdaRay/Schwarzschild.hs +195/−0
• bench/bench.hs +10/−0
• src/Data/SNMap.hs +43/−44
• src/Graphics/GPipe/Buffer.hs +8/−15
• src/Graphics/GPipe/Context.hs +1/−1
• src/Graphics/GPipe/Expr.hs +1/−2
• src/Graphics/GPipe/Format.hs +2/−2
• src/Graphics/GPipe/FragmentStream.hs +1/−1
• src/Graphics/GPipe/FrameBuffer.hs +2/−2
• src/Graphics/GPipe/GeometryStream.hs +1/−1
• src/Graphics/GPipe/Internal/Buffer.hs +56/−48
• src/Graphics/GPipe/Internal/Compiler.hs +37/−39
• src/Graphics/GPipe/Internal/Context.hs +50/−36
• src/Graphics/GPipe/Internal/Debug.hs +6/−6
• src/Graphics/GPipe/Internal/Expr.hs +244/−208
• src/Graphics/GPipe/Internal/Format.hs +123/−120
• src/Graphics/GPipe/Internal/FragmentStream.hs +54/−34
• src/Graphics/GPipe/Internal/FrameBuffer.hs +117/−92
• src/Graphics/GPipe/Internal/GeometryStream.hs +157/−124
• src/Graphics/GPipe/Internal/Linear.hs +2/−1
• src/Graphics/GPipe/Internal/Orphans.hs +18/−16
• src/Graphics/GPipe/Internal/PrimitiveArray.hs +32/−22
• src/Graphics/GPipe/Internal/PrimitiveStream.hs +75/−46
• src/Graphics/GPipe/Internal/Shader.hs +33/−19
• src/Graphics/GPipe/Internal/Texture.hs +143/−96
• src/Graphics/GPipe/Internal/TransformFeedback.hs +39/−20
• src/Graphics/GPipe/Internal/Uniform.hs +52/−27
• src/Graphics/GPipe/Orphans.hs +2/−2
• src/Graphics/GPipe/PrimitiveArray.hs +12/−12
• src/Graphics/GPipe/PrimitiveStream.hs +1/−1
• src/Graphics/GPipe/Sampler.hs +16/−17
• src/Graphics/GPipe/Shader.hs +2/−2
• src/Graphics/GPipe/Texture.hs +22/−22
• src/Graphics/GPipe/TransformFeedback.hs +1/−1
• src/Graphics/GPipe/Uniform.hs +5/−5
• test/Graphics/GPipe/ExprSpec.hs +0/−1

@@ -1,3 +1,9 @@+### 0.2.3.1++- 10-18x performance improvement in the shader compiler. This should speed up+  your load times significantly if you have complex shaders. The shaders+  themselves won't be faster, though.+ ### 0.2.3.0  Pre-release for GPipe-Core.

@@ -1,5 +1,5 @@ name:           GPipe-Core-version:        0.2.3.0+version:        0.2.3.1 cabal-version:  >= 1.10 build-type:     Simple author:         Tobias Bexelius@@ -19,6 +19,11 @@ maintainer:     Pippijn van Steenhoven data-files:     CHANGELOG.md +source-repository head+  type:     git+  location: https://github.com/homectl/workspace+  subdir:   GPipe-Core+ library   hs-source-dirs: src   default-language: Haskell2010@@ -69,9 +74,10 @@     , 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+    , text                          >= 0.10 && < 1.3+    , unordered-containers          >= 0.2 && < 0.3  test-suite testsuite   default-language: Haskell2010@@ -82,6 +88,7 @@       Graphics.GPipe.ExprSpec   ghc-options:       -Wall+      -rtsopts       -threaded   build-tool-depends:       hspec-discover:hspec-discover@@ -90,4 +97,22 @@     , GPipe-Core     , hspec     , lens-    , text++benchmark bench+  default-language: Haskell2010+  hs-source-dirs:   bench+  type: exitcode-stdio-1.0+  main-is:          bench.hs+  other-modules:+      Graphics.GPipe.ExprBench+      LambdaRay.Config+      LambdaRay.Schwarzschild+  ghc-options:+      -Wall+      -rtsopts+      -threaded+  build-depends:+      base < 5+    , GPipe-Core+    , criterion+    , lens

@@ -0,0 +1,49 @@+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+module Graphics.GPipe.ExprBench (suite) where++import           Criterion.Main               (Benchmark, bench, bgroup, nfIO,+                                               whnfIO)++import           Graphics.GPipe.Internal.Expr+import           Graphics.GPipe.Linear        (V2 (..), norm)+import qualified LambdaRay.Config             as Config+import qualified LambdaRay.Schwarzschild      as Schwarzschild+import           System.Mem                   (performGC)+++benchRaytracer :: Int -> IO String+benchRaytracer iterations = do+    -- performGC+    let+        config = Config.defaultConfig{Config.iterations}+        rt = Config.defaultRuntimeConfig+        expr = norm $ Schwarzschild.frag config (V2 100 100) rt (V2 30 30)+    finalSource <$> runExprM (tellGlobal "") (unS expr >>= tellAssignment' "result")+++benchSum :: Int -> IO String+benchSum n = do+    performGC+    let expr :: FFloat+        expr = sum $ map fromIntegral [0..n]+    finalSource <$> runExprM (tellGlobal "") (unS expr >>= tellAssignment' "result")+++suite :: IO Benchmark+suite = return $ bgroup "Expr"+    [ bgroup "raytracer"+        [ bench  "50" $ whnfIO (benchRaytracer  50)+        , bench "100" $ whnfIO (benchRaytracer 100)+        , bench "150" $ whnfIO (benchRaytracer 150)+        , bench "200" $ whnfIO (benchRaytracer 200)+        , bench "250" $ whnfIO (benchRaytracer 250)+        ]+    , bgroup "sum [0..n]"+        [ bench "1000" $ nfIO (benchSum 1000)+        , bench "2000" $ nfIO (benchSum 2000)+        , bench "3000" $ nfIO (benchSum 3000)+        , bench "4000" $ nfIO (benchSum 4000)+        , bench "5000" $ nfIO (benchSum 5000)+        ]+    ]

@@ -0,0 +1,53 @@+module LambdaRay.Config where++import           Graphics.GPipe (V2, V3 (..))++data HorizonMode+    = HorizonGrid+    | HorizonBlack++data DiskMode a+    = DiskGrid+    | DiskSolid+    | DiskTexture (V2 a -> V3 a)++data SkyMode a+    = SkyBlack+    | SkyTexture (V2 a -> V3 a)++data DistortionMethod+    = MethodNone+    | MethodLeapFrog++data Config a = Config+    { horizonMode      :: HorizonMode+    , diskMode         :: DiskMode a+    , skyMode          :: SkyMode a+    , distortionMethod :: DistortionMethod+    , iterations       :: Int+    }++defaultConfig :: Fractional a => Config a+defaultConfig = Config+    { distortionMethod = MethodLeapFrog+    , horizonMode = HorizonBlack+    , diskMode = DiskSolid+    , skyMode = SkyBlack+    , iterations = 70+    }++data RuntimeConfig a = RuntimeConfig+    { stepsize   :: a+    , stepfactor :: a+    , time       :: a+    , cameraPos  :: V3 a+    }++defaultRuntimeConfig :: Fractional a => RuntimeConfig a+defaultRuntimeConfig = RuntimeConfig+    -- 0.4 is the maximum before you end up with lots of additional Einstein rings.+    { stepsize = 0.4+    , stepfactor = 1+    , time = 0+    , cameraPos = V3 0 1 (-20)+    }

@@ -0,0 +1,195 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+module LambdaRay.Schwarzschild (frag) where++import           Control.Lens     ((^.))+import           Graphics.GPipe   hiding (lookAt, normalize)+import           LambdaRay.Config+import           Prelude          hiding ((<*))+++aspectRatio :: Fractional a => V2 Int -> a+aspectRatio viewPort = fromRational $ toRational y / toRational x+  where V2 x y = viewPort+++sqrnorm :: (Metric f, Floating a) => f a -> a+sqrnorm vec = n * n+  where n = norm vec++clip :: (IfB a, OrdB a) => a -> a -> a -> a+clip lo hi x = maxB (minB x hi) lo++xorB :: Boolean b => b -> b -> b+xorB a b = a &&* notB b ||* b &&* notB a+++diskOuter, diskOuterSqr, diskInner, diskInnerSqr, diskWidth :: Fractional a => a+diskInner = 2.6+diskOuter = 14+diskWidth = fromRational (14 - 2.6)+diskInnerSqr = fromRational (2.6 * 2.6)+diskOuterSqr = fromIntegral (14 * 14 :: Int)+++viewMatrix :: Floating a => V3 a -> V3 (V3 a)+viewMatrix cameraPos = V3 leftVec nupVec frontVec+  where+    lookAt = V3 0 0 0+    upVec = V3 0.2 1 0++    frontVec = signorm (lookAt - cameraPos)+    leftVec = signorm (cross upVec frontVec)+    nupVec = cross frontVec leftVec+++data Context a = Context+    { ctxPoint       :: V3 a+    , ctxVelocity    :: V3 a+    , ctxStepsize    :: a+    , ctxObjectColor :: V3 a+    , ctxObjectAlpha :: a+    }++-- instance ShaderType (Context FFloat) x where+--     type ShaderBaseType (Context FFloat) = ShaderBaseType FFloat+--     toBase x ~Context{..} = (toBase x ctxI)+--     fromBase x b = undefined+++blendcolors :: Num a => V3 a -> a -> V3 a -> a -> V3 a+blendcolors ca aa cb ba = ca + cb ^* (ba * (1 - aa))++blendalpha :: Num a => a -> a -> a+blendalpha aa ba = aa + ba * (1 - aa)+++computeSkyColor :: Real' a => SkyMode a -> V3 a -> V3 a+computeSkyColor SkyBlack _ = V3 0 0 0+computeSkyColor (SkyTexture samp) velocity = skycolor+  where+    vphi = atan2' (velocity ^. _x) (velocity ^. _z)+    vtheta = atan2' (velocity ^. _y) (norm (velocity ^. _xz))++    u = mod'' (vphi+4.5)(2*pi) / (2*pi)+    v = (vtheta+pi/2)/pi++    skycolor = samp (V2 u v)+++computeDiskColor :: FFloat -> V3 FFloat -> V3 FFloat -> DiskMode FFloat -> (V3 FFloat, FFloat)+computeDiskColor time velocity newpoint = compute+  where+    -- actual collision point by intersection+    lambdaa = -(newpoint ^. _y / (velocity ^. _y))+    colpoint = newpoint + lambdaa *^ velocity+    colpointsqr = sqrnorm colpoint++    phi = atan2' (colpoint ^. _x) (newpoint ^. _z) + time / 30++    compute DiskSolid = (V3 0.5 0.5 0.5, 1)++    compute (DiskTexture samp) = (diskcolor, diskalpha)+      where+        u = ((phi + 2*pi) `mod''` 2*pi) / (2*pi)+        v = (sqrt colpointsqr - diskInner) / diskWidth++        diskcolor = samp (V2 u v)+        diskalpha = clip 0 1 (sqrnorm diskcolor / 3.0)++    compute DiskGrid = (diskcolor, 1)+      where+        diskcolor = ifThenElse' (phi `mod''` 0.52359 <* 0.261799)+            (V3 1 1 1)+            (V3 0 0 1)+++computeHorizonColor :: HorizonMode -> V3 FFloat -> FFloat -> V3 FFloat -> FFloat -> (V3 FFloat, FFloat)+computeHorizonColor HorizonBlack _ _ _ _ = (V3 0 0 0, 1)+computeHorizonColor HorizonGrid oldpoint oldpointsqr newpoint newpointsqr = (horizoncolor, 1)+  where+    lambdaa = 1 - (1 - oldpointsqr) / (newpointsqr - oldpointsqr)+    colpoint = lambdaa *^ newpoint + (1 - lambdaa) *^ oldpoint++    phi = atan2' (colpoint ^. _x) (newpoint ^. _z)+    theta = atan2' (colpoint ^. _y) (norm (newpoint ^. _xz))++    horizoncolor = ifThenElse' (((phi `mod''` 1.04719) <* 0.52359) `xorB` ((theta `mod''` 1.04719) <* 0.52359))+        (V3 1 0 0)+        (V3 0 0 0)+++computeVelocity :: Floating a => DistortionMethod -> a -> a -> a -> V3 a -> V3 a -> a -> (V3 a, a)+computeVelocity MethodNone stepsize _ _ velocity _ _ = (velocity, stepsize)+computeVelocity MethodLeapFrog stepsize stepfactor h2 velocity newpoint newpointsqr = (newvelocity, newstepsize)+  where+    accel = (-1.5) * h2 *^ newpoint ^/ (newpointsqr ** 2.5)+    newvelocity = velocity + accel ^* stepsize+    -- step = abs $ norm velocity - norm newvelocity+    newstepsize = stepsize * stepfactor+++iteration :: Config FFloat -> RuntimeConfig FFloat -> FFloat -> Context FFloat -> Context FFloat+iteration Config{distortionMethod,diskMode,horizonMode} RuntimeConfig{..} (h2 :: FFloat) ctx = nctx+  where+    oldpoint = ctxPoint ctx -- for intersections+    oldpointsqr = sqrnorm oldpoint++    newpoint = ctxPoint ctx + ctxVelocity ctx ^* ctxStepsize ctx+    newpointsqr = sqrnorm newpoint++    (newvelocity, newstepsize) =+      computeVelocity distortionMethod (ctxStepsize ctx) stepfactor h2 (ctxVelocity ctx) newpoint newpointsqr++    -- whether it just crossed the horizontal plane+    maskCrossing = (oldpoint ^. _y >* 0) `xorB` (newpoint ^. _y >* 0)+    -- whether it's close enough+    maskDistance = newpointsqr <* diskOuterSqr &&* newpointsqr >* diskInnerSqr++    diskMask = maskCrossing &&* maskDistance+    (diskcolor, diskalpha) = ifThenElse' diskMask (computeDiskColor time (ctxVelocity ctx) newpoint diskMode) (0, 0)++    -- event horizon+    horizonMask = newpointsqr <* 1 &&* oldpointsqr >* 1+    (horizoncolor, horizonalpha) = ifThenElse' horizonMask (computeHorizonColor horizonMode oldpoint oldpointsqr newpoint newpointsqr) (0, 0)++    c1 = blendcolors (ctxObjectColor ctx) (ctxObjectAlpha ctx) horizoncolor horizonalpha+    a1 = blendalpha (ctxObjectAlpha ctx) horizonalpha+    c2 = blendcolors c1 a1 diskcolor diskalpha+    a2 = blendalpha a1 diskalpha++    nctx = Context+      { ctxPoint = newpoint+      , ctxVelocity = newvelocity+      , ctxStepsize = newstepsize+      , ctxObjectColor = c2+      , ctxObjectAlpha = a2+      }+++frag :: Config FFloat -> V2 Int -> RuntimeConfig FFloat -> V2 FFloat -> V3 FFloat+frag cfg@Config{iterations} viewPort rt@RuntimeConfig{..} (V2 x y) = result+  where+    tanFov = 1.5++    pos = cameraPos + V3 0 0 (time / 3 `mod''` 21)+    -- pos = V3 0 2 (-15.0)++    view = signorm $ viewMatrix pos !* V3 (tanFov * (x - 0.5)) (tanFov * aspectRatio viewPort * (y - 0.5)) 1++    h2 = sqrnorm (cross pos view)++    Context{ctxVelocity, ctxObjectColor, ctxObjectAlpha} =+      foldr (const $ iteration cfg rt h2)+        Context { ctxPoint = pos+                , ctxVelocity = view+                , ctxStepsize = stepsize+                , ctxObjectColor = V3 0 0 0+                , ctxObjectAlpha = 0+                } [0..iterations]++    skycolor = computeSkyColor (skyMode cfg) ctxVelocity++    result = blendcolors ctxObjectColor ctxObjectAlpha skycolor 1

@@ -0,0 +1,10 @@+module Main (main) where++import           Criterion.Main              (defaultMain)++import qualified Graphics.GPipe.ExprBench  as ExprBench++main :: IO ()+main = defaultMain =<< sequence+    [ ExprBench.suite+    ]

@@ -1,67 +1,66 @@--- {-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.SNMap (-    -- SNMap,-    SNMapReaderT,-    runSNMapReaderT,-    -- newSNMap,-    -- memoize,    -    memoizeM,-    scopedM-)where+module Data.SNMap+    ( SNMapReaderT+    , runSNMapReaderT+    , 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+import           Control.Applicative              (Applicative)+import           Control.Monad.Exception          (MonadAsyncException,+                                                   MonadException)+import           Control.Monad.IO.Class           (MonadIO, liftIO)+import           Control.Monad.Trans.Class        (MonadTrans (..))+import           Control.Monad.Trans.State.Strict (StateT (StateT), evalStateT,+                                                   get, put)+import qualified Data.HashMap.Strict              as HT+import           System.Mem.StableName            (StableName, makeStableName)  {- 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)+newtype SNMap m a = SNMap { unSNMap :: HT.HashMap (StableName (m a)) a } -newSNMap :: IO (SNMap m a)-newSNMap = SNMap <$> HT.new+newSNMap :: SNMap m a+newSNMap = SNMap HT.empty  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+    => m (SNMap m a)        -- The "IO call" to retrieve our cache.+    -> (SNMap m a -> m ())  -- The "IO call" to store an updated cache.+    -> m a                  -- The "IO call" to execute and cache the result.+    -> m a                  -- The result being naturally also returned.+memoize getter putter m = do+    s <- liftIO $ makeStableName m+    x <- HT.lookup s . unSNMap <$> getter+    case x of+        Just a -> return a+        Nothing -> do+            a <- m+            -- Need to redo the getter action because of scopeM.+            getter >>= putter . SNMap . HT.insert s a . unSNMap+            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)+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 +runSNMapReaderT (SNMapReaderT m) = do+    let h = 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)+memoizeM = memoize (SNMapReaderT get) (SNMapReaderT . put)  -- | 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+scopedM m = do+    save <- SNMapReaderT get+    x <- m+    SNMapReaderT $ put save+    return x

@@ -47,18 +47,11 @@ ) where -import Graphics.GPipe.Internal.Buffer-    ( copyBuffer,-      newBuffer,-      writeBuffer,-      B,-      B2,-      B3,-      B4,-      BPacked,-      Buffer(bufferLength),-      BufferColor,-      BufferFormat(toBuffer, HostFormat),-      BufferStartPos,-      Normalized(..),-      ToBuffer )+import           Graphics.GPipe.Internal.Buffer (B, B2, B3, B4, BPacked,+                                                 Buffer (bufferLength),+                                                 BufferColor,+                                                 BufferFormat (HostFormat, toBuffer),+                                                 BufferStartPos,+                                                 Normalized (..), ToBuffer,+                                                 copyBuffer, newBuffer,+                                                 writeBuffer)

@@ -37,4 +37,4 @@ ) where -import Graphics.GPipe.Internal.Context+import           Graphics.GPipe.Internal.Context

@@ -44,5 +44,4 @@ ) where -import Data.Boolean-import Graphics.GPipe.Internal.Expr+import           Graphics.GPipe.Internal.Expr

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- -- Module      :  Graphics.GPipe.Format@@ -33,4 +33,4 @@ ) where -import Graphics.GPipe.Internal.Format+import           Graphics.GPipe.Internal.Format

@@ -37,4 +37,4 @@ ) where -import Graphics.GPipe.Internal.FragmentStream+import           Graphics.GPipe.Internal.FragmentStream

@@ -83,5 +83,5 @@ ) where -import Graphics.GPipe.Internal.Texture-import Graphics.GPipe.Internal.FrameBuffer+import           Graphics.GPipe.Internal.FrameBuffer+import           Graphics.GPipe.Internal.Texture

@@ -27,4 +27,4 @@ ) where -import Graphics.GPipe.Internal.GeometryStream+import           Graphics.GPipe.Internal.GeometryStream

@@ -1,6 +1,10 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE Arrows, TypeFamilies, ScopedTypeVariables,-  FlexibleContexts, FlexibleInstances , TypeSynonymInstances #-}+{-# LANGUAGE Arrows               #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE PatternSynonyms      #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeSynonymInstances #-}  module Graphics.GPipe.Internal.Buffer (@@ -19,35 +23,39 @@     bufSize, bufName, bufElementSize, bufferLength, bufBElement, bufTransformFeedback, bufferWriteInternal, makeBuffer, getUniformAlignment, UniformAlignment ) where -import Graphics.GPipe.Internal.Context+import           Graphics.GPipe.Internal.Context   (ContextHandler, ContextT,+                                                    addContextFinalizer,+                                                    addVAOBufferFinalizer,+                                                    liftNonWinContextAsyncIO,+                                                    liftNonWinContextIO) -import Graphics.GL.Core45-import Graphics.GL.Types-import Foreign.Marshal.Utils-import Foreign.Marshal.Alloc+import           Foreign.Marshal.Alloc             (alloca)+import           Foreign.Marshal.Utils             (with)+import           Graphics.GL.Core45+import           Graphics.GL.Types                 (GLenum, GLuint) -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(..))+import           Control.Arrow                     (Arrow (arr, first),+                                                    Kleisli (..), returnA)+import           Control.Category                  (Category (..))+import           Control.Monad                     (void)+import           Control.Monad.IO.Class            (MonadIO (..))+import           Control.Monad.Trans.Class         (lift)+import           Control.Monad.Trans.Reader        (Reader, ask, runReader)+import           Control.Monad.Trans.State.Strict  (StateT (runStateT), get,+                                                    put)+import           Control.Monad.Trans.Writer.Strict (WriterT (runWriterT), tell)+import           Data.IORef                        (IORef, newIORef, readIORef)+import           Data.Int                          (Int, Int16, Int32, Int8)+import           Data.Word                         (Word, Word16, Word32, Word8)+import           Foreign.Ptr                       (Ptr, castPtr, minusPtr,+                                                    nullPtr, plusPtr)+import           Foreign.Storable                  (Storable (peek, peekElemOff, poke, sizeOf))+import           Linear                            (Quaternion (..), V0 (..),+                                                    V1 (..), V2 (..), V3 (..),+                                                    V4 (..))+import           Linear.Affine                     (Point (..))+import           Linear.Plucker                    (Plucker (..))+import           Prelude                           hiding (id, (.))  -- | The class that constraints which types can live in a buffer. class BufferFormat f where@@ -68,12 +76,12 @@  -- | 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+    {   bufName              :: BufferName+    ,   bufElementSize       :: Int         -- | Retrieve the number of elements in a buffer.-    ,   bufferLength :: Int-    ,   bufBElement :: BInput -> b-    ,   bufWriter :: Ptr () -> HostFormat b -> IO ()+    ,   bufferLength         :: Int+    ,   bufBElement          :: BInput -> b+    ,   bufWriter            :: Ptr () -> HostFormat b -> IO ()     ,   bufTransformFeedback :: IORef (Maybe (GLuint, GLuint))     } @@ -89,7 +97,7 @@ type BufferStartPos = Int  data BInput = BInput-    {   bInSkipElems :: Int+    {   bInSkipElems   :: Int     ,   bInInstanceDiv :: Int     } @@ -111,12 +119,12 @@     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 AlignUniform AlignUnknown       = AlignUniform+            comb AlignUnknown AlignUniform       = AlignUniform             comb AlignUnknown AlignPackedIndices = AlignPackedIndices             comb AlignPackedIndices AlignUnknown = AlignPackedIndices-            comb AlignUnknown AlignUnknown = AlignUnknown-            comb _ _ = Align4+            comb AlignUnknown AlignUnknown       = AlignUnknown+            comb _ _                             = Align4  instance Arrow ToBuffer where     {-# INLINE arr #-}@@ -126,10 +134,10 @@  -- | 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+    {   bName        :: IORef GLuint+    ,   bOffset      :: Int+    ,   bStride      :: Int+    ,   bSkipElems   :: Int     ,   bInstanceDiv :: Int     } @@ -244,10 +252,10 @@     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+        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)

@@ -1,35 +1,35 @@-{-# LANGUAGE PatternGuards, PatternSynonyms #-}+{-# LANGUAGE PatternGuards   #-}+{-# LANGUAGE 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           Control.Monad                    (forM_, void, when)+import           Control.Monad.Exception          (MonadException)+import           Control.Monad.IO.Class           (MonadIO (..))+import           Control.Monad.Trans.Class        (MonadTrans (lift))+import           Control.Monad.Trans.Except       (throwE)+import           Control.Monad.Trans.Reader       (ask)+import           Control.Monad.Trans.State.Strict (evalState, get, put)+import           Data.IntMap                      ((!))+import qualified Data.IntMap                      as Map+import qualified Data.IntSet                      as Set+import           Data.Maybe                       (fromJust, isJust, isNothing)+import           Graphics.GPipe.Internal.Context -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+import           Control.Exception                (throwIO)+import           Data.Either                      (partitionEithers)+import           Data.IORef                       (IORef, mkWeakIORef, newIORef,+                                                   readIORef)+import           Data.List                        (zip5)+import           Data.Word                        (Word32)+import           Foreign.C.String                 (peekCString, withCString,+                                                   withCStringLen)+import           Foreign.Marshal.Alloc            (alloca)+import           Foreign.Marshal.Array            (allocaArray, withArray)+import           Foreign.Marshal.Utils            (with)+import           Foreign.Ptr                      (nullPtr)+import           Foreign.Storable                 (peek)+import           Graphics.GL.Core45+import           Graphics.GL.Types                (GLuint)  -- public type WinId = Int@@ -73,7 +73,7 @@     where         feedbackBuffer' = case feedbackBuffer dc of             Nothing -> Nothing-            Just b -> Just (b . f)+            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@@ -129,7 +129,7 @@ -- 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'+    let merge x x' = Map.union x $ Map.map (. f) x'     in  RenderIOState (merge a a') (merge b b') (merge c c') (merge d d') (merge e e')  -- | May throw a GPipeException@@ -291,8 +291,8 @@                 whenJust' ofShader $ glDetachShader pName                  glDeleteShader vShader-                whenJust' ogShader $ glDeleteShader-                whenJust' ofShader $ glDeleteShader+                whenJust' ogShader glDeleteShader+                whenJust' ofShader glDeleteShader                  case mPErr of                     Just errP -> do@@ -305,8 +305,8 @@                     Nothing -> return $ Right pName             else do                 glDeleteShader vShader-                whenJust' ogShader $ glDeleteShader-                whenJust' ofShader $ glDeleteShader+                whenJust' ogShader glDeleteShader+                whenJust' ofShader glDeleteShader                  let err = concat                         [ maybe "" (\e -> "A vertex shader compilation failed:\n" ++ e ++ "\nSource:\n" ++ vsource) mErrV@@ -383,9 +383,7 @@                                         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 ()+                            forM_ mErr throwE              -- Bind the framebuffer.             windowId <- case mFboKeyIO of@@ -529,7 +527,7 @@                         drawIO                         glDisable GL_RASTERIZER_DISCARD                         glEndTransformFeedback-                        glEndQuery(GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN);+                        glEndQuery GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN                         {-                         l <- alloca $ \ptr -> do                             glGetQueryObjectiv tfqName GL_QUERY_RESULT ptr

@@ -1,4 +1,10 @@-{-# LANGUAGE TypeFamilies, RankNTypes, GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, GADTs, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE TypeFamilies               #-}  module Graphics.GPipe.Internal.Context (@@ -30,27 +36,35 @@ ) 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+import           Control.Concurrent.MVar          (MVar, modifyMVar_,+                                                   newEmptyMVar, newMVar,+                                                   putMVar, readMVar, takeMVar)+import           Control.Exception                (throwIO)+import           Control.Monad                    (void)+import           Control.Monad.Exception          (Exception,+                                                   MonadAsyncException,+                                                   MonadException, bracket)+import qualified Control.Monad.Fail               as MF+import           Control.Monad.IO.Class           (MonadIO (..))+import           Control.Monad.Trans.Class        (MonadTrans (..))+import           Control.Monad.Trans.Except       (ExceptT (..), runExceptT)+import           Control.Monad.Trans.Reader       (ReaderT (..), ask, asks)+import           Control.Monad.Trans.State.Strict (StateT (runStateT),+                                                   evalStateT, get, gets,+                                                   modify, put)+import           Data.IORef                       (IORef, mkWeakIORef,+                                                   readIORef)+import           Data.IntMap                      ((!))+import qualified Data.IntMap.Strict               as IMap+import qualified Data.IntSet                      as Set+import qualified Data.Map.Strict                  as Map+import           Data.Maybe                       (maybeToList)+import           Data.Typeable                    (Typeable)+import           Graphics.GL.Core45+import           Graphics.GL.Types                (GLint, GLuint)+import           Graphics.GPipe.Internal.Format   (WindowBits, WindowFormat,+                                                   windowBits)+import           Linear.V2                        (V2 (..))  -- | Class implementing a window handler that can create openGL contexts, such as GLFW or GLUT class ContextHandler ctx where@@ -103,14 +117,14 @@     deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadAsyncException)  data ContextEnv ctx = ContextEnv {-    context :: ctx,+    context           :: ctx,     sharedContextData :: SharedContextDatas   }  data ContextState ctx = ContextState {-    nextName :: Name,+    nextName       :: Name,     perWindowState :: PerWindowState ctx,-    lastUsedWin :: Name -- -1 is no window. 0 is the hidden window. 1.. are visible windows+    lastUsedWin    :: Name -- -1 is no window. 0 is the hidden window. 1.. are visible windows   }  -- | A monad in which shaders are run.@@ -118,13 +132,13 @@  data RenderEnv = RenderEnv {     renderSharedContextData :: SharedContextDatas,-    nonWindowDoAsync :: ContextDoAsync+    nonWindowDoAsync        :: ContextDoAsync   }  data RenderState = RenderState {     perWindowRenderState :: PerWindowRenderState,-    renderWriteTextures :: Set.IntSet,-    renderLastUsedWin :: Name+    renderWriteTextures  :: Set.IntSet,+    renderLastUsedWin    :: Name   }  type Name = Int@@ -133,9 +147,9 @@  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-  }+newtype WindowState = WindowState+    { windowContextData :: ContextData+    }  -- | Run a 'Render' monad, that may have the effect of windows or textures being drawn to. --@@ -151,7 +165,7 @@     lift $ put $ cs { lastUsedWin = renderLastUsedWin rs}     case eError of       Left s -> liftIO $ throwIO $ GPipeException s-      _ -> return ()+      _      -> return ()  registerRenderWriteTexture :: Int -> Render os () registerRenderWriteTexture n = Render $ lift $ lift $ modify $ \ rs -> rs { renderWriteTextures = Set.insert n $ renderWriteTextures rs }@@ -176,7 +190,7 @@      )      (\ctx -> evalStateT (runReaderT m (ContextEnv ctx cds)) (ContextState 1 IMap.empty (-1))) -data Window os c ds = Window { getWinName :: Name }+newtype Window os c ds = Window { getWinName :: Name }  instance Eq (Window os c ds) where   (Window a) == (Window b) = a == b@@ -214,7 +228,7 @@     Just (ws, w) -> do       ContextEnv ctx cds <-  ask       let wmap' = IMap.delete wid wmap-      n' <- if (IMap.null 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@@ -301,8 +315,8 @@   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)+newtype GPipeException = GPipeException String+    deriving (Show, Typeable)  instance Exception GPipeException 

@@ -1,11 +1,11 @@ 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+import           Control.Monad      (when)+import           Data.List          (intercalate)+import           Data.Maybe         (fromMaybe)+import qualified Debug.Trace        as Trace+import           Graphics.GL.Core45+import           Graphics.GL.Types  (GLenum)  traceIt :: Show a => String -> a -> a traceIt t a = Trace.trace (t ++ " = " ++ show a) a

@@ -1,76 +1,108 @@-{-# LANGUAGE GADTs, EmptyDataDecls, NoMonomorphismRestriction, TypeFamilies, ScopedTypeVariables, FlexibleInstances, RankNTypes, MultiParamTypeClasses, FlexibleContexts, OverloadedStrings, ViewPatterns, RecordWildCards #-}+{-# LANGUAGE EmptyDataDecls            #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE ViewPatterns              #-}  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))+import           Control.Applicative               (liftA2, liftA3)+import           Control.Category                  (Category (id, (.)))+import           Control.Monad                     (void, when)+import qualified Control.Monad.Trans.Class         as T (lift)+import           Control.Monad.Trans.Reader        (ReaderT (runReaderT), ask)+import           Control.Monad.Trans.State.Strict  (State, StateT, evalState,+                                                    evalStateT, execStateT, get,+                                                    modify, modify', put,+                                                    runStateT)+import           Control.Monad.Trans.Writer.Strict (Writer,+                                                    WriterT (runWriterT),+                                                    execWriter, execWriterT,+                                                    tell)+import           Data.Bits                         (FiniteBits (finiteBitSize))+import           Data.Boolean                      (Boolean (..), BooleanOf,+                                                    EqB (..), IfB (..),+                                                    OrdB (..), maxB, minB)+import           Data.Foldable                     (Foldable (toList))+import           Data.Int                          (Int16, Int32, Int8)+import qualified Data.IntMap.Strict                as Map+import           Data.List                         (intercalate)+import           Data.Maybe                        (fromJust, isJust)+import           Data.Monoid                       (mconcat)+import           Data.SNMap                        (SNMapReaderT, memoizeM,+                                                    runSNMapReaderT, scopedM)+import           Data.Text.Lazy                    (Text)+import qualified Data.Text.Lazy                    as LT+import qualified Data.Text.Lazy.Builder            as LTB+import           Data.Word                         (Word16, Word32, Word8)+import           Linear.Affine                     (distanceA)+import           Linear.Conjugate                  (Conjugate, TrivialConjugate)+import           Linear.Matrix                     ((!*!), (!*), (*!))+import           Linear.Metric                     (Metric (distance, dot, norm, signorm))+import           Linear.V0                         (V0 (..))+import           Linear.V1                         (V1 (..))+import           Linear.V2                         (V2 (..))+import           Linear.V3                         (V3 (..), cross)+import           Linear.V4                         (V4 (..))+import           Linear.Vector                     (outer)+import           Prelude                           hiding (id, (.), (<*)) +tshow :: Show a => a -> Text+tshow = LT.pack . show+ type NextTempVar = Int type NextGlobal = Int -data SType = STypeFloat | STypeInt | STypeBool | STypeUInt | STypeDyn String | STypeMat Int Int | STypeVec Int | STypeIVec Int | STypeUVec Int | STypeGenerativeGeometry+data SType+    = STypeFloat+    | STypeInt+    | STypeBool+    | STypeUInt+    | STypeDyn Text+    | 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 :: SType -> Text+stypeName STypeFloat              = "float"+stypeName STypeInt                = "int"+stypeName STypeBool               = "bool"+stypeName STypeUInt               = "uint"+stypeName (STypeDyn s)            = s+stypeName (STypeMat r c)          = "mat" <> tshow c <> "x" <> tshow r+stypeName (STypeVec n)            = "vec" <> tshow n+stypeName (STypeIVec n)           = "ivec" <> tshow n+stypeName (STypeUVec n)           = "uvec" <> tshow 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 (STypeVec n)  = n * 4 stypeSize (STypeIVec n) = n * 4 stypeSize (STypeUVec n) = n * 4-stypeSize _ = 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.-            )-        )-    )+    [Text]                  -- Declared names (t*, vg*, vgf*).+    (StateT ExprState IO)   -- IO to create stable names. -type GlobDeclM = Writer String+type GlobDeclM = Writer Text  data ExprState = ExprState+    ShaderInputs -- Shader inputs, lazy because this is sometimes undefined.+    !NextTempVar -- Next unique variable name.+    !LTB.Builder -- Generated GLSL source code.++data ShaderInputs = ShaderInputs     {   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)@@ -112,7 +144,7 @@     -> 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+    ExprState st _ body <- execStateT (runSNMapReaderT m) (ExprState (ShaderInputs Map.empty Map.empty Map.empty Nothing) 0 mempty)     let (unis, uniDecls) = unzip $ Map.toAscList (shaderUsedUniformBlocks st)         (samps, sampDecls) = unzip $ Map.toAscList (shaderUsedSamplers st)         (inps, inpDescs) = unzip $ Map.toAscList (shaderUsedInput st)@@ -127,9 +159,9 @@             sequence_ inpDecls         finalSource = mconcat             [ "#version 450\n"-            , execWriter decls+            , LT.unpack $ execWriter decls             , "void main() {\n"-            , body+            , LT.unpack $ LTB.toLazyText body             , "}\n"             ]     return ExprResult{..}@@ -145,16 +177,16 @@         -- 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 ()+    ,   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.+    {   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.+    ,   prevExpression       :: ExprM () -- ^ The expression to evaluate in order to produce the previous shader.     }  evaluateExpression :: [ExprM ()] -> ExprM () -> GlobDeclM () -> IO ShaderStageOutput@@ -162,11 +194,11 @@     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+        []       -> return $ ShaderStageOutput s u ss is pds pe  -------------------------------------------------------------------------------- -newtype S x a = S { unS :: ExprM String }+newtype S x a = S { unS :: ExprM Text }  scalarS :: SType -> ExprM RValue -> S c a scalarS typ = S . tellAssignment typ@@ -182,7 +214,7 @@ vec4S :: SType -> ExprM RValue -> V4 (S c a) vec4S typ s =     let m = tellAssignment typ s-        f p = S $ fmap (++ p) m+        f p = S $ fmap (<> p) m     in  V4 (f ".x") (f ".y") (f ".z") (f ".w")  scalarS' :: RValue -> S c a@@ -205,7 +237,7 @@     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)+    let f p = S $ fmap (<> ("[" <> tshow (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@@ -230,93 +262,94 @@ type FWord = S F Word type FBool = S F Bool -useVInput :: SType -> Int -> ExprM String+useVInput :: SType -> Int -> ExprM Text useVInput stype i = do-    s <- T.lift get-    T.lift $ put $ s { shaderUsedInput = Map.insert i (gDeclInput, undefined) $ shaderUsedInput s }-    return $ "in" ++ show i+    ExprState s nvar body <- T.lift get+    T.lift $ put (ExprState s{ shaderUsedInput = Map.insert i (gDeclInput, undefined) $ shaderUsedInput s } nvar body)+    return $ "in" <> tshow i     where         gDeclInput = do             tellGlobal "in "             tellGlobal $ stypeName stype             tellGlobal " in"-            tellGlobalLn $ show i+            tellGlobalLn $ tshow i -useGInput :: String -> SType -> Int -> Int -> ExprM String -> ExprM String+useGInput :: Text -> SType -> Int -> Int -> ExprM Text -> ExprM Text 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 ++ "]"+    ExprState s nvar body <- T.lift get+    T.lift $ put (ExprState s{ shaderUsedInput = Map.insert n (gDeclIn, (assignOutput, gDeclOut)) $ shaderUsedInput s } nvar body)+    return $ prefix <> tshow n <> "[" <> tshow i <> "]"     where         prefix = "vg"          -- Output assignement in the previous shader         assignOutput = do             val <- v-            let name = prefix ++ show n+            let name = prefix <> tshow n             tellAssignment' name val          -- Output declaration in the previous shader.         gDeclOut = do-            tellGlobal $ qual ++ " out "+            tellGlobal $ qual <> " out "             tellGlobal $ stypeName stype-            tellGlobal $ ' ':prefix-            tellGlobalLn $ show n+            tellGlobal $ " " <> prefix+            tellGlobalLn $ tshow n          -- Input declaration in the current shader.         gDeclIn = do-            tellGlobal $ qual ++ " in "+            tellGlobal $ qual <> " in "             tellGlobal $ stypeName stype-            tellGlobal $ ' ':prefix-            tellGlobal $ show n-            tellGlobalLn $ "[]"+            tellGlobal $ " " <> prefix+            tellGlobal $ tshow n+            tellGlobalLn "[]" -useFInputFromG :: String -> SType -> Int -> ExprM String -> ExprM String+useFInputFromG :: Text -> SType -> Int -> ExprM Text -> ExprM Text 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+    ExprState s nvar body <- T.lift get+    val :: Int <- read . LT.unpack <$> v+    T.lift $ put (ExprState s{ shaderUsedInput = Map.insert i (gDecl val (qual <> " in "), (return (), gDecl val (qual <> " out "))) $ shaderUsedInput s } nvar body)+    return $ prefix <> tshow val     where         prefix = "vgf"          gDecl val s = do             tellGlobal s             tellGlobal $ stypeName stype-            tellGlobal $ ' ':prefix-            tellGlobalLn $ show val+            tellGlobal $ " " <> prefix+            tellGlobalLn $ tshow val -useFInput :: String -> String -> SType -> Int -> ExprM String -> ExprM String+useFInput :: Text -> Text -> SType -> Int -> ExprM Text -> ExprM Text 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+    ExprState s nvar body <- T.lift get+    T.lift $ put (ExprState s{ shaderUsedInput = Map.insert i (gDecl (qual <> " in "), (assignOutput, gDecl (qual <> " out "))) $ shaderUsedInput s } nvar body)+    return $ prefix <> tshow i     where         assignOutput = do             val <- v-            let name = prefix ++ show i+            let name = prefix <> tshow i             tellAssignment' name val          gDecl s = do             tellGlobal s             tellGlobal $ stypeName stype-            tellGlobal $ ' ':prefix-            tellGlobalLn $ show i+            tellGlobal $ " " <> prefix+            tellGlobalLn $ tshow i -declareGeometryLayout :: String -> String -> Int -> ExprM ()-declareGeometryLayout inputPrimitive outputPrimitive maxVertices = T.lift $ modify $ \ s -> s { shaderGeometry = Just gDeclBlock }+declareGeometryLayout :: Text -> Text -> Int -> ExprM ()+declareGeometryLayout inputPrimitive outputPrimitive maxVertices =+    T.lift $ modify $ \(ExprState s nvar body) -> ExprState s{ shaderGeometry = Just gDeclBlock } nvar body     where         gDeclBlock = do-            tellGlobalLn $ "layout(" ++ inputPrimitive ++ ") in"-            tellGlobalLn $ "layout(" ++ outputPrimitive ++ ", max_vertices = " ++ show maxVertices ++ ") out"+            tellGlobalLn $ "layout(" <> inputPrimitive <> ") in"+            tellGlobalLn $ "layout(" <> outputPrimitive <> ", max_vertices = " <> tshow maxVertices <> ") out" -useUniform :: GlobDeclM () -> Int -> Int -> ExprM String+useUniform :: GlobDeclM () -> Int -> Int -> ExprM Text 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"+    T.lift $ modify $ \(ExprState s nvar body) -> ExprState s{ shaderUsedUniformBlocks = Map.insert blockI gDeclUniformBlock $ shaderUsedUniformBlocks s } nvar body+    return $ "u" <> tshow blockI <> "." <> "u" <> tshow offset -- "u8.u4"     where         gDeclUniformBlock = do-            let blockStr = show blockI+            let blockStr = tshow blockI             tellGlobal "layout(std140) uniform uBlock"             tellGlobal blockStr             tellGlobal " {\n"@@ -324,10 +357,10 @@             tellGlobal "} u"             tellGlobalLn blockStr -useSampler :: String -> String -> Int -> ExprM String+useSampler :: Text -> Text -> Int -> ExprM Text useSampler prefix str name = do-    T.lift $ modify $ \ s -> s { shaderUsedSamplers = Map.insert name gDeclSampler $ shaderUsedSamplers s }-    return $ 's':show name+    T.lift $ modify $ \(ExprState s nvar body) -> ExprState s{ shaderUsedSamplers = Map.insert name gDeclSampler $ shaderUsedSamplers s } nvar body+    return $ "s" <> tshow name     where         gDeclSampler = do             tellGlobal "uniform "@@ -335,38 +368,41 @@             tellGlobal "sampler"             tellGlobal str             tellGlobal " s"-            tellGlobalLn $ show name+            tellGlobalLn $ tshow name -getNext :: Monad m => StateT Int m Int+getNext :: Monad m => StateT ExprState m Int getNext = do-    s <- get-    put $ s + 1-    return s+    ExprState s nvar body <- get+    put $ ExprState s (nvar + 1) body+    return nvar -type RValue = String+type RValue = Text -tellAssignment :: SType -> ExprM RValue -> ExprM String+tellAssignment :: SType -> ExprM RValue -> ExprM Text 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 ++ " ")+    var <- T.lift getNext+    let name = "t" <> tshow var+    T.lift $ tellST $ stypeName typ <> " "     tellAssignment' name val     return [name] -tellAssignment' :: String -> RValue -> ExprM ()-tellAssignment' name string = T.lift $ T.lift $ tell $ mconcat [name, " = ", string, ";\n"]+tellAssignment' :: Text -> RValue -> ExprM ()+tellAssignment' name string = T.lift $ tellST $ mconcat [name, " = ", string, ";\n"] +tellST :: Text -> StateT ExprState IO ()+tellST text = modify' $ \(ExprState s nvar body) -> ExprState s nvar (body <> LTB.fromLazyText text)+ discard :: FBool -> ExprM () discard (S m) = do     b <- m-    when (b /= "true") $ T.lift $ T.lift $ tell $ mconcat ["if (!(", b, ")) discard;\n"]+    when (b /= "true") $ T.lift $ tellST $ mconcat ["if (!(", b, ")) discard;\n"]  ---tellGlobalLn :: String -> GlobDeclM ()-tellGlobalLn string = tell $ string `mappend` ";\n"+tellGlobalLn :: Text -> GlobDeclM ()+tellGlobalLn string = tell $ string <> ";\n" ---tellGlobal :: String -> GlobDeclM ()+tellGlobal :: Text -> GlobDeclM () tellGlobal = tell  -----------------------@@ -381,9 +417,9 @@     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 :: ShaderBase a x -> WriterT [Text] ExprM (ShaderBase a x)+shaderbaseAssign :: ShaderBase a x -> StateT [Text] ExprM ()+shaderbaseReturn :: ShaderBase a x -> ReaderT (ExprM [Text]) (State ExprState) (ShaderBase a x)  shaderbaseDeclare (ShaderBaseFloat _) = ShaderBaseFloat <$> shaderbaseDeclareDef STypeFloat shaderbaseDeclare (ShaderBaseInt _) = ShaderBaseInt <$> shaderbaseDeclareDef STypeInt@@ -417,15 +453,15 @@     return $ ShaderBaseProd a' b' shaderbaseReturn (ShaderBaseGenerativeGeometry _) = ShaderBaseGenerativeGeometry <$> shaderbaseReturnDef -shaderbaseDeclareDef :: SType -> WriterT [String] ExprM (S x a)+shaderbaseDeclareDef :: SType -> WriterT [Text] 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"]+    var <- T.lift $ T.lift getNext+    let root = "t" <> tshow var+    T.lift $ T.lift $ tellST $ mconcat [stypeName styp, " " <> root, ";\n"]     tell [root]     return $ S $ return root -shaderbaseAssignDef :: (S x a) -> StateT [String] ExprM ()+shaderbaseAssignDef :: S x a -> StateT [Text] ExprM () shaderbaseAssignDef (S shaderM) = do     ul <- T.lift shaderM     xs <- get@@ -433,11 +469,10 @@     T.lift $ tellAssignment' (head xs) ul     return () -shaderbaseReturnDef :: ReaderT (ExprM [String]) (State Int) (S x a)+shaderbaseReturnDef :: ReaderT (ExprM [Text]) (State ExprState) (S x a) shaderbaseReturnDef = do     i <- T.lift getNext-    m <- ask-    return $ S $ fmap (!!i) m+    S . fmap (!!i) <$> ask  -- | 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.@@ -546,7 +581,7 @@             -> (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]+            let ifM :: ExprM [Text]                 ifM = memoizeM $ do                     boolStr <- unS bool                     (lifted, aDecls) <- runWriterT $ shaderbaseDeclare (toBase x (errShaderType :: a))@@ -554,11 +589,11 @@                     decls <- execWriterT $ shaderbaseDeclare (toBase x (errShaderType :: b))                     tellIf boolStr                     scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls-                    T.lift $ T.lift $ tell "} else {\n"+                    T.lift $ tellST "} else {\n"                     scopedM $ void $ evalStateT (shaderbaseAssign $ els lifted) decls-                    T.lift $ T.lift $ tell "}\n"+                    T.lift $ tellST "}\n"                     return decls-            in  evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: b))) ifM) 0+            in  evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: b))) ifM) (ExprState undefined 0 mempty)  -- | @ifThen c f x@ will return @f x@ if @c@ evaluates to 'true' or @x@ otherwise. --@@ -576,12 +611,12 @@                     void $ evalStateT (shaderbaseAssign a) decls                     tellIf boolStr                     scopedM $ void $ evalStateT (shaderbaseAssign $ thn lifted) decls-                    T.lift $ T.lift $ tell "}\n"+                    T.lift $ tellST "}\n"                     return decls-            in  evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: a))) ifM) 0+            in  evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: a))) ifM) (ExprState undefined 0 mempty)  tellIf :: RValue -> ExprM ()-tellIf boolStr = T.lift $ T.lift $ tell $ mconcat ["if(", boolStr, "){\n" ]+tellIf boolStr = T.lift $ tellST $ 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@@ -594,81 +629,82 @@                     (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" ]+                    T.lift $ tellST $ 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"+                    T.lift $ tellST "}\n"                     return decls-            in  evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: a))) whileM) 0+            in  evalState (runReaderT (shaderbaseReturn (toBase x (errShaderType :: a))) whileM) (ExprState undefined 0 mempty) +errShaderType :: a 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 :: SType -> Text -> 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' ++ ")"+                                                    return $ "(" <> a' <> o <> b' <> ")" -fun1 :: SType -> String -> S c x -> S c y+fun1 :: SType -> Text -> S c x -> S c y fun1 typ f (S a) = S $ tellAssignment typ $ do a' <- a-                                               return $ f ++ '(' : a' ++ ")"+                                               return $ f <> "(" <> a' <> ")" -fun2 :: SType -> String -> S c x -> S c y -> S c z+fun2 :: SType -> Text -> 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' ++ ")"+                                                     return $ f <> "(" <> a' <> "," <> b' <> ")" -fun3 :: SType -> String -> S c x -> S c y -> S c z -> S c w+fun3 :: SType -> Text -> 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' ++")"+                                                           return $ f <> "(" <> a' <> "," <> b' <> "," <> c' <>")" -fun4 :: SType -> String -> S c x -> S c y -> S c z -> S c w -> S c r+fun4 :: SType -> Text -> 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' ++")"+                                                                 return $ f <> "(" <> a' <> "," <> b' <> "," <> c' <> "," <> d' <>")" -postop :: SType -> String -> S c x -> S c y+postop :: SType -> Text -> S c x -> S c y postop typ f (S a) = S $ tellAssignment typ $ do a' <- a-                                                 return $ '(' : a' ++ f ++ ")"+                                                 return $ "(" <> a' <> f <> ")" -preop :: SType -> String -> S c x -> S c y+preop :: SType -> Text -> S c x -> S c y preop typ f (S a) = S $ tellAssignment typ $ do a' <- a-                                                return $ '(' : f ++ a' ++ ")"+                                                return $ "(" <> f <> a' <> ")" -binf :: String -> S c x -> S c y -> S c Float+binf :: Text -> S c x -> S c y -> S c Float binf = bin STypeFloat-fun1f :: String -> S c x -> S c Float+fun1f :: Text -> S c x -> S c Float fun1f = fun1 STypeFloat-fun2f :: String -> S c x -> S c y -> S c Float+fun2f :: Text -> 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 :: Text -> S c x -> S c y -> S c z -> S c Float fun3f = fun3 STypeFloat-preopf :: String -> S c x -> S c Float+preopf :: Text -> S c x -> S c Float preopf = preop STypeFloat-postopf :: String -> S c x -> S c Float+postopf :: Text -> S c x -> S c Float postopf = postop STypeFloat -bini :: String -> S c x -> S c y -> S c Int+bini :: Text -> S c x -> S c y -> S c Int bini = bin STypeInt-fun1i :: String -> S c x -> S c Int+fun1i :: Text -> S c x -> S c Int fun1i = fun1 STypeInt-preopi :: String -> S c x -> S c Int+preopi :: Text -> S c x -> S c Int preopi = preop STypeInt -binu :: String -> S c x -> S c y -> S c Word+binu :: Text -> S c x -> S c y -> S c Word binu = bin STypeUInt-fun1u :: String -> S c x -> S c Word+fun1u :: Text -> S c x -> S c Word fun1u = fun1 STypeUInt-preopu :: String -> S c x -> S c Word+preopu :: Text -> S c x -> S c Word preopu = preop STypeUInt  instance Num (S a Float) where@@ -677,7 +713,7 @@     abs = fun1f "abs"     signum = fun1f "sign"     (*) = binf "*"-    fromInteger = S . return . show+    fromInteger = S . return . tshow     negate = preopf "-"  instance Num (S a Int) where@@ -686,7 +722,7 @@     abs = fun1i "abs"     signum = fun1i "sign"     (*) = bini "*"-    fromInteger = S . return . show+    fromInteger = S . return . tshow     negate = preopi "-"  instance Num (S a Word) where@@ -695,12 +731,12 @@     abs = fun1u "abs"     signum = fun1u "sign"     (*) = binu "*"-    fromInteger x = S $ return $ show x ++ "u"+    fromInteger x = S $ return $ tshow x <> "u"     negate = preopu "-"  instance Fractional (S a Float) where   (/)          = binf "/"-  fromRational = S . return . ("float(" ++) . (++ ")") . show . (`asTypeOf` (undefined :: Float)) . fromRational+  fromRational = S . return . ("float(" <>) . (<> ")") . tshow . (`asTypeOf` (undefined :: Float)) . fromRational  class Integral' a where     div' :: a -> a -> a@@ -779,7 +815,7 @@     bitSize' = pure (finiteBitSize (undefined :: Word))  instance Floating (S a Float) where-  pi    = S $ return $ show (pi :: Float)+  pi    = S $ return $ tshow (pi :: Float)   sqrt  = fun1f "sqrt"   exp   = fun1f "exp"   log   = fun1f "log"@@ -874,52 +910,52 @@   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'+  rsqrt = fmap rsqrt+  exp2 = fmap exp2+  log2 = fmap log2+  floor' = fmap floor'+  ceiling' = fmap ceiling'+  fract' = fmap 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'+  rsqrt = fmap rsqrt+  exp2 = fmap exp2+  log2 = fmap log2+  floor' = fmap floor'+  ceiling' = fmap ceiling'+  fract' = fmap 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'+  rsqrt = fmap rsqrt+  exp2 = fmap exp2+  log2 = fmap log2+  floor' = fmap floor'+  ceiling' = fmap ceiling'+  fract' = fmap 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'+  rsqrt = fmap rsqrt+  exp2 = fmap exp2+  log2 = fmap log2+  floor' = fmap floor'+  ceiling' = fmap ceiling'+  fract' = fmap 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'+  rsqrt = fmap rsqrt+  exp2 = fmap exp2+  log2 = fmap log2+  floor' = fmap floor'+  ceiling' = fmap ceiling'+  fract' = fmap fract'   mod'' = liftA2 mod''   mix = liftA3 mix   atan2' = liftA2 atan2'@@ -1009,7 +1045,7 @@  --------------------------------- fromV f s v = S $ do params <- mapM (unS . f) $ toList v-                     return $ s ++ '(' : intercalate "," params ++ ")"+                     return $ s <> "(" <> LT.intercalate "," params <> ")"  fromVec4 :: V4 (S x Float) -> S x (V4 Float) fromVec4 = fromV id "vec4"

@@ -1,18 +1,21 @@+{-# LANGUAGE EmptyDataDecls        #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeSynonymInstances, EmptyDataDecls #-}+{-# LANGUAGE TypeSynonymInstances  #-}  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+import           Data.Text.Lazy        (Text)+import           Foreign.Marshal.Array (withArray)+import           Graphics.GL.Core45+import           Graphics.GL.Types     (GLenum)+import           Linear.V2             (V2 (..))+import           Linear.V3             (V3 (..))+import           Linear.V4             (V4 (..))  data RFloat data RInt@@ -107,77 +110,77 @@     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 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@@ -220,12 +223,12 @@ class TextureFormat f => ColorSampleable f where     type Color f a     type ColorElement f :: *-    typeStr :: f -> String-    typeStr4 :: f -> String+    typeStr :: f -> Text+    typeStr4 :: f -> Text     toColor :: f -> V4 x -> Color f x     fromColor :: f -> Color f x -> [x]     setBorderColor :: f -> GLenum -> Color f (ColorElement f) -> IO ()-    samplerPrefix :: f -> String+    samplerPrefix :: f -> Text     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"@@ -380,7 +383,7 @@     clearColor _ (V2 r g) = withArray [fromIntegral r, fromIntegral g,0,0] (glClearBufferuiv GL_COLOR 0) instance ColorRenderable RGBFloat where     isSrgb SRGB8 = True-    isSrgb _ = False+    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)@@ -388,7 +391,7 @@     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+    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)@@ -413,9 +416,9 @@     alphaBits = error "You cannot create your own instances of ContextColorFormat"  instance ContextColorFormat RFloat where-    redBits R8 = 8-    redBits R8S = 8-    redBits R16 = 16+    redBits R8   = 8+    redBits R8S  = 8+    redBits R16  = 16     redBits R16S = 16     redBits R16F = 16     redBits R32F = 32@@ -424,9 +427,9 @@     alphaBits _ = 0  instance ContextColorFormat RGFloat where-    redBits RG8 = 8-    redBits RG8S = 8-    redBits RG16 = 16+    redBits RG8   = 8+    redBits RG8S  = 8+    redBits RG16  = 16     redBits RG16S = 16     redBits RG16F = 16     redBits RG32F = 32@@ -435,44 +438,44 @@     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 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+    redBits RGB9E5       = 14 -- hmm...+    redBits SRGB8        = 8     greenBits = redBits-    blueBits R3G3B2 = 2+    blueBits R3G3B2       = 2     blueBits R11FG11FB10F = 10-    blueBits x = redBits x+    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 RGBA2   = 2+    redBits RGBA4   = 4+    redBits RGB5A1  = 5+    redBits RGBA8   = 8+    redBits RGBA8S  = 8     redBits RGB10A2 = 10-    redBits RGBA12 = 12-    redBits RGBA16 = 16+    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 RGB5A1  = 1     alphaBits RGB10A2 = 2-    alphaBits x = redBits x+    alphaBits x       = redBits x  -------------------------------------------------------------------------- @@ -480,20 +483,20 @@ 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 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 Stencil1  = 1+stencilBits Stencil4  = 4+stencilBits Stencil8  = 8 stencilBits Stencil16 = 16  depthStencilBits :: Format DepthStencil -> (Int, Int) depthStencilBits Depth32FStencil8 = (32, 8)-depthStencilBits Depth24Stencil8 = (24, 8)+depthStencilBits Depth24Stencil8  = (24, 8)  data WindowFormat c ds where     WindowFormatColor :: ContextColorFormat c => Format c -> WindowFormat c ()

@@ -1,30 +1,46 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, Arrows, FlexibleContexts  #-}+{-# LANGUAGE Arrows                     #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeSynonymInstances       #-} 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+import           Control.Arrow                           (Arrow (arr, first),+                                                          Kleisli (Kleisli),+                                                          returnA)+import           Control.Category                        (Category)+import           Control.Monad.Trans.State.Lazy          (State, evalState, get,+                                                          put)+import           Data.Text.Lazy                          (Text)+import           Graphics.GPipe.Internal.Compiler        (RenderIOState (rasterizationNameToRenderIO))+import           Graphics.GPipe.Internal.Expr+import           Graphics.GPipe.Internal.PrimitiveStream (PrimitiveStream (..),+                                                          PrimitiveStreamData)+import           Graphics.GPipe.Internal.Shader          (Shader (..),+                                                          getNewName,+                                                          modifyRenderIO) #if __GLASGOW_HASKELL__ < 804-import Data.Semigroup (Semigroup(..))+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           Data.Boolean                            (Boolean (true, (&&*)),+                                                          EqB ((==*)),+                                                          IfB (ifB))+import           Data.IntMap.Lazy                        (insert)+import           Linear.Affine                           (Point (..))+import           Linear.Plucker                          (Plucker (..))+import           Linear.Quaternion                       (Quaternion (..))+import           Linear.V0                               (V0 (..))+import           Linear.V1                               (V1 (..))+import           Linear.V2                               (V2 (..))+import           Linear.V3                               (V3 (..))+import           Linear.V4                               (V4 (..)) -import Graphics.GL.Core45-import Data.Maybe (isJust)+import           Data.Maybe                              (isJust)+import           Graphics.GL.Core45  type VPos = V4 VFloat @@ -53,9 +69,13 @@     --  @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 a stream of primitives into fragments, using a 'Side',+--   'PolygonMode', '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. 'PolygonMode'+--   controls whether to fill in the primitives or whether to show a wireframe+--   or points only. rasterize:: forall p a s os f. FragmentInput a           => (s -> (Side, PolygonMode, ViewPort, DepthRange))           -> PrimitiveStream p (VPos, a)@@ -72,8 +92,8 @@                                        y' <- y                                        z' <- z                                        w' <- w-                                       tellAssignment' "gl_Position" $ "vec4("++x'++',':y'++',':z'++',':w'++")"-        makePointSize Nothing = return ()+                                       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@@ -87,8 +107,8 @@                             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+        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@@ -115,9 +135,9 @@     where g (a,FragmentStreamData x1 x2 x3 x4 x5) = (a,FragmentStreamData x1 x2 x3 x4 (x5 &&* f a))  data RasterizedInfo = RasterizedInfo {-        rasterizedFragCoord :: V4 FFloat,+        rasterizedFragCoord   :: V4 FFloat,         rasterizedFrontFacing :: FBool,-        rasterizedPointCoord :: V2 FFloat+        rasterizedPointCoord  :: V2 FFloat     }  -- | Like 'fmap', but where various auto generated information from the rasterization is provided for each vertex.@@ -125,11 +145,11 @@ 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+newtype FlatVFloat = Flat VFloat -- | A float value that doesn't get divided by the interpolated position's w-component during interpolation.-data NoPerspectiveVFloat = NoPerspective VFloat+newtype NoPerspectiveVFloat = NoPerspective VFloat -makeFragment :: String -> SType -> (a -> ExprM String) -> ToFragment a (S c a1)+makeFragment :: Text -> SType -> (a -> ExprM Text) -> 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

@@ -1,35 +1,67 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# 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 +import           Control.Monad                           (void, when)+import           Control.Monad.IO.Class                  (MonadIO (liftIO))+import           Control.Monad.Trans.Class               (MonadTrans (lift))+import           Control.Monad.Trans.Except              (ExceptT, throwE)+import           Control.Monad.Trans.State.Lazy          (StateT (..), get, put)+import qualified Control.Monad.Trans.State.Strict        as StrictState+import           Control.Monad.Trans.Writer.Lazy         (Writer, execWriter,+                                                          tell)+import           Data.IORef                              (mkWeakIORef, newIORef,+                                                          readIORef)+import qualified Data.IntMap                             as IMap+import           Data.List                               (intercalate)+import           Data.Text.Lazy                          (Text)+import qualified Data.Text.Lazy                          as LT+import           Foreign.Marshal.Alloc                   (alloca)+import           Foreign.Marshal.Array                   (withArray)+import           Foreign.Marshal.Utils                   (fromBool, with)+import           Foreign.Ptr                             (nullPtr)+import           Foreign.Storable                        (peek)+import           Graphics.GL.Core45+import           Graphics.GL.Types                       (GLenum, GLuint)+import           Graphics.GPipe.Internal.Compiler        (Drawcall (Drawcall),+                                                          WinId, getFboError)+import           Graphics.GPipe.Internal.Context         (FBOKey,+                                                          FBOKeys (FBOKeys),+                                                          Render (Render),+                                                          RenderState (perWindowRenderState),+                                                          Window (getWinName),+                                                          asSync, getFBO,+                                                          getLastRenderWin,+                                                          setFBO)+import           Graphics.GPipe.Internal.Expr            (ExprM,+                                                          ExprResult (ExprResult),+                                                          F, FFloat, GlobDeclM,+                                                          S (..), discard,+                                                          runExprM,+                                                          tellAssignment',+                                                          tellGlobal,+                                                          tellGlobalLn, tshow)+import           Graphics.GPipe.Internal.Format          (ColorRenderable (clearColor),+                                                          ColorSampleable (Color, ColorElement, fromColor, typeStr),+                                                          ContextColorFormat,+                                                          DepthRenderable,+                                                          DepthStencil, Format,+                                                          StencilRenderable)+import           Graphics.GPipe.Internal.FragmentStream  (FragmentStream (..),+                                                          FragmentStreamData (..))+import           Graphics.GPipe.Internal.PrimitiveStream (PrimitiveStreamData (PrimitiveStreamData))+import           Graphics.GPipe.Internal.Shader          (Shader (..), ShaderM,+                                                          tellDrawcall)+import           Graphics.GPipe.Internal.Texture         (ComparisonFunction,+                                                          Image, getGlCompFunc,+                                                          getImageBinding,+                                                          getImageFBOKey,+                                                          imageEquals)+import           Linear.V4                               (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) @@ -99,11 +131,8 @@     -> 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'+makeFBOKeys c d s =+    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@@ -246,14 +275,14 @@  setColor :: forall c. ColorSampleable c => c -> Int -> FragColor c -> (ExprM (), GlobDeclM ()) setColor ct n c =-    let name = "out" ++ show n+    let name = "out" <> tshow n         typeS = typeStr ct     in  ( do             xs <- mapM unS (fromColor ct c :: [S F (ColorElement c)])-            tellAssignment' name (typeS ++ "(" ++ intercalate "," xs ++ ")")+            tellAssignment' name (typeS <> "(" <> LT.intercalate "," xs <> ")")         , do             tellGlobal "layout(location = "-            tellGlobal $ show n+            tellGlobal $ tshow n             tellGlobal ") out "             tellGlobal typeS             tellGlobal " "@@ -284,8 +313,8 @@     setGlBlend blend     case blend of         NoBlending -> glDisable GL_BLEND-        LogicOp _ -> glDisable GL_BLEND-        _ -> glEnable GL_BLEND+        LogicOp _  -> glDisable GL_BLEND+        _          -> glEnable GL_BLEND  setGlBlend :: Blending -> IO () setGlBlend NoBlending = return ()@@ -324,17 +353,17 @@ type StencilOptions = FrontBack StencilOption  data StencilOption = StencilOption-    { stencilTest :: ComparisonFunction-    , stencilReference :: Int-    , opWhenStencilFail :: StencilOp-    , opWhenStencilPass :: StencilOp-    , stencilReadBitMask :: Word+    { stencilTest         :: ComparisonFunction+    , stencilReference    :: Int+    , opWhenStencilFail   :: StencilOp+    , opWhenStencilPass   :: StencilOp+    , stencilReadBitMask  :: Word     , stencilWriteBitMask :: Word     }  data DepthStencilOption = DepthStencilOption-    { dsStencilOptions :: StencilOptions-    , dsDepthOption :: DepthOption+    { dsStencilOptions              :: StencilOptions+    , dsDepthOption                 :: DepthOption     , opWhenStencilPassButDepthFail :: FrontBack StencilOp     } @@ -395,11 +424,11 @@     | OneMinusConstantAlpha     | SrcAlphaSaturate -usesConstantColor ConstantColor = True+usesConstantColor ConstantColor         = True usesConstantColor OneMinusConstantColor = True-usesConstantColor ConstantAlpha = True+usesConstantColor ConstantAlpha         = True usesConstantColor OneMinusConstantAlpha = True-usesConstantColor _ = False+usesConstantColor _                     = False  -- | A bitwise logical operation that will be used to combine colors that has an integral internal representation. data LogicOp@@ -567,7 +596,7 @@ inWin w m = Render $ do     rs <- lift $ lift StrictState.get     case IMap.lookup (getWinName w) (perWindowRenderState rs) of-        Nothing -> return () -- Window deleted, do nothing+        Nothing           -> return () -- Window deleted, do nothing         Just (_, doAsync) -> liftIO $ doAsync m  -- | Fill the window's back buffer with a constant color value@@ -608,64 +637,60 @@     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 ()+maybeThrow = (>>= mapM_ throwE)  --------------- glTrue :: Num n => n glTrue = fromBool True  getGlBlendEquation :: BlendEquation -> GLenum-getGlBlendEquation FuncAdd = GL_FUNC_ADD-getGlBlendEquation FuncSubtract = GL_FUNC_SUBTRACT+getGlBlendEquation FuncAdd             = GL_FUNC_ADD+getGlBlendEquation FuncSubtract        = GL_FUNC_SUBTRACT getGlBlendEquation FuncReverseSubtract = GL_FUNC_REVERSE_SUBTRACT-getGlBlendEquation Min = GL_MIN-getGlBlendEquation Max = GL_MAX+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 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 ConstantAlpha         = GL_CONSTANT_ALPHA getGlBlendFunc OneMinusConstantAlpha = GL_ONE_MINUS_CONSTANT_ALPHA-getGlBlendFunc SrcAlphaSaturate = GL_SRC_ALPHA_SATURATE+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 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+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 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 OpDecr     = GL_DECR getGlStencilOp OpDecrWrap = GL_DECR_WRAP-getGlStencilOp OpInvert = GL_INVERT+getGlStencilOp OpInvert   = GL_INVERT

@@ -1,43 +1,87 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, Arrows, GeneralizedNewtypeDeriving, GADTs, MultiParamTypeClasses #-}+{-# LANGUAGE Arrows                     #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}  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)+import           Control.Arrow                           (Arrow (arr, first),+                                                          Kleisli (Kleisli),+                                                          returnA)+import           Control.Category                        (Category (..))+import qualified Control.Monad.Trans.Class               as T (lift)+import           Control.Monad.Trans.State.Lazy          (State, evalState, get,+                                                          put)+import           Control.Monad.Trans.Writer              (tell) #if __GLASGOW_HASKELL__ < 804-import Data.Semigroup (Semigroup(..))+import           Data.Semigroup                          (Semigroup (..)) #endif-import Prelude hiding (length, id, (.))+import           Prelude                                 hiding (id, length,+                                                          (.)) -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.GPipe.Internal.Compiler        (RenderIOState (rasterizationNameToRenderIO, transformFeedbackToRenderIO))+import           Graphics.GPipe.Internal.Expr            (ExprM,+                                                          GGenerativeGeometry,+                                                          GlobDeclM, S (..),+                                                          SType (..), VBool,+                                                          VFloat, VInt, VWord,+                                                          declareGeometryLayout,+                                                          stypeName,+                                                          tellAssignment',+                                                          tellGlobal,+                                                          tellGlobalLn, tellST,+                                                          tshow, useFInputFromG,+                                                          useGInput)+import           Graphics.GPipe.Internal.FragmentStream  (DepthRange (DepthRange),+                                                          FlatVFloat (..),+                                                          FragmentInput (FragmentFormat),+                                                          FragmentStream (..),+                                                          FragmentStreamData (..),+                                                          NoPerspectiveVFloat (..),+                                                          PolygonMode (..),+                                                          Side (Back, Front),+                                                          VPos,+                                                          ViewPort (ViewPort),+                                                          unFlat, unNPersp)+import           Graphics.GPipe.Internal.PrimitiveArray  (Geometry (..), Lines,+                                                          LinesWithAdjacency,+                                                          Points,+                                                          PrimitiveTopology (..),+                                                          Triangles,+                                                          TrianglesWithAdjacency)+import           Graphics.GPipe.Internal.PrimitiveStream (PointSize,+                                                          PrimitiveStream (..),+                                                          PrimitiveStreamData)+import           Graphics.GPipe.Internal.Shader          (Shader (..),+                                                          getNewName,+                                                          modifyRenderIO) -import Graphics.GL.Core45+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(..))+import           Data.Boolean                            (Boolean (true),+                                                          EqB ((==*)),+                                                          IfB (ifB))+import           Data.IntMap.Lazy                        (insert)+import           Data.Text.Lazy                          (Text)+import qualified Data.Text.Lazy                          as LT+import           Linear.Affine                           (Point (..))+import           Linear.Plucker                          (Plucker (..))+import           Linear.Quaternion                       (Quaternion (..))+import           Linear.V0                               (V0 (..))+import           Linear.V1                               (V1 (..))+import           Linear.V2                               (V2 (..))+import           Linear.V3                               (V3 (..))+import           Linear.V4                               (V4 (..))  ------------------------------------------------------------------------------------------------------------------------------------  type GeometrizationName = Int -type LayoutName = String+type LayoutName = Text  data GeometryStreamData = GeometryStreamData GeometrizationName LayoutName PrimitiveStreamData @@ -66,7 +110,7 @@  instance Arrow ToAnotherVertex where     {-# INLINE arr #-}-    arr f = ToAnotherVertex (arr (f . (\(_, c) -> c)))+    arr f = ToAnotherVertex (arr (f . snd))     {-# INLINE first #-}     first (ToAnotherVertex f) = ToAnotherVertex $ proc ~(i, (x, z)) -> do         y <- f -< (i, x)@@ -118,8 +162,8 @@  ------------------------------------------------------------------------------------------------------------------------------------ --- 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 :: Text -> SType -> ((S c a) -> ExprM Text) -> ToAnotherVertex (S c a) (S c a)+makeAnotherVertex :: Text -> SType -> (b -> ExprM Text) -> (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@@ -275,7 +319,7 @@ emitVertex a g = S $ do     g' <- unS g     exploseGeometry a 0-    T.lift $ T.lift $ tell "EmitVertex();\n"+    T.lift $ tellST "EmitVertex();\n"     return notMeantToBeRead  emitVertexPosition :: GeometryExplosive a => (VPos, a) -> GGenerativeGeometry p (VPos, a) -> GGenerativeGeometry p (VPos, a)@@ -285,17 +329,17 @@     y' <- unS y     z' <- unS z     w' <- unS w-    tellAssignment' "gl_Position" $ "vec4("++x'++',':y'++',':z'++',':w'++")"+    tellAssignment' "gl_Position" $ "vec4("<>x'<>"," <> y'<>"," <> z'<>"," <> w'<>")"     exploseGeometry a 0-    T.lift $ T.lift $ tell "EmitVertex();\n"+    T.lift $ tellST "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"+    tellAssignment' "gl_Layer" i'+    T.lift $ tellST "EmitVertex();\n"     return notMeantToBeRead  emitVertexPositionAndLayer :: GeometryExplosive a => ((VPos, VInt), a) -> GGenerativeGeometry p ((VPos, VInt), a) -> GGenerativeGeometry p ((VPos, VInt), a)@@ -305,17 +349,17 @@     y' <- unS y     z' <- unS z     w' <- unS w-    tellAssignment' "gl_Position" $ "vec4("++x'++',':y'++',':z'++',':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"+    tellAssignment' "gl_Layer" i'+    T.lift $ tellST "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"+    T.lift $ tellST "EndPrimitive();\n"     return notMeantToBeRead  ------------------------------------------------------------------------------------------------------------------------------------@@ -323,10 +367,10 @@ class FragmentInput a => GeometryExplosive a where     exploseGeometry :: a -> Int -> ExprM Int     declareGeometry :: a -> State Int (GlobDeclM ())-    enumerateVaryings :: a -> State Int [String]+    enumerateVaryings :: a -> State Int [Text]  defaultExploseGeometry f x n = do-    let name = "vgf" ++ show n+    let name = "vgf" <> tshow n     x' <- unS (f x)     tellAssignment' name x'     return (n + 1)@@ -334,16 +378,16 @@ defaultDeclareGeometry t x = do     n <- get     put (n + 1)-    let name = "vgf" ++ show n+    let name = "vgf" <> tshow n     return $ do-        tellGlobal $ "out "+        tellGlobal "out "         tellGlobal $ stypeName t-        tellGlobalLn $ ' ':name+        tellGlobalLn $ " " <> name  defaultEnumerateVaryings x = do     n <- get     put (n + 1)-    return ["vgf" ++ show n]+    return ["vgf" <> tshow n]  instance GeometryExplosive () where     exploseGeometry _ n = return n@@ -518,8 +562,8 @@                             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+        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@@ -538,7 +582,7 @@ class FragmentInput a => AnotherFragmentInput a where     toFragment2 :: ToAnotherFragment a (FragmentFormat a) -makeAnotherFragment :: String -> SType -> (a -> ExprM String) -> ToAnotherFragment a (S c a1)+makeAnotherFragment :: Text -> SType -> (a -> ExprM Text) -> ToAnotherFragment a (S c a1) makeAnotherFragment qual styp f = ToAnotherFragment $ Kleisli $ \ x -> do         n <- get         put (n + 1)@@ -680,133 +724,122 @@     createFragment = do         n <- get         put (n + 1)-        return $ S (return $ show n)+        return $ S (return $ tshow n)  instance FragmentCreator FlatVFloat where     createFragment = do         n <- get         put (n + 1)-        return $ Flat $ S (return $ show n)+        return $ Flat $ S (return $ tshow n)  instance FragmentCreator NoPerspectiveVFloat where     createFragment = do         n <- get         put (n + 1)-        return $ NoPerspective $ S (return $ show n)+        return $ NoPerspective $ S (return $ tshow n)  instance FragmentCreator VInt where     createFragment = do         n <- get         put (n + 1)-        return $ S (return $ show n)+        return $ S (return $ tshow n)  instance FragmentCreator VWord where     createFragment = do         n <- get         put (n + 1)-        return $ S (return $ show n)+        return $ S (return $ tshow n)  instance FragmentCreator VBool where     createFragment = do         n <- get         put (n + 1)-        return $ S (return $ show n)+        return $ S (return $ tshow n)  instance (FragmentCreator a) => FragmentCreator (V0 a) where     createFragment = return V0  instance (FragmentCreator a) => FragmentCreator (V1 a) where-    createFragment = createFragment >>= return . V1+    createFragment = V1+        <$> createFragment  instance (FragmentCreator a) => FragmentCreator (V2 a) where-    createFragment = do-        x <- createFragment-        y <- createFragment-        return (V2 x y)+    createFragment = V2+        <$> createFragment+        <*> createFragment  instance (FragmentCreator a) => FragmentCreator (V3 a) where-    createFragment = do-        x <- createFragment-        y <- createFragment-        z <- createFragment-        return (V3 x y z)+    createFragment = V3+        <$> createFragment+        <*> createFragment+        <*> createFragment  instance (FragmentCreator a) => FragmentCreator (V4 a) where-    createFragment = do-        x <- createFragment-        y <- createFragment-        z <- createFragment-        w <- createFragment-        return (V4 x y z w)+    createFragment = V4+        <$> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment  instance (FragmentCreator a, FragmentCreator b) => FragmentCreator (a,b) where-    createFragment = do-        x <- createFragment-        y <- createFragment-        return (x, y)+    createFragment = (,)+        <$> createFragment+        <*> createFragment  instance (FragmentCreator a, FragmentCreator b, FragmentCreator c) => FragmentCreator (a,b,c) where-    createFragment = do-        x <- createFragment-        y <- createFragment-        z <- createFragment-        return (x, y, z)+    createFragment = (,,)+        <$> createFragment+        <*> createFragment+        <*> createFragment  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)+    createFragment = (,,,)+        <$> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment  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)+    createFragment = (,,,,)+        <$> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment  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)+    createFragment = (,,,,,)+        <$> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment  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)+    createFragment = (,,,,,,)+        <$> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment  instance FragmentCreator a => FragmentCreator (Quaternion a) where-    createFragment = do-        a <- createFragment-        v <- createFragment-        return (Quaternion a v)+    createFragment = Quaternion+        <$> createFragment+        <*> createFragment  instance (FragmentCreator (f a), FragmentCreator a, FragmentFormat (f a) ~ f (FragmentFormat a)) => FragmentCreator (Point f a) where-    createFragment = do-        a <- createFragment-        return (P a)+    createFragment = P+        <$> createFragment  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)+    createFragment = Plucker+        <$> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment+        <*> createFragment

@@ -1,7 +1,8 @@ module Graphics.GPipe.Internal.Linear where  import           Control.Lens ((^.))-import           Linear+import           Linear       (M44, Metric (dot, signorm), R1 (..), R2 (..),+                               R3 (..), V3, V4 (..), cross)   lookAt :: Floating a => V3 a -> V3 a -> V3 a -> V4 (V4 a)

@@ -1,15 +1,17 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-} 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(..))+import           Data.Boolean      (Boolean (false, true, (&&*), (||*)),+                                    BooleanOf, EqB (..), IfB (..))+import           Linear.Affine     (Point (..))+import           Linear.Plucker    (Plucker (..))+import           Linear.Quaternion (Quaternion (..))+import           Linear.V0         (V0 (..))+import           Linear.V1         (V1 (..))+import           Linear.V2         (V2 (..))+import           Linear.V3         (V3 (..))+import           Linear.V4         (V4 (..))  type instance BooleanOf (V0 a) = BooleanOf a type instance BooleanOf (V1 a) = BooleanOf a@@ -44,17 +46,17 @@ 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 +        ifB q _ _ = V0 instance IfB a => IfB (V1 a) where-        ifB q (V1 a) (V1 x) = V1 (ifB q a x) +        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) +        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) +        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) +        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

@@ -1,18 +1,28 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, EmptyDataDecls, TypeFamilies, GADTs #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE EmptyDataDecls       #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeSynonymInstances #-} module Graphics.GPipe.Internal.PrimitiveArray where -import Graphics.GPipe.Internal.Buffer-import Graphics.GPipe.Internal.Shader+import           Data.Text.Lazy                 (Text)+import qualified Data.Text.Lazy                 as LT+import           Graphics.GPipe.Internal.Buffer (B, BInput (..), BPacked,+                                                 Buffer (bufBElement, bufName, bufferLength),+                                                 BufferFormat (getGlType))+import           Graphics.GPipe.Internal.Shader (Render (Render)) #if __GLASGOW_HASKELL__ < 804-import Data.Semigroup+import           Data.Semigroup #endif-import Data.IORef+import           Data.IORef                     (IORef) -import Data.Word+import           Data.Word                      (Word16, Word32, Word8)  import           Graphics.GL.Core45-import           Graphics.GL.Types+import           Graphics.GL.Types              (GLuint)  -- | 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.@@ -20,8 +30,8 @@ data VertexArray t a = VertexArray  {     -- | Retrieve the number of elements in a 'VertexArray'.     vertexArrayLength :: Int,-    vertexArraySkip :: Int,-    bArrBFunc:: BInput -> a+    vertexArraySkip   :: Int,+    bArrBFunc         :: BInput -> a     }  -- | A phantom type to indicate that a 'VertexArray' may only be used for instances (in 'toPrimitiveArrayInstanced' and 'toPrimitiveArrayIndexedInstanced').@@ -69,12 +79,12 @@ -- | 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,+    iArrName         :: IORef GLuint,     -- | Numer of indices in an 'IndexArray'.-    indexArrayLength:: Int,-    offset:: Int,-    restart:: Maybe Int,-    indexType :: GLuint+    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.@@ -103,8 +113,8 @@     toGLtopology :: p -> GLuint     toPrimitiveSize :: p -> Int     toGeometryShaderOutputTopology :: p -> GLuint-    toLayoutIn :: p -> String-    toLayoutOut :: p -> String+    toLayoutIn :: p -> Text+    toLayoutOut :: p -> Text     data Geometry p a  instance PrimitiveTopology Points where@@ -116,8 +126,8 @@     data Geometry Points a = Point a  instance PrimitiveTopology Lines where-    toGLtopology LineList = GL_LINES-    toGLtopology LineLoop = GL_LINE_LOOP+    toGLtopology LineList  = GL_LINES+    toGLtopology LineLoop  = GL_LINE_LOOP     toGLtopology LineStrip = GL_LINE_STRIP     toPrimitiveSize _= 2     toGeometryShaderOutputTopology _ = GL_LINES@@ -126,7 +136,7 @@     data Geometry Lines a = Line a a  instance PrimitiveTopology LinesWithAdjacency where-    toGLtopology LineListAdjacency = GL_LINES_ADJACENCY+    toGLtopology LineListAdjacency  = GL_LINES_ADJACENCY     toGLtopology LineStripAdjacency = GL_LINE_STRIP_ADJACENCY     toPrimitiveSize _= 2     toGeometryShaderOutputTopology _ = GL_LINES@@ -135,7 +145,7 @@     data Geometry LinesWithAdjacency a = LineWithAdjacency a a a a  instance PrimitiveTopology Triangles where-    toGLtopology TriangleList = GL_TRIANGLES+    toGLtopology TriangleList  = GL_TRIANGLES     toGLtopology TriangleStrip = GL_TRIANGLE_STRIP     toPrimitiveSize _= 3     toGeometryShaderOutputTopology _ = GL_TRIANGLES@@ -144,7 +154,7 @@     data Geometry Triangles a = Triangle a a a  instance PrimitiveTopology TrianglesWithAdjacency where-    toGLtopology TriangleListAdjacency = GL_TRIANGLES_ADJACENCY+    toGLtopology TriangleListAdjacency  = GL_TRIANGLES_ADJACENCY     toGLtopology TriangleStripAdjacency = GL_TRIANGLE_STRIP_ADJACENCY     toPrimitiveSize _= 3     toGeometryShaderOutputTopology _ = GL_TRIANGLES

@@ -1,52 +1,81 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, Arrows, GeneralizedNewtypeDeriving, PatternSynonyms #-}+{-# LANGUAGE Arrows                     #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeSynonymInstances       #-} +{-# LANGUAGE TupleSections              #-} 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+import           Control.Arrow                          (Arrow (arr, first),+                                                         Kleisli (Kleisli),+                                                         returnA)+import           Control.Monad.Trans.Class              (MonadTrans (lift))+import           Control.Monad.Trans.Reader             (Reader, ask, runReader)+import           Control.Monad.Trans.State.Strict       (State,+                                                         StateT (runStateT),+                                                         execState, get, modify,+                                                         put)+import           Data.Text.Lazy                         (Text)+import qualified Data.Text.Lazy                         as LT+import           Graphics.GPipe.Internal.Buffer         (B (..), B2 (..),+                                                         B3 (..), B4 (..),+                                                         Buffer (bufTransformFeedback),+                                                         BufferFormat (HostFormat),+                                                         Normalized (..))+import           Graphics.GPipe.Internal.Compiler       (Binding,+                                                         RenderIOState (inputArrayToRenderIO))+import           Graphics.GPipe.Internal.Context        (VAOKey (VAOKey))+import           Graphics.GPipe.Internal.Expr           (ExprM, S (S),+                                                         SType (..), V, VFloat,+                                                         VInt, VWord, scalarS',+                                                         useUniform, useVInput,+                                                         vec2S, vec3S, vec4S)+import           Graphics.GPipe.Internal.PrimitiveArray (IndexArray (iArrName, indexArrayLength, indexType, offset, restart),+                                                         Points,+                                                         PrimitiveArray (getPrimitiveArray),+                                                         PrimitiveArrayInt (..),+                                                         PrimitiveTopology (toGLtopology, toPrimitiveSize))+import           Graphics.GPipe.Internal.Shader         (Shader (..), ShaderM,+                                                         askUniformAlignment,+                                                         getNewName,+                                                         modifyRenderIO)+import           Prelude                                hiding (id, length, (.)) -- 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)+import           Control.Category                       (Category (..))+import           Control.Monad                          (void, when)+import           Graphics.GPipe.Internal.Uniform        (OffsetToSType,+                                                         buildUDecl) #if __GLASGOW_HASKELL__ < 804-import Data.Semigroup (Semigroup(..))+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           Data.Int                               (Int16, Int32, Int8)+import qualified Data.IntMap                            as Map+import           Data.IntMap.Lazy                       (insert)+import           Data.Word                              (Word16, Word32, Word8)+import           Foreign.Marshal                        (alloca)+import           Foreign.Ptr                            (Ptr, castPtr,+                                                         intPtrToPtr, plusPtr)+import           Foreign.Storable                       (Storable (peek, poke, sizeOf)) -import Graphics.GPipe.Internal.Debug+import           Data.IORef                             (readIORef)+import           Data.Maybe                             (fromMaybe)+import           Foreign.Marshal.Utils                  (fromBool)+import           Graphics.GL.Core45+import           Graphics.GL.Types                      (GLuint)+import           Linear.Affine                          (Point (..))+import           Linear.Plucker                         (Plucker (..))+import           Linear.Quaternion                      (Quaternion (..))+import           Linear.V0                              (V0 (..))+import           Linear.V1                              (V1 (..))+import           Linear.V2                              (V2 (..))+import           Linear.V3                              (V3 (..))+import           Linear.V4                              (V4 (..))  -- Originally named DrawCallName and later in the code as PrimN. I've sticked -- with the latter, because it's more logical.@@ -107,7 +136,7 @@             ,   OffsetToSType -- Offset -> SType?             )             (   Reader-                (   Int {- offset -} -> ExprM String -- Ends up calling useVInput and returning the input variable name (eg. 'in123').+                (   Int {- offset -} -> ExprM Text -- Ends up calling useVInput and returning the input variable name (eg. 'in123').                 )             )         ) a b)@@ -160,7 +189,7 @@             fb = getFeedbackBuffer >>= \g -> return (g s)             ps = getPrimitiveArray (sf s)         in-            map drawcall (map (\p -> (fb, p)) ps)+            map (drawcall . (fb,)) ps      return $ PrimitiveStream [(x, (Nothing, PrimitiveStreamData n uSize))] @@ -180,7 +209,7 @@                 then glDrawTransformFeedback (toGLtopology p) tfName                 else do                     -- Is it costly too do it repeatedly?-                    l' <- (fromIntegral (toPrimitiveSize p) *) <$> (alloca $ \ptr -> do+                    l' <- (fromIntegral (toPrimitiveSize p) *) <$> alloca (\ptr -> do                         glGetQueryObjectiv tfqName GL_QUERY_RESULT ptr                         peek ptr)                     -- liftIO $ hPutStrLn stderr $ "queried vertice count: " ++ show l'@@ -245,7 +274,7 @@             void $ glUnmapBuffer GL_COPY_WRITE_BUFFER  data InputIndices = InputIndices {-        inputVertexID :: VInt,+        inputVertexID   :: VInt,         inputInstanceID :: VInt     } 

@@ -1,6 +1,11 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts,-  RankNTypes, ExistentialQuantification, GeneralizedNewtypeDeriving,-  FlexibleInstances, GADTs #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE TypeFamilies               #-}  module Graphics.GPipe.Internal.Shader (     Shader(..),@@ -21,22 +26,31 @@ ) 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)+import           Control.Applicative              (Alternative, (<|>))+import           Control.Monad                    (MonadPlus, forM)+import           Control.Monad.Exception          (MonadException)+import           Control.Monad.IO.Class           (MonadIO)+import           Control.Monad.Trans.Class        (lift)+import           Control.Monad.Trans.List         (ListT (..))+import           Control.Monad.Trans.Reader       (ReaderT (..), ask)+import           Control.Monad.Trans.State        (State, get, modify, put,+                                                   runState)+import           Control.Monad.Trans.Writer.Lazy  (WriterT (..), execWriterT,+                                                   tell)+import           Data.Either                      (isLeft, isRight)+import           Data.List                        (find)+import           Data.Maybe                       (fromJust, isJust, isNothing)+import           Data.Monoid                      (All (..))+import           Graphics.GPipe.Internal.Buffer   (UniformAlignment,+                                                   getUniformAlignment)+import           Graphics.GPipe.Internal.Compiler (Drawcall, RenderIOState,+                                                   compileDrawcalls,+                                                   mapDrawcall,+                                                   mapRenderIOState,+                                                   newRenderIOState)+import           Graphics.GPipe.Internal.Context  (ContextHandler, ContextT,+                                                   Render (..),+                                                   liftNonWinContextIO)  {- Some wording & structure: 

@@ -1,31 +1,78 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, ScopedTypeVariables, AllowAmbiguousTypes, EmptyDataDecls #-}+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE EmptyDataDecls        #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-} 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           Control.Monad.IO.Class                       (MonadIO, liftIO)+import           Data.IntMap.Lazy                             (insert)+import           Data.Text.Lazy                               (Text)+import qualified Data.Text.Lazy                               as LT+import           Graphics.GPipe.Internal.Buffer               (Buffer (bufElementSize, bufName, bufferLength),+                                                               BufferColor,+                                                               BufferFormat (..),+                                                               BufferStartPos,+                                                               bufferWriteInternal,+                                                               makeBuffer)+import           Graphics.GPipe.Internal.Compiler             (Binding,+                                                               RenderIOState (samplerNameToRenderIO))+import           Graphics.GPipe.Internal.Context              (ContextHandler,+                                                               ContextT,+                                                               FBOKey (FBOKey),+                                                               GPipeException (GPipeException),+                                                               Render (Render),+                                                               addContextFinalizer,+                                                               addFBOTextureFinalizer,+                                                               liftNonWinContextAsyncIO,+                                                               liftNonWinContextIO,+                                                               registerRenderWriteTexture)+import           Graphics.GPipe.Internal.Expr                 (ExprM, F, FFloat,+                                                               S (..),+                                                               SType (..),+                                                               scalarS, tshow,+                                                               useSampler,+                                                               vec2S, vec3S,+                                                               vec4S)+import           Graphics.GPipe.Internal.Format               (ColorRenderable,+                                                               ColorSampleable (..),+                                                               DepthRenderable,+                                                               Format,+                                                               TextureFormat (..),+                                                               getGlInternalFormat)+import           Graphics.GPipe.Internal.Shader               (Shader (..),+                                                               ShaderM,+                                                               getNewName,+                                                               modifyRenderIO) -import Graphics.GL.Core45-import Graphics.GL.Types-import Graphics.GL.Ext.EXT.TextureFilterAnisotropic+import           Graphics.GL.Core45+import           Graphics.GL.Ext.EXT.TextureFilterAnisotropic+import           Graphics.GL.Types                            (GLenum, GLuint) -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)+import           Control.Exception                            (throwIO)+import           Control.Monad                                (foldM, forM_,+                                                               void, when)+import           Control.Monad.Exception                      (MonadAsyncException,+                                                               bracket)+import           Control.Monad.Trans.Class                    (lift)+import           Data.IORef                                   (IORef, newIORef,+                                                               readIORef)+import           Foreign.Marshal.Alloc                        (alloca,+                                                               allocaBytes,+                                                               free,+                                                               mallocBytes)+import           Foreign.Marshal.Utils                        (with)+import           Foreign.Ptr                                  (minusPtr,+                                                               nullPtr, plusPtr,+                                                               wordPtrToPtr)+import           Foreign.Storable                             (Storable (peek))+import           Linear.V2                                    (V2 (..))+import           Linear.V3                                    (V3 (..))+import           Linear.V4                                    (V4 (..))  data Texture1D os a = Texture1D TexName Size1 MaxLevels data Texture1DArray os a = Texture1DArray TexName Size2 MaxLevels@@ -192,7 +239,7 @@ textureCubeLevels :: TextureCube os f -> Int texture1DLevels (Texture1D _ _ ls) = ls texture1DArrayLevels (Texture1DArray _ _ ls) = ls-texture2DLevels (Texture2D _ _ ls) = ls+texture2DLevels (Texture2D _ _ ls)   = ls texture2DLevels (RenderBuffer2D _ _) = 1 texture2DArrayLevels (Texture2DArray _ _ ls) = ls texture3DLevels (Texture3D _ _ ls) = ls@@ -720,7 +767,7 @@ 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+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@@ -757,14 +804,14 @@    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 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+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))@@ -893,10 +940,10 @@                                    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+    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 ()@@ -912,12 +959,12 @@                                                 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+                    (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+                    Linear  -> GL_LINEAR   @@ -927,12 +974,12 @@  -- | 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+data Sampler1D f = Sampler1D Int Bool Text+data Sampler1DArray f = Sampler1DArray Int Bool Text+data Sampler2D f = Sampler2D Int Bool Text+data Sampler2DArray f = Sampler2DArray Int Bool Text+data Sampler3D f = Sampler3D Int Bool Text+data SamplerCube f = SamplerCube Int Bool Text  -- | 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.@@ -955,8 +1002,8 @@ 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' SampleAuto'       = SampleAuto+fromLod' (SampleBias' x)   = SampleBias x fromLod' (SampleGrad' x y) = SampleGrad x y  type SampleProj x = Maybe (S x Float)@@ -1027,123 +1074,123 @@ 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+addShadowPrefix :: Bool -> Text -> Text+addShadowPrefix shadow = if shadow then (<> "Shadow") else id -getTextureSize :: String -> Int -> String -> S c Int -> ExprM String+getTextureSize :: Text -> Int -> Text -> S c Int -> ExprM Text getTextureSize prefix sampId sName l = do s <- useSampler prefix sName sampId                                           l' <- unS l-                                          return $ "textureSize(" ++ s ++ ',' : 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 :: e -> Text -> Text -> Text -> Int -> SampleLod lcoord x -> SampleProj x -> Maybe off -> coord -> (coord -> ExprM Text) -> (lcoord -> ExprM Text) -> (off -> Text) -> (coord -> S x Float -> ExprM Text) -> 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 :: Text -> Int -> SampleLod lcoord x -> SampleProj x -> Maybe off -> coord -> (coord -> ExprM Text) -> (lcoord -> ExprM Text) -> (off -> Text) -> (coord -> S x Float -> ExprM Text) -> S x Float sampleShadow sName sampId lod proj off coord vToS lvToS civToS pvToS =-    scalarS STypeFloat $ do s <- useSampler "" (sName ++ "Shadow") sampId+    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 :: e -> Text -> Text -> Text -> Int -> S x Int -> Maybe off -> coord -> (coord -> ExprM Text) -> (off -> Text) -> 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 :: S c Float -> ExprM Text+v2toF :: V2 (S c Float) -> ExprM Text+v3toF :: V3 (S c Float) -> ExprM Text+v4toF :: V4 (S c Float) -> ExprM Text v1toF = unS v2toF (V2 x y) = do x' <- unS x                     y' <- unS y-                    return $ "vec2(" ++ x' ++ ',':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' ++ ")"+                      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' ++ ")"+                        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 :: S c Int -> ExprM Text+iv2toF :: V2 (S c Int) -> ExprM Text+iv3toF :: V3 (S c Int) -> ExprM Text iv1toF = unS iv2toF (V2 x y) = do x' <- unS x                      y' <- unS y-                     return $ "ivec2(" ++ x' ++ ',':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' ++ ")"+                       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+civ1toF :: Int -> Text+civ2toF :: V2 Int -> Text+civ3toF :: V3 Int -> Text+civ1toF = tshow+civ2toF (V2 x y) = "ivec2(" <> tshow x <> "," <> tshow y <> ")"+civ3toF (V3 x y z) = "ivec3(" <> tshow x <> "," <> tshow y <> "," <> tshow z <> ")"+pv1toF :: S c Float -> S c Float -> ExprM Text+pv2toF :: V2 (S c Float) -> S c Float -> ExprM Text+pv3toF :: V3 (S c Float) -> S c Float -> ExprM Text  pv1toF x y = do x' <- unS x                 y' <- unS y-                return $ "vec2(" ++ x' ++ ',':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' ++ ")"+                       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' ++ ")"+                         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 ++ ")"+    return $ "texture" <> projName proj <> lodName lod <> offName off <> "(" <> s <> "," <> pc <> l <> o <> b <> ")"   where     o = offParam off civToS      projName Nothing = ""-    projName _ = "Proj"+    projName _       = "Proj" -    projCoordParam Nothing = vToS coord+    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 (SampleLod x) = fmap ("," <> ) (unS x)+    lodParam (SampleGrad x y) = (<>) <$> fmap ("," <> ) (lvToS x) <*> fmap ("," <> ) (lvToS y)     lodParam _ = return "" -    biasParam :: SampleLod v x -> ExprM String+    biasParam :: SampleLod v x -> ExprM Text     biasParam (SampleBias (S x)) = do x' <- x-                                      return $ ',':x'+                                      return $ "," <> x'     biasParam _ = return "" -    lodName (SampleLod _) = "Lod"+    lodName (SampleLod _)    = "Lod"     lodName (SampleGrad _ _) = "Grad"-    lodName _ = ""+    lodName _                = ""  fetchFunc s off coord lod vToS civToS = do     c <- vToS coord     l <- unS lod-    return $ "texelFetch" ++ offName off ++ '(' : s ++ ',' : c ++ ',': l ++ o ++ ")"+    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+offParam :: Maybe t -> (t -> Text) -> Text+offParam Nothing _       = ""+offParam (Just x) civToS = "," <> civToS x -offName :: Maybe t -> String+offName :: Maybe t -> Text offName Nothing = ""-offName _ = "Offset"+offName _       = "Offset"  ---------------------------------------------------------------------------------- 

@@ -1,26 +1,45 @@-{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, Arrows, GeneralizedNewtypeDeriving, GADTs, MultiParamTypeClasses, FlexibleContexts #-}+{-# LANGUAGE Arrows                     #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}  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           Data.Text.Lazy                          (Text)+import qualified Data.Text.Lazy                          as LT+import           Graphics.GPipe.Internal.Buffer          (Buffer (bufName, bufTransformFeedback))+import           Graphics.GPipe.Internal.Compiler        (Drawcall (Drawcall),+                                                          RenderIOState (transformFeedbackToRenderIO))+import           Graphics.GPipe.Internal.Context         (Window (getWinName))+import           Graphics.GPipe.Internal.Expr            (ExprM,+                                                          ExprResult (ExprResult),+                                                          GGenerativeGeometry,+                                                          GlobDeclM, S (..),+                                                          declareGeometryLayout,+                                                          runExprM)+import           Graphics.GPipe.Internal.GeometryStream  (GeometryExplosive (declareGeometry, enumerateVaryings),+                                                          GeometryStream (..),+                                                          GeometryStreamData (..))+import           Graphics.GPipe.Internal.PrimitiveArray  (PrimitiveTopology (toGeometryShaderOutputTopology, toLayoutOut))+import           Graphics.GPipe.Internal.PrimitiveStream (PrimitiveStreamData (PrimitiveStreamData),+                                                          VertexInput (VertexFormat))+import           Graphics.GPipe.Internal.Shader          (Shader (..), ShaderM,+                                                          modifyRenderIO,+                                                          tellDrawcall) -import Graphics.GL.Core45-import Graphics.GL.Types+import           Graphics.GL.Core45+import           Graphics.GL.Types                       (GLuint) -import Data.IORef-import Data.IntMap.Lazy (insert)-import Foreign.C.String-import Foreign.Marshal-import Foreign.Storable-import Control.Monad.Trans.State+import           Control.Monad.Trans.State               (evalState)+import           Data.IORef                              (readIORef, writeIORef)+import           Data.IntMap.Lazy                        (insert)+import           Foreign.C.String                        (newCString)+import           Foreign.Marshal                         (alloca, free,+                                                          withArray)+import           Foreign.Storable                        (Storable (peek))  drawNothing :: forall p a s c ds os f. (PrimitiveTopology p, VertexInput a, GeometryExplosive (VertexFormat a))     => Window os c ds@@ -46,12 +65,12 @@ 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)+        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+                names <- mapM (newCString . LT.unpack) varyings                 withArray names $ \a -> do                     glTransformFeedbackVaryings pName (fromIntegral varyingCount) a bufferMode                 mapM_ free names

@@ -1,30 +1,55 @@-{-# LANGUAGE TypeFamilies, FlexibleContexts, GADTs, TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances, GeneralizedNewtypeDeriving, Arrows, MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE AllowAmbiguousTypes        #-}+{-# LANGUAGE Arrows                     #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeSynonymInstances       #-}  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           Control.Arrow                    (Arrow (arr),+                                                   Kleisli (Kleisli), returnA,+                                                   (>>>))+import           Control.Category                 (Category)+import           Control.Monad.Trans.Class        (lift)+import           Control.Monad.Trans.Reader       (Reader, ask, runReader)+import           Control.Monad.Trans.Writer       (WriterT (runWriterT), tell)+import qualified Data.IntMap                      as Map+import           Data.IntMap.Lazy                 (insert)+import           Data.Text.Lazy                   (Text)+import qualified Data.Text.Lazy                   as LT+import           Data.Word                        (Word32)+import           Graphics.GPipe.Internal.Buffer   (B (..), B2 (..), B3 (..),+                                                   B4 (..), BInput (..),+                                                   Buffer (..), BufferFormat,+                                                   Uniform (..), makeBuffer)+import           Graphics.GPipe.Internal.Compiler (Binding,+                                                   RenderIOState (uniformNameToRenderIO))+import           Graphics.GPipe.Internal.Expr     (ExprM, GlobDeclM, S (S),+                                                   SType (..), stypeName,+                                                   stypeSize, tellGlobal,+                                                   tellGlobalLn, tshow,+                                                   useUniform, vec2S'', vec3S'',+                                                   vec4S'')+import           Graphics.GPipe.Internal.Shader   (Shader (..), ShaderM,+                                                   askUniformAlignment,+                                                   getNewName, modifyRenderIO) -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(..))+import           Data.IORef                       (readIORef)+import           Data.Int                         (Int32)+import           Graphics.GL.Core45+import           Linear.Plucker                   (Plucker (..))+import           Linear.Quaternion                (Quaternion (..))+import           Linear.V0                        (V0 (..))+import           Linear.V1                        (V1 (..))+import           Linear.V2                        (V2 (..))+import           Linear.V3                        (V3 (..))+import           Linear.V4                        (V4 (..))  -- | This class constraints which buffer types can be loaded as uniforms, and what type those values have. class BufferFormat a => UniformInput a where@@ -47,7 +72,7 @@     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 :: (Int -> ExprM Text) -> (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@@ -71,11 +96,11 @@         | off == p = do             tellGlobal $ stypeName stype             tellGlobal " u"-            tellGlobalLn $ show off+            tellGlobalLn $ tshow off             buildUDecl' (p + stypeSize stype) xs         | off > p = do             tellGlobal "float pad"-            tellGlobalLn $ show p+            tellGlobalLn $ tshow p             buildUDecl' (p + 4) xxs         | otherwise =             error "buildUDecl: Expected all offsets to be multiple of 4"@@ -84,7 +109,7 @@ 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)+newtype ToUniform x a b = ToUniform (Kleisli (WriterT OffsetToSType (Reader (Int -> ExprM Text))) a b) deriving (Category, Arrow)  makeUniform :: SType -> ToUniform x (B a) (S x b) makeUniform styp = ToUniform $ Kleisli $ \bIn -> do

@@ -10,9 +10,9 @@ -- -- | -- 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). +-- (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 +import           Graphics.GPipe.Internal.Orphans ()

@@ -9,7 +9,7 @@ -- 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.   +--   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: --@@ -18,14 +18,14 @@ -- --  @ --   do---      aArr <- newVertexArray a        ---      bArr <- newVertexArray b +--      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 (          +module Graphics.GPipe.PrimitiveArray (     -- * Vertex arrays     VertexArray(),     Instances,@@ -36,17 +36,17 @@     takeVertices,     dropVertices,     replicateEach,-    +     -- * Index arrays-    IndexArray(),    +    IndexArray(),     newIndexArray,     IndexFormat,     indexArrayLength,     takeIndices,     dropIndices,-   +     -- * Primitive arrays-    PrimitiveArray(),   +    PrimitiveArray(),     PrimitiveTopology(..),     Points(..),     Lines(..),@@ -61,10 +61,10 @@      -- * 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. +    --   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+import           Graphics.GPipe.Internal.Buffer+import           Graphics.GPipe.Internal.PrimitiveArray

@@ -32,4 +32,4 @@ ) where -import Graphics.GPipe.Internal.PrimitiveStream+import           Graphics.GPipe.Internal.PrimitiveStream

@@ -10,7 +10,7 @@ -- -- | -- 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.  +-- 'Shadow' samplers that doesnt return a sampled color value, but instead compare a reference value to the texture value. -----------------------------------------------------------------------------  module Graphics.GPipe.Sampler (@@ -19,14 +19,14 @@     Shadow,      -- * Creating samplers-    -- | These 'Shader' actions all take a texture and some filtering and edge options from the shader environment, and return a sampler. +    -- | 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, +    EdgeMode2,     EdgeMode3,     BorderColor,     Anisotropy,@@ -35,38 +35,37 @@     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]. +    --   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, +    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,   +    texelFetch1D, texelFetch1DArray, texelFetch2D, texelFetch2DArray, texelFetch3D,      -- * Sample parameter types-    SampleLod(..), -    SampleLod1, -    SampleLod2, -    SampleLod3, -    SampleLod'(..), -    SampleLod2', +    SampleLod(..),+    SampleLod1,+    SampleLod2,+    SampleLod3,+    SampleLod'(..),+    SampleLod2',     SampleLod3',     fromLod',     SampleProj,     SampleOffset1,     SampleOffset2,-    SampleOffset3, +    SampleOffset3,     ReferenceValue,     ColorSample, ) where -import Graphics.GPipe.Internal.Texture-+import           Graphics.GPipe.Internal.Texture

@@ -37,5 +37,5 @@ ) where -import Graphics.GPipe.Internal.Context-import Graphics.GPipe.Internal.Shader+import           Graphics.GPipe.Internal.Context+import           Graphics.GPipe.Internal.Shader

@@ -22,13 +22,13 @@  module Graphics.GPipe.Texture (     -- * Texture data types-    Texture1D(), Texture1DArray(), Texture2D(), Texture2DArray(), Texture3D(), TextureCube(), +    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.  +    --   maximum possible number of levels.     newTexture1D,     newTexture1DArray,     newTexture2D,@@ -38,28 +38,28 @@      -- * 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, +    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'.  +    -- | 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,    +    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,@@ -68,7 +68,7 @@     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.    +    --   'writeTextureX' where parameter 'Level' is 0.     generateTexture1DMipmap,     generateTexture1DArrayMipmap,     generateTexture2DMipmap,@@ -85,7 +85,7 @@     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,@@ -93,12 +93,12 @@     readTexture2DArrayToBuffer,     readTexture3DToBuffer,     readTextureCubeToBuffer,-    +     -- * Type synonyms     MaxLevels, Level,     Size1, Size2, Size3,-    StartPos1, StartPos2, StartPos3, +    StartPos1, StartPos2, StartPos3, ) where -import Graphics.GPipe.Internal.Texture+import           Graphics.GPipe.Internal.Texture

@@ -3,4 +3,4 @@ ) where -import Graphics.GPipe.Internal.TransformFeedback+import           Graphics.GPipe.Internal.TransformFeedback

@@ -10,16 +10,16 @@ -- -- | -- 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.  +-- They are loaded from a 'Buffer' and OpenGl uniform blocks are used under the hood. -----------------------------------------------------------------------------  module Graphics.GPipe.Uniform (     UniformInput(..),     ToUniform(),-    getUniform,   -    Uniform(..), +    getUniform,+    Uniform(..), ) where -import Graphics.GPipe.Internal.Uniform-import Graphics.GPipe.Internal.Buffer  +import           Graphics.GPipe.Internal.Buffer+import           Graphics.GPipe.Internal.Uniform

@@ -3,7 +3,6 @@  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