{-# LANGUAGE PatternGuards   #-}
{-# LANGUAGE PatternSynonyms #-}
module Graphics.GPipe.Internal.Compiler where

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

{-
A Drawcall is an OpenGL shader program with its context. Drawcalls are produced
when evaluating a (GPipe) Shader and are intended to be "compiled" (sources
compiled and linked into a program used by a render action).
-}
-- public

data Drawcall s = Drawcall
    {   Drawcall s -> s -> (Either WinId (IO FBOKeys, IO ()), IO ())
drawcallFbo :: s ->
        (   Either WinId
                (   IO FBOKeys
                ,   IO ()
                )
        ,   IO ()
        )
    ,   Drawcall s -> Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
feedbackBuffer :: Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
        -- Key for RenderIOState::inputArrayToRenderIOs.

    ,   Drawcall s -> WinId
primitiveName :: Int
        -- Key for RenderIOState::rasterizationNameToRenderIO.

    ,   Drawcall s -> Maybe WinId
rasterizationName :: Maybe Int
        -- Shader sources.

    ,   Drawcall s -> String
vertexSource :: String
    ,   Drawcall s -> Maybe String
optionalGeometrySource :: Maybe String
    ,   Drawcall s -> Maybe String
optionalFragmentSource :: Maybe String
        -- Inputs.

    ,   Drawcall s -> [WinId]
usedInputs :: [Int]
        -- Uniforms and texture units used in each shader.

    ,   Drawcall s -> [WinId]
usedVUniforms :: [Int],   Drawcall s -> [WinId]
usedVSamplers :: [Int]
    ,   Drawcall s -> [WinId]
usedGUniforms :: [Int],   Drawcall s -> [WinId]
usedGSamplers :: [Int]
    ,   Drawcall s -> [WinId]
usedFUniforms :: [Int],   Drawcall s -> [WinId]
usedFSamplers :: [Int]
        -- The size of the uniform buffer for the primitive stream (see USize in PrimitiveStream data).

    ,   Drawcall s -> WinId
primStrUBufferSize :: Int
    }

-- public

mapDrawcall :: (s -> s') -> Drawcall s' -> Drawcall s
mapDrawcall :: (s -> s') -> Drawcall s' -> Drawcall s
mapDrawcall s -> s'
f Drawcall s'
dc = Drawcall s'
dc{ drawcallFbo :: s -> (Either WinId (IO FBOKeys, IO ()), IO ())
drawcallFbo = Drawcall s' -> s' -> (Either WinId (IO FBOKeys, IO ()), IO ())
forall s.
Drawcall s -> s -> (Either WinId (IO FBOKeys, IO ()), IO ())
drawcallFbo Drawcall s'
dc (s' -> (Either WinId (IO FBOKeys, IO ()), IO ()))
-> (s -> s') -> s -> (Either WinId (IO FBOKeys, IO ()), IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s'
f, feedbackBuffer :: Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
feedbackBuffer = Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
feedbackBuffer' }
    where
        feedbackBuffer' :: Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
feedbackBuffer' = case Drawcall s' -> Maybe (s' -> IO (GLuint, GLuint, GLuint, GLuint))
forall s.
Drawcall s -> Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
feedbackBuffer Drawcall s'
dc of
            Maybe (s' -> IO (GLuint, GLuint, GLuint, GLuint))
Nothing -> Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
forall a. Maybe a
Nothing
            Just s' -> IO (GLuint, GLuint, GLuint, GLuint)
b  -> (s -> IO (GLuint, GLuint, GLuint, GLuint))
-> Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
forall a. a -> Maybe a
Just (s' -> IO (GLuint, GLuint, GLuint, GLuint)
b (s' -> IO (GLuint, GLuint, GLuint, GLuint))
-> (s -> s') -> s -> IO (GLuint, GLuint, GLuint, GLuint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s'
f)

-- index/binding refers to what is used in the final shader. Index space is

-- limited, usually 16 attribname is what was declared, but all might not be

-- used. Attribname share namespace with uniforms and textures (in all shaders)

-- and is unlimited(TM)

-- What? Contradiction.

-- Should be used elsewhere instead of Int (of are they pre-alloc Int?).

-- public

type Binding = Int

-- TODO: Add usedBuffers to RenderIOState, ie Map.IntMap (s -> (Binding -> IO

--       (), Int)) and the like then create a function that checks that none of

--       the input buffers are used as output, and throws if it is


{- Contains the interactions between a GPipeShader and its environment. It is
populated when creating a GPipeShader and queried when compiling it into a
rendering action. In other words, it’s not a state at all, but some kind of
environment connector or adaptor. It is simply called a state because it build
using a State monad.
-}
-- public

data RenderIOState s = RenderIOState
    {   -- Uniform buffer objects bindings. TODO Return buffer name here when we

        -- start writing to buffers during rendering (transform feedback, buffer

        -- textures) -> Ok, but uniform only?

        RenderIOState s -> IntMap (s -> WinId -> IO ())
uniformNameToRenderIO :: Map.IntMap (s -> Binding -> IO ())
        -- Texture units bindings. IO returns texturename for validating that it

        -- isnt used as render target

    ,   RenderIOState s -> IntMap (s -> WinId -> IO WinId)
samplerNameToRenderIO :: Map.IntMap (s -> Binding -> IO Int)
        -- Final rasterization operations (mostly setting the viewport).

    ,   RenderIOState s -> IntMap (s -> IO ())
rasterizationNameToRenderIO :: Map.IntMap (s -> IO ())
        -- Final vertex processiong stage.

    ,   RenderIOState s -> IntMap (s -> GLuint -> IO ())
transformFeedbackToRenderIO :: Map.IntMap (s -> GLuint -> IO ())
        -- VAO bindings.

    ,   RenderIOState s
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
inputArrayToRenderIO :: Map.IntMap (s ->
        [   (   [Binding] -- inputs (drawcall's usedInputs)

            ,   GLuint -- primitive stream uniforms buffer

            ,   Int -- primitive stream uniforms buffer size

            ) ->
            (   (   IO [VAOKey] -- VAO names?

                ,   IO () -- To bind the VAO?

                )
            ,   IO () -- To draw with it.

            )
        ])
    }

-- public

newRenderIOState :: RenderIOState s
newRenderIOState :: RenderIOState s
newRenderIOState = IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO WinId)
-> IntMap (s -> IO ())
-> IntMap (s -> GLuint -> IO ())
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
-> RenderIOState s
forall s.
IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO WinId)
-> IntMap (s -> IO ())
-> IntMap (s -> GLuint -> IO ())
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
-> RenderIOState s
RenderIOState IntMap (s -> WinId -> IO ())
forall a. IntMap a
Map.empty IntMap (s -> WinId -> IO WinId)
forall a. IntMap a
Map.empty IntMap (s -> IO ())
forall a. IntMap a
Map.empty IntMap (s -> GLuint -> IO ())
forall a. IntMap a
Map.empty IntMap
  (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
forall a. IntMap a
Map.empty

-- Why 'map'? Wouldn’t 'inject' be a better name?

-- public

mapRenderIOState :: (s -> s') -> RenderIOState s' -> RenderIOState s -> RenderIOState s
mapRenderIOState :: (s -> s') -> RenderIOState s' -> RenderIOState s -> RenderIOState s
mapRenderIOState s -> s'
f (RenderIOState IntMap (s' -> WinId -> IO ())
a' IntMap (s' -> WinId -> IO WinId)
b' IntMap (s' -> IO ())
c' IntMap (s' -> GLuint -> IO ())
d' IntMap
  (s' -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
e') (RenderIOState IntMap (s -> WinId -> IO ())
a IntMap (s -> WinId -> IO WinId)
b IntMap (s -> IO ())
c IntMap (s -> GLuint -> IO ())
d IntMap
  (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
e) =
    let merge :: IntMap (s -> c) -> IntMap (s' -> c) -> IntMap (s -> c)
merge IntMap (s -> c)
x IntMap (s' -> c)
x' = IntMap (s -> c) -> IntMap (s -> c) -> IntMap (s -> c)
forall a. IntMap a -> IntMap a -> IntMap a
Map.union IntMap (s -> c)
x (IntMap (s -> c) -> IntMap (s -> c))
-> IntMap (s -> c) -> IntMap (s -> c)
forall a b. (a -> b) -> a -> b
$ ((s' -> c) -> s -> c) -> IntMap (s' -> c) -> IntMap (s -> c)
forall a b. (a -> b) -> IntMap a -> IntMap b
Map.map ((s' -> c) -> (s -> s') -> s -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s'
f) IntMap (s' -> c)
x'
    in  IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO WinId)
-> IntMap (s -> IO ())
-> IntMap (s -> GLuint -> IO ())
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
-> RenderIOState s
forall s.
IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO WinId)
-> IntMap (s -> IO ())
-> IntMap (s -> GLuint -> IO ())
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
-> RenderIOState s
RenderIOState (IntMap (s -> WinId -> IO ())
-> IntMap (s' -> WinId -> IO ()) -> IntMap (s -> WinId -> IO ())
forall c. IntMap (s -> c) -> IntMap (s' -> c) -> IntMap (s -> c)
merge IntMap (s -> WinId -> IO ())
a IntMap (s' -> WinId -> IO ())
a') (IntMap (s -> WinId -> IO WinId)
-> IntMap (s' -> WinId -> IO WinId)
-> IntMap (s -> WinId -> IO WinId)
forall c. IntMap (s -> c) -> IntMap (s' -> c) -> IntMap (s -> c)
merge IntMap (s -> WinId -> IO WinId)
b IntMap (s' -> WinId -> IO WinId)
b') (IntMap (s -> IO ()) -> IntMap (s' -> IO ()) -> IntMap (s -> IO ())
forall c. IntMap (s -> c) -> IntMap (s' -> c) -> IntMap (s -> c)
merge IntMap (s -> IO ())
c IntMap (s' -> IO ())
c') (IntMap (s -> GLuint -> IO ())
-> IntMap (s' -> GLuint -> IO ()) -> IntMap (s -> GLuint -> IO ())
forall c. IntMap (s -> c) -> IntMap (s' -> c) -> IntMap (s -> c)
merge IntMap (s -> GLuint -> IO ())
d IntMap (s' -> GLuint -> IO ())
d') (IntMap
  (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
-> IntMap
     (s' -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
forall c. IntMap (s -> c) -> IntMap (s' -> c) -> IntMap (s -> c)
merge IntMap
  (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
e IntMap
  (s' -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
e')

-- | May throw a GPipeException

-- The multiple drawcalls to be compiled are intended to use the same environment 's' (and only one is selected dynamically when rendering).

-- public

compileDrawcalls :: (Monad m, MonadIO m, MonadException m, ContextHandler ctx)
    => [IO (Drawcall s)] -- The proto drawcalls to generate and compile.

    -> RenderIOState s -- Interactions between the drawcalls and the environment 's'.

    -> ContextT ctx os m (s -> Render os ()) -- The compiled drawcall (OpenGL program shader actually) as a function on an environment.

compileDrawcalls :: [IO (Drawcall s)]
-> RenderIOState s -> ContextT ctx os m (s -> Render os ())
compileDrawcalls [IO (Drawcall s)]
protoDrawcalls RenderIOState s
state = do

    ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])]
drawcalls, [String]
limitErrors) <- IO ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
-> ContextT
     ctx
     os
     m
     ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
forall ctx (m :: * -> *) a os.
(ContextHandler ctx, MonadIO m) =>
IO a -> ContextT ctx os m a
liftNonWinContextIO (IO ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
 -> ContextT
      ctx
      os
      m
      ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String]))
-> IO
     ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
-> ContextT
     ctx
     os
     m
     ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
forall a b. (a -> b) -> a -> b
$ [IO (Drawcall s)]
-> IO
     ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
forall s.
[IO (Drawcall s)]
-> IO
     ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
safeGenerateDrawcalls [IO (Drawcall s)]
protoDrawcalls
    [Either String ((IORef GLuint, IO ()), s -> Render os ())]
compilationResults <- IO [Either String ((IORef GLuint, IO ()), s -> Render os ())]
-> ContextT
     ctx os m [Either String ((IORef GLuint, IO ()), s -> Render os ())]
forall ctx (m :: * -> *) a os.
(ContextHandler ctx, MonadIO m) =>
IO a -> ContextT ctx os m a
liftNonWinContextIO (IO [Either String ((IORef GLuint, IO ()), s -> Render os ())]
 -> ContextT
      ctx
      os
      m
      [Either String ((IORef GLuint, IO ()), s -> Render os ())])
-> IO [Either String ((IORef GLuint, IO ()), s -> Render os ())]
-> ContextT
     ctx os m [Either String ((IORef GLuint, IO ()), s -> Render os ())]
forall a b. (a -> b) -> a -> b
$ ((Drawcall s, [WinId], [WinId], [WinId], [WinId])
 -> IO (Either String ((IORef GLuint, IO ()), s -> Render os ())))
-> [(Drawcall s, [WinId], [WinId], [WinId], [WinId])]
-> IO [Either String ((IORef GLuint, IO ()), s -> Render os ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RenderIOState s
-> (Drawcall s, [WinId], [WinId], [WinId], [WinId])
-> IO (Either String ((IORef GLuint, IO ()), s -> Render os ()))
forall s os.
RenderIOState s
-> (Drawcall s, [WinId], [WinId], [WinId], [WinId])
-> IO (Either String ((IORef GLuint, IO ()), s -> Render os ()))
innerCompile RenderIOState s
state) [(Drawcall s, [WinId], [WinId], [WinId], [WinId])]
drawcalls
    let ([String]
compilationErrors, [((IORef GLuint, IO ()), s -> Render os ())]
compiledDrawcalls) = [Either String ((IORef GLuint, IO ()), s -> Render os ())]
-> ([String], [((IORef GLuint, IO ()), s -> Render os ())])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either String ((IORef GLuint, IO ()), s -> Render os ())]
compilationResults
        ([(IORef GLuint, IO ())]
programNameAndDeleters, [s -> Render os ()]
renderers) = [((IORef GLuint, IO ()), s -> Render os ())]
-> ([(IORef GLuint, IO ())], [s -> Render os ()])
forall a b. [(a, b)] -> ([a], [b])
unzip [((IORef GLuint, IO ()), s -> Render os ())]
compiledDrawcalls
        compositeRenderer :: s -> Render os ()
compositeRenderer s
x = ((s -> Render os ()) -> Render os ())
-> [s -> Render os ()] -> Render os ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((s -> Render os ()) -> s -> Render os ()
forall a b. (a -> b) -> a -> b
$ s
x) [s -> Render os ()]
renderers
        allErrors :: [String]
allErrors = [String]
limitErrors [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
compilationErrors

    if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
allErrors
        then do
            -- Register each deleter separately on their program finalization.

            [(IORef GLuint, IO ())]
-> ((IORef GLuint, IO ()) -> ContextT ctx os m ())
-> ContextT ctx os m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(IORef GLuint, IO ())]
programNameAndDeleters (((IORef GLuint, IO ()) -> ContextT ctx os m ())
 -> ContextT ctx os m ())
-> ((IORef GLuint, IO ()) -> ContextT ctx os m ())
-> ContextT ctx os m ()
forall a b. (a -> b) -> a -> b
$ \ (IORef GLuint
programNameRef, IO ()
deleter) -> do
                GLuint
programName <- IO GLuint -> ContextT ctx os m GLuint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GLuint -> ContextT ctx os m GLuint)
-> IO GLuint -> ContextT ctx os m GLuint
forall a b. (a -> b) -> a -> b
$ IORef GLuint -> IO GLuint
forall a. IORef a -> IO a
readIORef IORef GLuint
programNameRef
                IORef GLuint -> IO () -> ContextT ctx os m ()
forall ctx (m :: * -> *) a os.
(ContextHandler ctx, MonadIO m) =>
IORef a -> IO () -> ContextT ctx os m ()
addContextFinalizer IORef GLuint
programNameRef IO ()
deleter
            -- Return a composite rendering action.

            (s -> Render os ()) -> ContextT ctx os m (s -> Render os ())
forall (m :: * -> *) a. Monad m => a -> m a
return s -> Render os ()
compositeRenderer
        else do
            -- Directly call all the deleters.

            IO () -> ContextT ctx os m ()
forall ctx (m :: * -> *) os.
(ContextHandler ctx, MonadIO m) =>
IO () -> ContextT ctx os m ()
liftNonWinContextAsyncIO (IO () -> ContextT ctx os m ()) -> IO () -> ContextT ctx os m ()
forall a b. (a -> b) -> a -> b
$ [(IORef GLuint, IO ())]
-> ((IORef GLuint, IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(IORef GLuint, IO ())]
programNameAndDeleters (((IORef GLuint, IO ()) -> IO ()) -> IO ())
-> ((IORef GLuint, IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ (IORef GLuint
_, IO ()
deleter) -> do
                IO ()
deleter
            -- Raise an error.

            IO (s -> Render os ()) -> ContextT ctx os m (s -> Render os ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (s -> Render os ()) -> ContextT ctx os m (s -> Render os ()))
-> IO (s -> Render os ()) -> ContextT ctx os m (s -> Render os ())
forall a b. (a -> b) -> a -> b
$ GPipeException -> IO (s -> Render os ())
forall e a. Exception e => e -> IO a
throwIO (GPipeException -> IO (s -> Render os ()))
-> GPipeException -> IO (s -> Render os ())
forall a b. (a -> b) -> a -> b
$ String -> GPipeException
GPipeException (String -> GPipeException) -> String -> GPipeException
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
allErrors

{- Generate the drawcalls (a single one each time in fact) and check their
inputs don't exceed some OpenGL limits.
-}
-- private

safeGenerateDrawcalls :: [IO (Drawcall s)] -- The proto drawcalls to generate.

    ->  IO (
        [   (   Drawcall s -- A generated drawcall.

            ,   [Int] -- Its uniform buffers used.

            ,   [Int] -- Its textures units used.

            ,   [Int] -- Its allocated uniforms.

            ,   [Int] -- Its allocated texture units.

            )
        ]
        , [String] -- The raised errors regarding exceeded limits.

        )
safeGenerateDrawcalls :: [IO (Drawcall s)]
-> IO
     ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
safeGenerateDrawcalls [IO (Drawcall s)]
protoDrawcalls = do

    -- Retrieve some limits from OpenGL.

    [   WinId
maxGUnis, WinId
maxGSamplers,
        WinId
maxVUnis, WinId
maxVSamplers,
        WinId
maxFUnis, WinId
maxFSamplers,
        WinId
maxUnis, WinId
maxSamplers ]
        <- IO [WinId] -> IO [WinId]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [WinId] -> IO [WinId]) -> IO [WinId] -> IO [WinId]
forall a b. (a -> b) -> a -> b
$
            (GLuint -> IO WinId) -> [GLuint] -> IO [WinId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\GLuint
t -> GLint -> WinId
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLint -> WinId) -> IO GLint -> IO WinId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr GLint -> IO GLint) -> IO GLint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca (\ Ptr GLint
ptr -> GLuint -> Ptr GLint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> Ptr GLint -> m ()
glGetIntegerv GLuint
t Ptr GLint
ptr IO () -> IO GLint -> IO GLint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLint -> IO GLint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLint
ptr))
                [ GLuint
forall a. (Eq a, Num a) => a
GL_MAX_GEOMETRY_UNIFORM_BLOCKS
                , GLuint
forall a. (Eq a, Num a) => a
GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS
                , GLuint
forall a. (Eq a, Num a) => a
GL_MAX_VERTEX_UNIFORM_BLOCKS
                , GLuint
forall a. (Eq a, Num a) => a
GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS
                , GLuint
forall a. (Eq a, Num a) => a
GL_MAX_FRAGMENT_UNIFORM_BLOCKS
                , GLuint
forall a. (Eq a, Num a) => a
GL_MAX_TEXTURE_IMAGE_UNITS
                , GLuint
forall a. (Eq a, Num a) => a
GL_MAX_COMBINED_UNIFORM_BLOCKS
                , GLuint
forall a. (Eq a, Num a) => a
GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS
                ]

    -- Build the drawcalls.

    [Drawcall s]
drawcalls <- IO [Drawcall s] -> IO [Drawcall s]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Drawcall s] -> IO [Drawcall s])
-> IO [Drawcall s] -> IO [Drawcall s]
forall a b. (a -> b) -> a -> b
$ [IO (Drawcall s)] -> IO [Drawcall s]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [IO (Drawcall s)]
protoDrawcalls -- IO only for SNMap


    let
        -- Collect stats from the drawcalls (bound uniforms and texture units).

        gUnisPerDrawcall :: [[WinId]]
gUnisPerDrawcall = (Drawcall s -> [WinId]) -> [Drawcall s] -> [[WinId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [WinId]
forall s. Drawcall s -> [WinId]
usedGUniforms [Drawcall s]
drawcalls
        gSampsPerDrawcall :: [[WinId]]
gSampsPerDrawcall = (Drawcall s -> [WinId]) -> [Drawcall s] -> [[WinId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [WinId]
forall s. Drawcall s -> [WinId]
usedGSamplers [Drawcall s]
drawcalls
        vUnisPerDrawcall :: [[WinId]]
vUnisPerDrawcall = (Drawcall s -> [WinId]) -> [Drawcall s] -> [[WinId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [WinId]
forall s. Drawcall s -> [WinId]
usedVUniforms [Drawcall s]
drawcalls
        vSampsPerDrawcall :: [[WinId]]
vSampsPerDrawcall = (Drawcall s -> [WinId]) -> [Drawcall s] -> [[WinId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [WinId]
forall s. Drawcall s -> [WinId]
usedVSamplers [Drawcall s]
drawcalls
        fUnisPerDrawcall :: [[WinId]]
fUnisPerDrawcall = (Drawcall s -> [WinId]) -> [Drawcall s] -> [[WinId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [WinId]
forall s. Drawcall s -> [WinId]
usedFUniforms [Drawcall s]
drawcalls
        fSampsPerDrawcall :: [[WinId]]
fSampsPerDrawcall = (Drawcall s -> [WinId]) -> [Drawcall s] -> [[WinId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [WinId]
forall s. Drawcall s -> [WinId]
usedFSamplers [Drawcall s]
drawcalls

        -- Consolidate them for the whole program.

        unisPerDrawcall :: [[WinId]]
unisPerDrawcall = ([WinId] -> [WinId] -> [WinId])
-> [[WinId]] -> [[WinId]] -> [[WinId]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [WinId] -> [WinId] -> [WinId]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion (([WinId] -> [WinId] -> [WinId])
-> [[WinId]] -> [[WinId]] -> [[WinId]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [WinId] -> [WinId] -> [WinId]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion [[WinId]]
gUnisPerDrawcall [[WinId]]
vUnisPerDrawcall) [[WinId]]
fUnisPerDrawcall
        sampsPerDrawcall :: [[WinId]]
sampsPerDrawcall = ([WinId] -> [WinId] -> [WinId])
-> [[WinId]] -> [[WinId]] -> [[WinId]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [WinId] -> [WinId] -> [WinId]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion (([WinId] -> [WinId] -> [WinId])
-> [[WinId]] -> [[WinId]] -> [[WinId]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [WinId] -> [WinId] -> [WinId]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion [[WinId]]
gSampsPerDrawcall [[WinId]]
vSampsPerDrawcall) [[WinId]]
fSampsPerDrawcall

        -- Produce an error message for each limit exceeded by at least one of the drawcalls.

        limitErrors :: [String]
limitErrors = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [String
"Too many uniform blocks used in a single geometry shader\n" | ([WinId] -> Bool) -> [[WinId]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ [WinId]
xs -> [WinId] -> WinId
forall (t :: * -> *) a. Foldable t => t a -> WinId
length [WinId]
xs WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
>= WinId
maxGUnis) [[WinId]]
gUnisPerDrawcall]
            , [String
"Too many textures used in a single geometry shader\n" | ([WinId] -> Bool) -> [[WinId]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ [WinId]
xs -> [WinId] -> WinId
forall (t :: * -> *) a. Foldable t => t a -> WinId
length [WinId]
xs WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
>= WinId
maxGSamplers) [[WinId]]
gSampsPerDrawcall]
            , [String
"Too many uniform blocks used in a single vertex shader\n" | ([WinId] -> Bool) -> [[WinId]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ [WinId]
xs -> [WinId] -> WinId
forall (t :: * -> *) a. Foldable t => t a -> WinId
length [WinId]
xs WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
>= WinId
maxVUnis) [[WinId]]
vUnisPerDrawcall]
            , [String
"Too many textures used in a single vertex shader\n" | ([WinId] -> Bool) -> [[WinId]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ [WinId]
xs -> [WinId] -> WinId
forall (t :: * -> *) a. Foldable t => t a -> WinId
length [WinId]
xs WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
>= WinId
maxVSamplers) [[WinId]]
vSampsPerDrawcall]
            , [String
"Too many uniform blocks used in a single fragment shader\n" | ([WinId] -> Bool) -> [[WinId]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ [WinId]
xs -> [WinId] -> WinId
forall (t :: * -> *) a. Foldable t => t a -> WinId
length [WinId]
xs WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
>= WinId
maxFUnis) [[WinId]]
fUnisPerDrawcall]
            , [String
"Too many textures used in a single fragment shader\n" | ([WinId] -> Bool) -> [[WinId]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ [WinId]
xs -> [WinId] -> WinId
forall (t :: * -> *) a. Foldable t => t a -> WinId
length [WinId]
xs WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
>= WinId
maxFSamplers) [[WinId]]
fSampsPerDrawcall]
            , [String
"Too many uniform blocks used in a single shader program\n" | ([WinId] -> Bool) -> [[WinId]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ [WinId]
xs -> [WinId] -> WinId
forall (t :: * -> *) a. Foldable t => t a -> WinId
length [WinId]
xs WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
>= WinId
maxUnis) [[WinId]]
unisPerDrawcall]
            , [String
"Too many textures used in a single shader program\n" | ([WinId] -> Bool) -> [[WinId]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ [WinId]
xs -> [WinId] -> WinId
forall (t :: * -> *) a. Foldable t => t a -> WinId
length [WinId]
xs WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
>= WinId
maxSamplers) [[WinId]]
sampsPerDrawcall]
            ]

        allocatedUniforms :: [[WinId]]
allocatedUniforms = WinId -> [[WinId]] -> [[WinId]]
allocateConsecutiveIndexes WinId
maxUnis [[WinId]]
unisPerDrawcall
        allocatedSamplers :: [[WinId]]
allocatedSamplers = WinId -> [[WinId]] -> [[WinId]]
allocateConsecutiveIndexes WinId
maxSamplers [[WinId]]
sampsPerDrawcall

    ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
-> IO
     ([(Drawcall s, [WinId], [WinId], [WinId], [WinId])], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Drawcall s]
-> [[WinId]]
-> [[WinId]]
-> [[WinId]]
-> [[WinId]]
-> [(Drawcall s, [WinId], [WinId], [WinId], [WinId])]
forall a b c d e.
[a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]
zip5 [Drawcall s]
drawcalls [[WinId]]
unisPerDrawcall [[WinId]]
sampsPerDrawcall [[WinId]]
allocatedUniforms [[WinId]]
allocatedSamplers, [String]
limitErrors)

-- private

innerCompile :: RenderIOState s -- Interactions between the drawcall and the environment 's'.

    ->  ( Drawcall s -- A drawcall with:

        , [Int] -- its uniform buffers used,

        , [Int] -- its textures units used,

        , [Int] -- its allocated uniforms,

        , [Int] -- its allocated texture units.

        )
    ->  IO
        ( Either
            String -- A failure in case the program cannot be compiled in linked.

            ( (IORef GLuint, IO ()) -- The program name and its destructor.

            , s -> Render os () -- The program's renderer as a function on a render (OpenGL) state. Upper stage called this a 'CompiledShader'.

            )
        )
innerCompile :: RenderIOState s
-> (Drawcall s, [WinId], [WinId], [WinId], [WinId])
-> IO (Either String ((IORef GLuint, IO ()), s -> Render os ()))
innerCompile RenderIOState s
state (Drawcall s
drawcall, [WinId]
unis, [WinId]
samps, [WinId]
ubinds, [WinId]
sbinds) = do
    let vsource :: String
vsource = Drawcall s -> String
forall s. Drawcall s -> String
vertexSource Drawcall s
drawcall
        ogsource :: Maybe String
ogsource = Drawcall s -> Maybe String
forall s. Drawcall s -> Maybe String
optionalGeometrySource Drawcall s
drawcall
        ofsource :: Maybe String
ofsource = Drawcall s -> Maybe String
forall s. Drawcall s -> Maybe String
optionalFragmentSource Drawcall s
drawcall
        inputs :: [WinId]
inputs = Drawcall s -> [WinId]
forall s. Drawcall s -> [WinId]
usedInputs Drawcall s
drawcall

    -- Compile and link the shader program.

    Either String GLuint
errorOrProgramName <- do
        -- Compile the vertex shader.

        GLuint
vShader <- GLuint -> IO GLuint
forall (m :: * -> *). MonadIO m => GLuint -> m GLuint
glCreateShader GLuint
forall a. (Eq a, Num a) => a
GL_VERTEX_SHADER
        Maybe String
mErrV <- GLuint -> String -> IO (Maybe String)
compileOpenGlShader GLuint
vShader String
vsource
        -- Compile the optional geometry shader.

        (Maybe GLuint
ogShader, Maybe String
mErrG) <- case Maybe String
ogsource of
            Maybe String
Nothing -> (Maybe GLuint, Maybe String) -> IO (Maybe GLuint, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe GLuint
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)
            Just String
gsource -> do
                GLuint
gShader <- GLuint -> IO GLuint
forall (m :: * -> *). MonadIO m => GLuint -> m GLuint
glCreateShader GLuint
forall a. (Eq a, Num a) => a
GL_GEOMETRY_SHADER
                Maybe String
mErrG <- GLuint -> String -> IO (Maybe String)
compileOpenGlShader GLuint
gShader String
gsource
                (Maybe GLuint, Maybe String) -> IO (Maybe GLuint, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLuint -> Maybe GLuint
forall a. a -> Maybe a
Just GLuint
gShader, Maybe String
mErrG)
        -- Compile the fragment shader.

        (Maybe GLuint
ofShader, Maybe String
mErrF) <- case Maybe String
ofsource of
            Maybe String
Nothing -> (Maybe GLuint, Maybe String) -> IO (Maybe GLuint, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe GLuint
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)
            Just String
fsource -> do
                GLuint
fShader <- GLuint -> IO GLuint
forall (m :: * -> *). MonadIO m => GLuint -> m GLuint
glCreateShader GLuint
forall a. (Eq a, Num a) => a
GL_FRAGMENT_SHADER
                Maybe String
mErrF <- GLuint -> String -> IO (Maybe String)
compileOpenGlShader GLuint
fShader String
fsource
                (Maybe GLuint, Maybe String) -> IO (Maybe GLuint, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLuint -> Maybe GLuint
forall a. a -> Maybe a
Just GLuint
fShader, Maybe String
mErrF)

        if (Maybe String -> Bool) -> [Maybe String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe String
mErrV, Maybe String
mErrG, Maybe String
mErrF]
            then do
                GLuint
pName <- IO GLuint
forall (m :: * -> *). MonadIO m => m GLuint
glCreateProgram
                GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glAttachShader GLuint
pName GLuint
vShader

                Maybe GLuint -> (GLuint -> IO ()) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
Maybe a -> (a -> m b) -> m b
whenJust' Maybe GLuint
ogShader ((GLuint -> IO ()) -> IO ()) -> (GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glAttachShader GLuint
pName
                Maybe GLuint -> (GLuint -> IO ()) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
Maybe a -> (a -> m b) -> m b
whenJust' Maybe GLuint
ofShader ((GLuint -> IO ()) -> IO ()) -> (GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glAttachShader GLuint
pName
                ((WinId, GLuint) -> IO ()) -> [(WinId, GLuint)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(WinId
name, GLuint
ix) -> String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString (String
"in"String -> String -> String
forall a. [a] -> [a] -> [a]
++ WinId -> String
forall a. Show a => a -> String
show WinId
name) ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> CString -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> CString -> m ()
glBindAttribLocation GLuint
pName GLuint
ix) ([(WinId, GLuint)] -> IO ()) -> [(WinId, GLuint)] -> IO ()
forall a b. (a -> b) -> a -> b
$ [WinId] -> [GLuint] -> [(WinId, GLuint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WinId]
inputs [GLuint
0..]

                case (Drawcall s -> Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
forall s.
Drawcall s -> Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
feedbackBuffer Drawcall s
drawcall, Drawcall s -> Maybe WinId
forall s. Drawcall s -> Maybe WinId
rasterizationName Drawcall s
drawcall) of
                    (Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
Nothing, Just WinId
_) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    (Just s -> IO (GLuint, GLuint, GLuint, GLuint)
_, Just WinId
geoN) -> (RenderIOState s -> IntMap (s -> GLuint -> IO ())
forall s. RenderIOState s -> IntMap (s -> GLuint -> IO ())
transformFeedbackToRenderIO RenderIOState s
state IntMap (s -> GLuint -> IO ()) -> WinId -> s -> GLuint -> IO ()
forall a. IntMap a -> WinId -> a
! WinId
geoN) s
forall a. HasCallStack => a
undefined GLuint
pName

                Maybe String
mPErr <- GLuint -> IO (Maybe String)
linkProgram GLuint
pName

                GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glDetachShader GLuint
pName GLuint
vShader
                Maybe GLuint -> (GLuint -> IO ()) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
Maybe a -> (a -> m b) -> m b
whenJust' Maybe GLuint
ogShader ((GLuint -> IO ()) -> IO ()) -> (GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glDetachShader GLuint
pName
                Maybe GLuint -> (GLuint -> IO ()) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
Maybe a -> (a -> m b) -> m b
whenJust' Maybe GLuint
ofShader ((GLuint -> IO ()) -> IO ()) -> (GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glDetachShader GLuint
pName

                GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteShader GLuint
vShader
                Maybe GLuint -> (GLuint -> IO ()) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
Maybe a -> (a -> m b) -> m b
whenJust' Maybe GLuint
ogShader GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteShader
                Maybe GLuint -> (GLuint -> IO ()) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
Maybe a -> (a -> m b) -> m b
whenJust' Maybe GLuint
ofShader GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteShader

                case Maybe String
mPErr of
                    Just String
errP -> do
                        GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteProgram GLuint
pName
                        Either String GLuint -> IO (Either String GLuint)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GLuint -> IO (Either String GLuint))
-> Either String GLuint -> IO (Either String GLuint)
forall a b. (a -> b) -> a -> b
$ String -> Either String GLuint
forall a b. a -> Either a b
Left (String -> Either String GLuint) -> String -> Either String GLuint
forall a b. (a -> b) -> a -> b
$ String
"Linking a GPU progam failed:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errP String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                            [ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
e -> String
"\nVertex source:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") (String -> Maybe String
forall a. a -> Maybe a
Just String
vsource)
                            , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
e -> String
"\nGeometry source:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") Maybe String
ogsource
                            , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
e -> String
"\nFragment source:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n") Maybe String
ofsource
                            ]
                    Maybe String
Nothing -> Either String GLuint -> IO (Either String GLuint)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GLuint -> IO (Either String GLuint))
-> Either String GLuint -> IO (Either String GLuint)
forall a b. (a -> b) -> a -> b
$ GLuint -> Either String GLuint
forall a b. b -> Either a b
Right GLuint
pName
            else do
                GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteShader GLuint
vShader
                Maybe GLuint -> (GLuint -> IO ()) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
Maybe a -> (a -> m b) -> m b
whenJust' Maybe GLuint
ogShader GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteShader
                Maybe GLuint -> (GLuint -> IO ()) -> IO ()
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
Maybe a -> (a -> m b) -> m b
whenJust' Maybe GLuint
ofShader GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteShader

                let err :: String
err = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                        [ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
e -> String
"A vertex shader compilation failed:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nSource:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vsource) Maybe String
mErrV
                        , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
e -> String
"A geometry shader compilation failed:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nSource:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
ogsource) Maybe String
mErrG
                        , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
e -> String
"A fragment shader compilation failed:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nSource:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
ofsource) Maybe String
mErrF
                        ]
                Either String GLuint -> IO (Either String GLuint)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GLuint -> IO (Either String GLuint))
-> Either String GLuint -> IO (Either String GLuint)
forall a b. (a -> b) -> a -> b
$ String -> Either String GLuint
forall a b. a -> Either a b
Left String
err

    case Either String GLuint
errorOrProgramName of
        -- Left: the failure.

        Left String
err -> Either String ((IORef GLuint, IO ()), s -> Render os ())
-> IO (Either String ((IORef GLuint, IO ()), s -> Render os ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ((IORef GLuint, IO ()), s -> Render os ())
 -> IO (Either String ((IORef GLuint, IO ()), s -> Render os ())))
-> Either String ((IORef GLuint, IO ()), s -> Render os ())
-> IO (Either String ((IORef GLuint, IO ()), s -> Render os ()))
forall a b. (a -> b) -> a -> b
$ String -> Either String ((IORef GLuint, IO ()), s -> Render os ())
forall a b. a -> Either a b
Left String
err
        -- Right: the program wrapped in a Render monad.

        Right GLuint
pName -> ((IORef GLuint, IO ()), s -> Render os ())
-> Either String ((IORef GLuint, IO ()), s -> Render os ())
forall a b. b -> Either a b
Right (((IORef GLuint, IO ()), s -> Render os ())
 -> Either String ((IORef GLuint, IO ()), s -> Render os ()))
-> IO ((IORef GLuint, IO ()), s -> Render os ())
-> IO (Either String ((IORef GLuint, IO ()), s -> Render os ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case (Drawcall s -> Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
forall s.
Drawcall s -> Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
feedbackBuffer Drawcall s
drawcall, Drawcall s -> Maybe WinId
forall s. Drawcall s -> Maybe WinId
rasterizationName Drawcall s
drawcall) of
            (Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
Nothing, Just WinId
rastN) -> RenderIOState s
-> (Drawcall s, [WinId], [WinId], [WinId], [WinId])
-> GLuint
-> WinId
-> IO ((IORef GLuint, IO ()), s -> Render os ())
forall s os.
RenderIOState s
-> (Drawcall s, [WinId], [WinId], [WinId], [WinId])
-> GLuint
-> WinId
-> IO ((IORef GLuint, IO ()), s -> Render os ())
createRenderer RenderIOState s
state (Drawcall s
drawcall, [WinId]
unis, [WinId]
ubinds, [WinId]
samps, [WinId]
sbinds) GLuint
pName WinId
rastN
            (Just s -> IO (GLuint, GLuint, GLuint, GLuint)
getTransformFeedbackName, Just WinId
geoN) -> RenderIOState s
-> (Drawcall s, [WinId], [WinId], [WinId], [WinId])
-> GLuint
-> (s -> IO (GLuint, GLuint, GLuint, GLuint))
-> WinId
-> IO ((IORef GLuint, IO ()), s -> Render os ())
forall s os.
RenderIOState s
-> (Drawcall s, [WinId], [WinId], [WinId], [WinId])
-> GLuint
-> (s -> IO (GLuint, GLuint, GLuint, GLuint))
-> WinId
-> IO ((IORef GLuint, IO ()), s -> Render os ())
createFeedbackRenderer RenderIOState s
state (Drawcall s
drawcall, [WinId]
unis, [WinId]
ubinds, [WinId]
samps, [WinId]
sbinds) GLuint
pName s -> IO (GLuint, GLuint, GLuint, GLuint)
getTransformFeedbackName WinId
geoN
            (Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint)), Maybe WinId)
_ -> String -> IO ((IORef GLuint, IO ()), s -> Render os ())
forall a. HasCallStack => String -> a
error String
"No rasterization nor feedback!"

-- private

createRenderer :: RenderIOState s -- Interactions between the drawcall and the environment 's'.

    ->  ( Drawcall s -- A drawcall with:

        , [Int] -- its uniform buffers used,

        , [Int] -- its textures units used,

        , [Int] -- its allocated uniforms,

        , [Int] -- its allocated texture units.

        )
    ->  GLuint -- pName

    ->  Int
    ->  IO  ( (IORef GLuint, IO ()) -- The program name and its destructor.

            , s -> Render os () -- The program's renderer as a function on a render (OpenGL) state.

            )
createRenderer :: RenderIOState s
-> (Drawcall s, [WinId], [WinId], [WinId], [WinId])
-> GLuint
-> WinId
-> IO ((IORef GLuint, IO ()), s -> Render os ())
createRenderer RenderIOState s
state (Drawcall s
drawcall, [WinId]
unis, [WinId]
ubinds, [WinId]
samps, [WinId]
sbinds) GLuint
pName WinId
rastN = do
    let fboSetup :: s -> (Either WinId (IO FBOKeys, IO ()), IO ())
fboSetup = Drawcall s -> s -> (Either WinId (IO FBOKeys, IO ()), IO ())
forall s.
Drawcall s -> s -> (Either WinId (IO FBOKeys, IO ()), IO ())
drawcallFbo Drawcall s
drawcall
        primN :: WinId
primN = Drawcall s -> WinId
forall s. Drawcall s -> WinId
primitiveName Drawcall s
drawcall
        inputs :: [WinId]
inputs = Drawcall s -> [WinId]
forall s. Drawcall s -> [WinId]
usedInputs Drawcall s
drawcall
        pstrUSize :: WinId
pstrUSize = Drawcall s -> WinId
forall s. Drawcall s -> WinId
primStrUBufferSize Drawcall s
drawcall

    let pstrUSize' :: WinId
pstrUSize' = if WinId
0 WinId -> [WinId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WinId]
unis then WinId
pstrUSize else WinId
0
    GLuint
pstrUBuf <- WinId -> IO GLuint
forall a. Integral a => a -> IO GLuint
createUniformBuffer WinId
pstrUSize' -- Create uniform buffer for primiveStream uniforms


    [(WinId, WinId)] -> ((WinId, WinId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([WinId] -> [WinId] -> [(WinId, WinId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WinId]
unis [WinId]
ubinds) (((WinId, WinId) -> IO ()) -> IO ())
-> ((WinId, WinId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(WinId
name, WinId
bind) -> do
        GLuint
uix <- String -> (CString -> IO GLuint) -> IO GLuint
forall a. String -> (CString -> IO a) -> IO a
withCString (String
"uBlock" String -> String -> String
forall a. [a] -> [a] -> [a]
++ WinId -> String
forall a. Show a => a -> String
show WinId
name) ((CString -> IO GLuint) -> IO GLuint)
-> (CString -> IO GLuint) -> IO GLuint
forall a b. (a -> b) -> a -> b
$ GLuint -> CString -> IO GLuint
forall (m :: * -> *). MonadIO m => GLuint -> CString -> m GLuint
glGetUniformBlockIndex GLuint
pName
        GLuint -> GLuint -> GLuint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> GLuint -> m ()
glUniformBlockBinding GLuint
pName GLuint
uix (WinId -> GLuint
forall a b. (Integral a, Num b) => a -> b
fromIntegral WinId
bind)

    GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glUseProgram GLuint
pName -- For setting texture uniforms

    [(WinId, WinId)] -> ((WinId, WinId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([WinId] -> [WinId] -> [(WinId, WinId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WinId]
samps [WinId]
sbinds) (((WinId, WinId) -> IO ()) -> IO ())
-> ((WinId, WinId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(WinId
name, WinId
bind) -> do
        GLint
six <- String -> (CString -> IO GLint) -> IO GLint
forall a. String -> (CString -> IO a) -> IO a
withCString (String
"s" String -> String -> String
forall a. [a] -> [a] -> [a]
++ WinId -> String
forall a. Show a => a -> String
show WinId
name) ((CString -> IO GLint) -> IO GLint)
-> (CString -> IO GLint) -> IO GLint
forall a b. (a -> b) -> a -> b
$ GLuint -> CString -> IO GLint
forall (m :: * -> *). MonadIO m => GLuint -> CString -> m GLint
glGetUniformLocation GLuint
pName
        GLint -> GLint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> GLint -> m ()
glUniform1i GLint
six (WinId -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral WinId
bind)
    IORef GLuint
pNameRef <- GLuint -> IO (IORef GLuint)
forall a. a -> IO (IORef a)
newIORef GLuint
pName

    let uNameToRenderIOMap :: IntMap (s -> WinId -> IO ())
uNameToRenderIOMap = RenderIOState s -> IntMap (s -> WinId -> IO ())
forall s. RenderIOState s -> IntMap (s -> WinId -> IO ())
uniformNameToRenderIO RenderIOState s
state
        uNameToRenderIOMap' :: IntMap (s -> WinId -> IO ())
uNameToRenderIOMap' = GLuint
-> WinId
-> IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO ())
forall s.
GLuint
-> WinId
-> IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO ())
addPrimitiveStreamUniform GLuint
pstrUBuf WinId
pstrUSize' IntMap (s -> WinId -> IO ())
uNameToRenderIOMap

    -- Drawing with the program.

    let renderer :: s -> Render os ()
renderer = \s
x -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
-> Render os ()
forall os a.
ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) a
-> Render os a
Render (ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
 -> Render os ())
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
-> Render os ()
forall a b. (a -> b) -> a -> b
$ do
            RenderState
rs <- ReaderT RenderEnv (StateT RenderState IO) RenderState
-> ExceptT
     String (ReaderT RenderEnv (StateT RenderState IO)) RenderState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT RenderEnv (StateT RenderState IO) RenderState
 -> ExceptT
      String (ReaderT RenderEnv (StateT RenderState IO)) RenderState)
-> ReaderT RenderEnv (StateT RenderState IO) RenderState
-> ExceptT
     String (ReaderT RenderEnv (StateT RenderState IO)) RenderState
forall a b. (a -> b) -> a -> b
$ StateT RenderState IO RenderState
-> ReaderT RenderEnv (StateT RenderState IO) RenderState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT RenderState IO RenderState
forall (m :: * -> *) s. Monad m => StateT s m s
get
            RenderEnv
renv <- ReaderT RenderEnv (StateT RenderState IO) RenderEnv
-> ExceptT
     String (ReaderT RenderEnv (StateT RenderState IO)) RenderEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT RenderEnv (StateT RenderState IO) RenderEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
            let (Either WinId (IO FBOKeys, IO ())
mFboKeyIO, IO ()
blendIO) = s -> (Either WinId (IO FBOKeys, IO ()), IO ())
fboSetup s
x

            let inwin :: WinId
-> IO (Maybe String)
-> ExceptT String (t (StateT RenderState m)) ()
inwin WinId
windowId IO (Maybe String)
m = do
                    case WinId
-> IntMap (WindowState, ContextDoAsync)
-> Maybe (WindowState, ContextDoAsync)
forall a. WinId -> IntMap a -> Maybe a
Map.lookup WinId
windowId (RenderState -> IntMap (WindowState, ContextDoAsync)
perWindowRenderState RenderState
rs) of
                        Maybe (WindowState, ContextDoAsync)
Nothing -> () -> ExceptT String (t (StateT RenderState m)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Window deleted

                        Just (WindowState
ws, ContextDoAsync
doAsync) -> do
                            t (StateT RenderState m) ()
-> ExceptT String (t (StateT RenderState m)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (t (StateT RenderState m) ()
 -> ExceptT String (t (StateT RenderState m)) ())
-> t (StateT RenderState m) ()
-> ExceptT String (t (StateT RenderState m)) ()
forall a b. (a -> b) -> a -> b
$ StateT RenderState m () -> t (StateT RenderState m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT RenderState m () -> t (StateT RenderState m) ())
-> StateT RenderState m () -> t (StateT RenderState m) ()
forall a b. (a -> b) -> a -> b
$ RenderState -> StateT RenderState m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (RenderState
rs { renderLastUsedWin :: WinId
renderLastUsedWin = WinId
windowId })
                            Maybe String
mErr <- IO (Maybe String)
-> ExceptT String (t (StateT RenderState m)) (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String)
 -> ExceptT String (t (StateT RenderState m)) (Maybe String))
-> IO (Maybe String)
-> ExceptT String (t (StateT RenderState m)) (Maybe String)
forall a b. (a -> b) -> a -> b
$ ContextDoAsync -> IO (Maybe String) -> IO (Maybe String)
forall x. ContextDoAsync -> IO x -> IO x
asSync ContextDoAsync
doAsync (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
                                GLuint
pName' <- IORef GLuint -> IO GLuint
forall a. IORef a -> IO a
readIORef IORef GLuint
pNameRef -- Cant use pName, need to touch pNameRef

                                GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glUseProgram GLuint
pName'
                                Bool
True <- IntMap (s -> WinId -> IO ())
-> [(WinId, WinId)] -> s -> (() -> IO Bool) -> IO Bool
forall s x.
IntMap (s -> WinId -> IO x)
-> [(WinId, WinId)] -> s -> (x -> IO Bool) -> IO Bool
bind IntMap (s -> WinId -> IO ())
uNameToRenderIOMap' ([WinId] -> [WinId] -> [(WinId, WinId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WinId]
unis [WinId]
ubinds) s
x (IO Bool -> () -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> () -> IO Bool) -> IO Bool -> () -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
                                Bool
isOk <- IntMap (s -> WinId -> IO WinId)
-> [(WinId, WinId)] -> s -> (WinId -> IO Bool) -> IO Bool
forall s x.
IntMap (s -> WinId -> IO x)
-> [(WinId, WinId)] -> s -> (x -> IO Bool) -> IO Bool
bind (RenderIOState s -> IntMap (s -> WinId -> IO WinId)
forall s. RenderIOState s -> IntMap (s -> WinId -> IO WinId)
samplerNameToRenderIO RenderIOState s
state) ([WinId] -> [WinId] -> [(WinId, WinId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WinId]
samps [WinId]
sbinds) s
x (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (WinId -> Bool) -> WinId -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (WinId -> Bool) -> WinId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WinId -> IntSet -> Bool
`Set.member` RenderState -> IntSet
renderWriteTextures RenderState
rs))
                                (RenderIOState s -> IntMap (s -> IO ())
forall s. RenderIOState s -> IntMap (s -> IO ())
rasterizationNameToRenderIO RenderIOState s
state IntMap (s -> IO ()) -> WinId -> s -> IO ()
forall a. IntMap a -> WinId -> a
! WinId
rastN) s
x
                                IO ()
blendIO
                                Maybe String
mErr2 <- IO (Maybe String)
m
                                let mErr :: Maybe String
mErr = if Bool
isOk
                                        then Maybe String
forall a. Maybe a
Nothing
                                        else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Running shader that samples from texture that currently has an image borrowed from it."
                                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Try run this shader from a separate render call where no images from the same texture are drawn to or cleared.\n"
                                Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Maybe String
mErr Maybe String -> Maybe String -> Maybe String
forall a. Semigroup a => a -> a -> a
<> Maybe String
mErr2
                            Maybe String
-> (String -> ExceptT String (t (StateT RenderState m)) Any)
-> ExceptT String (t (StateT RenderState m)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
mErr String -> ExceptT String (t (StateT RenderState m)) Any
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE

            -- Bind the framebuffer.

            WinId
windowId <- case Either WinId (IO FBOKeys, IO ())
mFboKeyIO of
                Left WinId
wid -> do -- Bind correct context

                    WinId
-> IO (Maybe String)
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTrans t, Monad m, MonadIO (t (StateT RenderState m))) =>
WinId
-> IO (Maybe String)
-> ExceptT String (t (StateT RenderState m)) ()
inwin WinId
wid (IO (Maybe String)
 -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> IO (Maybe String)
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall a b. (a -> b) -> a -> b
$ do
                        GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBindFramebuffer GLuint
forall a. (Eq a, Num a) => a
GL_DRAW_FRAMEBUFFER GLuint
0
                        Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                    WinId
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) WinId
forall (m :: * -> *) a. Monad m => a -> m a
return WinId
wid
                Right (IO FBOKeys
fboKeyIO, IO ()
fboIO) -> do
                    -- Off-screen draw call, continue with last context

                    -- (something wrong here?)

                    (WinId
cwid, ContextData
cd, ContextDoAsync
doAsync) <- Render Any (WinId, ContextData, ContextDoAsync)
-> ExceptT
     String
     (ReaderT RenderEnv (StateT RenderState IO))
     (WinId, ContextData, ContextDoAsync)
forall os a.
Render os a
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) a
unRender Render Any (WinId, ContextData, ContextDoAsync)
forall os. Render os (WinId, ContextData, ContextDoAsync)
getLastRenderWin
                    WinId
-> IO (Maybe String)
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTrans t, Monad m, MonadIO (t (StateT RenderState m))) =>
WinId
-> IO (Maybe String)
-> ExceptT String (t (StateT RenderState m)) ()
inwin WinId
cwid (IO (Maybe String)
 -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> IO (Maybe String)
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall a b. (a -> b) -> a -> b
$ do
                        FBOKeys
fbokey <- IO FBOKeys
fboKeyIO
                        Maybe (IORef GLuint)
mfbo <- ContextData -> FBOKeys -> IO (Maybe (IORef GLuint))
getFBO ContextData
cd FBOKeys
fbokey
                        case Maybe (IORef GLuint)
mfbo of
                            Just IORef GLuint
fbo -> do
                                GLuint
fbo' <- IORef GLuint -> IO GLuint
forall a. IORef a -> IO a
readIORef IORef GLuint
fbo
                                GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBindFramebuffer GLuint
forall a. (Eq a, Num a) => a
GL_DRAW_FRAMEBUFFER GLuint
fbo'
                                Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                            Maybe (IORef GLuint)
Nothing -> do
                                GLuint
fbo' <- (Ptr GLuint -> IO GLuint) -> IO GLuint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLuint -> IO GLuint) -> IO GLuint)
-> (Ptr GLuint -> IO GLuint) -> IO GLuint
forall a b. (a -> b) -> a -> b
$ \ Ptr GLuint
ptr -> GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glGenFramebuffers GLint
1 Ptr GLuint
ptr IO () -> IO GLuint -> IO GLuint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLuint -> IO GLuint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLuint
ptr
                                IORef GLuint
fbo <- GLuint -> IO (IORef GLuint)
forall a. a -> IO (IORef a)
newIORef GLuint
fbo'
                                IO (Weak (IORef GLuint)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak (IORef GLuint)) -> IO ())
-> IO (Weak (IORef GLuint)) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef GLuint -> IO () -> IO (Weak (IORef GLuint))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef GLuint
fbo (ContextDoAsync
doAsync ContextDoAsync -> ContextDoAsync
forall a b. (a -> b) -> a -> b
$ GLuint -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLuint
fbo' ((Ptr GLuint -> IO ()) -> IO ()) -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glDeleteFramebuffers GLint
1)
                                ContextData -> FBOKeys -> IORef GLuint -> IO ()
setFBO ContextData
cd FBOKeys
fbokey IORef GLuint
fbo
                                GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBindFramebuffer GLuint
forall a. (Eq a, Num a) => a
GL_DRAW_FRAMEBUFFER GLuint
fbo'
                                GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glEnable GLuint
forall a. (Eq a, Num a) => a
GL_FRAMEBUFFER_SRGB
                                IO ()
fboIO
                                let numColors :: WinId
numColors = [FBOKey] -> WinId
forall (t :: * -> *) a. Foldable t => t a -> WinId
length ([FBOKey] -> WinId) -> [FBOKey] -> WinId
forall a b. (a -> b) -> a -> b
$ FBOKeys -> [FBOKey]
fboColors FBOKeys
fbokey
                                [GLuint] -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [GLuint
forall a. (Eq a, Num a) => a
GL_COLOR_ATTACHMENT0 .. (GLuint
forall a. (Eq a, Num a) => a
GL_COLOR_ATTACHMENT0 GLuint -> GLuint -> GLuint
forall a. Num a => a -> a -> a
+ WinId -> GLuint
forall a b. (Integral a, Num b) => a -> b
fromIntegral WinId
numColors GLuint -> GLuint -> GLuint
forall a. Num a => a -> a -> a
- GLuint
1)] ((Ptr GLuint -> IO ()) -> IO ()) -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glDrawBuffers (WinId -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral WinId
numColors)
                                IO (Maybe String)
forall (m :: * -> *). MonadIO m => m (Maybe String)
getFboError
                    WinId
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) WinId
forall (m :: * -> *) a. Monad m => a -> m a
return WinId
cwid

            -- Draw each vertex array.

            [((IO [VAOKey], IO ()), IO ())]
-> (((IO [VAOKey], IO ()), IO ())
    -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (((([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ()))
 -> ((IO [VAOKey], IO ()), IO ()))
-> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())]
-> [((IO [VAOKey], IO ()), IO ())]
forall a b. (a -> b) -> [a] -> [b]
map ((([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ()))
-> ([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())
forall a b. (a -> b) -> a -> b
$ ([WinId]
inputs, GLuint
pstrUBuf, WinId
pstrUSize)) ((RenderIOState s
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
forall s.
RenderIOState s
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
inputArrayToRenderIO RenderIOState s
state IntMap
  (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
-> WinId
-> s
-> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())]
forall a. IntMap a -> WinId -> a
! WinId
primN) s
x)) ((((IO [VAOKey], IO ()), IO ())
  -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
 -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> (((IO [VAOKey], IO ()), IO ())
    -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall a b. (a -> b) -> a -> b
$ \ ((IO [VAOKey]
keyIO, IO ()
vaoIO), IO ()
drawIO) -> do
                case WinId
-> IntMap (WindowState, ContextDoAsync)
-> Maybe (WindowState, ContextDoAsync)
forall a. WinId -> IntMap a -> Maybe a
Map.lookup WinId
windowId (RenderState -> IntMap (WindowState, ContextDoAsync)
perWindowRenderState RenderState
rs) of
                    Maybe (WindowState, ContextDoAsync)
Nothing -> () -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Window deleted

                    Just (WindowState
ws, ContextDoAsync
doAsync) ->
                        IO ()
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> IO ()
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall a b. (a -> b) -> a -> b
$ do
                            let cd :: ContextData
cd = WindowState -> ContextData
windowContextData WindowState
ws
                            [VAOKey]
key <- IO [VAOKey]
keyIO
                            Maybe (IORef GLuint)
mvao <- ContextData -> [VAOKey] -> IO (Maybe (IORef GLuint))
getVAO ContextData
cd [VAOKey]
key
                            case Maybe (IORef GLuint)
mvao of
                                Just IORef GLuint
vao -> do
                                    GLuint
vao' <- IORef GLuint -> IO GLuint
forall a. IORef a -> IO a
readIORef IORef GLuint
vao
                                    GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glBindVertexArray GLuint
vao'
                                Maybe (IORef GLuint)
Nothing -> do
                                    GLuint
vao' <- (Ptr GLuint -> IO GLuint) -> IO GLuint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLuint -> IO GLuint) -> IO GLuint)
-> (Ptr GLuint -> IO GLuint) -> IO GLuint
forall a b. (a -> b) -> a -> b
$ \ Ptr GLuint
ptr -> GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glGenVertexArrays GLint
1 Ptr GLuint
ptr IO () -> IO GLuint -> IO GLuint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLuint -> IO GLuint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLuint
ptr
                                    IORef GLuint
vao <- GLuint -> IO (IORef GLuint)
forall a. a -> IO (IORef a)
newIORef GLuint
vao'
                                    IO (Weak (IORef GLuint)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak (IORef GLuint)) -> IO ())
-> IO (Weak (IORef GLuint)) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef GLuint -> IO () -> IO (Weak (IORef GLuint))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef GLuint
vao (ContextDoAsync
doAsync ContextDoAsync -> ContextDoAsync
forall a b. (a -> b) -> a -> b
$ GLuint -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLuint
vao' ((Ptr GLuint -> IO ()) -> IO ()) -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glDeleteVertexArrays GLint
1)
                                    ContextData -> [VAOKey] -> IORef GLuint -> IO ()
setVAO ContextData
cd [VAOKey]
key IORef GLuint
vao
                                    GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glBindVertexArray GLuint
vao'
                                    IO ()
vaoIO
                            IO ()
drawIO

    let deleter :: IO ()
deleter = do
            GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteProgram GLuint
pName
            Bool -> ContextDoAsync
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WinId
pstrUSize WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
> WinId
0) ContextDoAsync -> ContextDoAsync
forall a b. (a -> b) -> a -> b
$ GLuint -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLuint
pstrUBuf (GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glDeleteBuffers GLint
1)

    ((IORef GLuint, IO ()), s -> Render os ())
-> IO ((IORef GLuint, IO ()), s -> Render os ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((IORef GLuint
pNameRef, IO ()
deleter), s -> Render os ()
forall os. s -> Render os ()
renderer)

-- private

createFeedbackRenderer :: RenderIOState s -- Interactions between the drawcall and the environment 's'.

    ->  ( Drawcall s -- A drawcall with:

        , [Int] -- its uniform buffers used,

        , [Int] -- its textures units used,

        , [Int] -- its allocated uniforms,

        , [Int] -- its allocated texture units.

        )
    ->  GLuint -- program name

    ->  (s -> IO (GLuint, GLuint, GLuint, GLuint)) -- transform feedback stuff

    ->  Int
    ->  IO  ( (IORef GLuint, IO ()) -- The program name and its destructor.

            , s -> Render os () -- The program's renderer as a function on a render (OpenGL) state.

            )
createFeedbackRenderer :: RenderIOState s
-> (Drawcall s, [WinId], [WinId], [WinId], [WinId])
-> GLuint
-> (s -> IO (GLuint, GLuint, GLuint, GLuint))
-> WinId
-> IO ((IORef GLuint, IO ()), s -> Render os ())
createFeedbackRenderer RenderIOState s
state (Drawcall s
drawcall, [WinId]
unis, [WinId]
ubinds, [WinId]
samps, [WinId]
sbinds) GLuint
pName s -> IO (GLuint, GLuint, GLuint, GLuint)
getTransformFeedbackName WinId
geoN = do
    let fboSetup :: s -> (Either WinId (IO FBOKeys, IO ()), IO ())
fboSetup = Drawcall s -> s -> (Either WinId (IO FBOKeys, IO ()), IO ())
forall s.
Drawcall s -> s -> (Either WinId (IO FBOKeys, IO ()), IO ())
drawcallFbo Drawcall s
drawcall
        primN :: WinId
primN = Drawcall s -> WinId
forall s. Drawcall s -> WinId
primitiveName Drawcall s
drawcall
        inputs :: [WinId]
inputs = Drawcall s -> [WinId]
forall s. Drawcall s -> [WinId]
usedInputs Drawcall s
drawcall
        pstrUSize :: WinId
pstrUSize = Drawcall s -> WinId
forall s. Drawcall s -> WinId
primStrUBufferSize Drawcall s
drawcall

    let pstrUSize' :: WinId
pstrUSize' = if WinId
0 WinId -> [WinId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WinId]
unis then WinId
pstrUSize else WinId
0
    GLuint
pstrUBuf <- WinId -> IO GLuint
forall a. Integral a => a -> IO GLuint
createUniformBuffer WinId
pstrUSize' -- Create uniform buffer for primiveStream uniforms


    [(WinId, WinId)] -> ((WinId, WinId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([WinId] -> [WinId] -> [(WinId, WinId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WinId]
unis [WinId]
ubinds) (((WinId, WinId) -> IO ()) -> IO ())
-> ((WinId, WinId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(WinId
name, WinId
bind) -> do
        GLuint
uix <- String -> (CString -> IO GLuint) -> IO GLuint
forall a. String -> (CString -> IO a) -> IO a
withCString (String
"uBlock" String -> String -> String
forall a. [a] -> [a] -> [a]
++ WinId -> String
forall a. Show a => a -> String
show WinId
name) ((CString -> IO GLuint) -> IO GLuint)
-> (CString -> IO GLuint) -> IO GLuint
forall a b. (a -> b) -> a -> b
$ GLuint -> CString -> IO GLuint
forall (m :: * -> *). MonadIO m => GLuint -> CString -> m GLuint
glGetUniformBlockIndex GLuint
pName
        GLuint -> GLuint -> GLuint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> GLuint -> m ()
glUniformBlockBinding GLuint
pName GLuint
uix (WinId -> GLuint
forall a b. (Integral a, Num b) => a -> b
fromIntegral WinId
bind)

    GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glUseProgram GLuint
pName -- For setting texture uniforms

    [(WinId, WinId)] -> ((WinId, WinId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([WinId] -> [WinId] -> [(WinId, WinId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WinId]
samps [WinId]
sbinds) (((WinId, WinId) -> IO ()) -> IO ())
-> ((WinId, WinId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(WinId
name, WinId
bind) -> do
        GLint
six <- String -> (CString -> IO GLint) -> IO GLint
forall a. String -> (CString -> IO a) -> IO a
withCString (String
"s" String -> String -> String
forall a. [a] -> [a] -> [a]
++ WinId -> String
forall a. Show a => a -> String
show WinId
name) ((CString -> IO GLint) -> IO GLint)
-> (CString -> IO GLint) -> IO GLint
forall a b. (a -> b) -> a -> b
$ GLuint -> CString -> IO GLint
forall (m :: * -> *). MonadIO m => GLuint -> CString -> m GLint
glGetUniformLocation GLuint
pName
        GLint -> GLint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> GLint -> m ()
glUniform1i GLint
six (WinId -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral WinId
bind)
    IORef GLuint
pNameRef <- GLuint -> IO (IORef GLuint)
forall a. a -> IO (IORef a)
newIORef GLuint
pName

    let uNameToRenderIOMap :: IntMap (s -> WinId -> IO ())
uNameToRenderIOMap = RenderIOState s -> IntMap (s -> WinId -> IO ())
forall s. RenderIOState s -> IntMap (s -> WinId -> IO ())
uniformNameToRenderIO RenderIOState s
state
        uNameToRenderIOMap' :: IntMap (s -> WinId -> IO ())
uNameToRenderIOMap' = GLuint
-> WinId
-> IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO ())
forall s.
GLuint
-> WinId
-> IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO ())
addPrimitiveStreamUniform GLuint
pstrUBuf WinId
pstrUSize' IntMap (s -> WinId -> IO ())
uNameToRenderIOMap

    -- Drawing with the program.

    let renderer :: s -> Render os ()
renderer = \s
x -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
-> Render os ()
forall os a.
ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) a
-> Render os a
Render (ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
 -> Render os ())
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
-> Render os ()
forall a b. (a -> b) -> a -> b
$ do
            RenderState
rs <- ReaderT RenderEnv (StateT RenderState IO) RenderState
-> ExceptT
     String (ReaderT RenderEnv (StateT RenderState IO)) RenderState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT RenderEnv (StateT RenderState IO) RenderState
 -> ExceptT
      String (ReaderT RenderEnv (StateT RenderState IO)) RenderState)
-> ReaderT RenderEnv (StateT RenderState IO) RenderState
-> ExceptT
     String (ReaderT RenderEnv (StateT RenderState IO)) RenderState
forall a b. (a -> b) -> a -> b
$ StateT RenderState IO RenderState
-> ReaderT RenderEnv (StateT RenderState IO) RenderState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT RenderState IO RenderState
forall (m :: * -> *) s. Monad m => StateT s m s
get
            RenderEnv
renv <- ReaderT RenderEnv (StateT RenderState IO) RenderEnv
-> ExceptT
     String (ReaderT RenderEnv (StateT RenderState IO)) RenderEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReaderT RenderEnv (StateT RenderState IO) RenderEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
            let (Left WinId
windowId, IO ()
blendIO) = s -> (Either WinId (IO FBOKeys, IO ()), IO ())
fboSetup s
x
                transformFeedback :: IO (GLuint, GLuint, GLuint, GLuint)
transformFeedback = s -> IO (GLuint, GLuint, GLuint, GLuint)
getTransformFeedbackName s
x

            case WinId
-> IntMap (WindowState, ContextDoAsync)
-> Maybe (WindowState, ContextDoAsync)
forall a. WinId -> IntMap a -> Maybe a
Map.lookup WinId
windowId (RenderState -> IntMap (WindowState, ContextDoAsync)
perWindowRenderState RenderState
rs) of
                Maybe (WindowState, ContextDoAsync)
Nothing -> () -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Window deleted

                Just (WindowState
ws, ContextDoAsync
doAsync) -> do
                    ReaderT RenderEnv (StateT RenderState IO) ()
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT RenderEnv (StateT RenderState IO) ()
 -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> ReaderT RenderEnv (StateT RenderState IO) ()
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall a b. (a -> b) -> a -> b
$ StateT RenderState IO ()
-> ReaderT RenderEnv (StateT RenderState IO) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT RenderState IO ()
 -> ReaderT RenderEnv (StateT RenderState IO) ())
-> StateT RenderState IO ()
-> ReaderT RenderEnv (StateT RenderState IO) ()
forall a b. (a -> b) -> a -> b
$ RenderState -> StateT RenderState IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (RenderState
rs { renderLastUsedWin :: WinId
renderLastUsedWin = WinId
windowId })
                    IO ()
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> IO ()
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall a b. (a -> b) -> a -> b
$ ContextDoAsync -> ContextDoAsync
forall x. ContextDoAsync -> IO x -> IO x
asSync ContextDoAsync
doAsync ContextDoAsync -> ContextDoAsync
forall a b. (a -> b) -> a -> b
$ do
                        GLuint
pName' <- IORef GLuint -> IO GLuint
forall a. IORef a -> IO a
readIORef IORef GLuint
pNameRef -- Cant use pName, need to touch pNameRef

                        GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glUseProgram GLuint
pName'
                        -- Too late: (transformFeedbackToRenderIO state ! geoN) x pName'

                        Bool
True <- IntMap (s -> WinId -> IO ())
-> [(WinId, WinId)] -> s -> (() -> IO Bool) -> IO Bool
forall s x.
IntMap (s -> WinId -> IO x)
-> [(WinId, WinId)] -> s -> (x -> IO Bool) -> IO Bool
bind IntMap (s -> WinId -> IO ())
uNameToRenderIOMap' ([WinId] -> [WinId] -> [(WinId, WinId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WinId]
unis [WinId]
ubinds) s
x (IO Bool -> () -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> () -> IO Bool) -> IO Bool -> () -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
                        Bool
isOk <- IntMap (s -> WinId -> IO WinId)
-> [(WinId, WinId)] -> s -> (WinId -> IO Bool) -> IO Bool
forall s x.
IntMap (s -> WinId -> IO x)
-> [(WinId, WinId)] -> s -> (x -> IO Bool) -> IO Bool
bind (RenderIOState s -> IntMap (s -> WinId -> IO WinId)
forall s. RenderIOState s -> IntMap (s -> WinId -> IO WinId)
samplerNameToRenderIO RenderIOState s
state) ([WinId] -> [WinId] -> [(WinId, WinId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WinId]
samps [WinId]
sbinds) s
x (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (WinId -> Bool) -> WinId -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (WinId -> Bool) -> WinId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WinId -> IntSet -> Bool
`Set.member` RenderState -> IntSet
renderWriteTextures RenderState
rs))
                        IO ()
blendIO

                    -- Draw each vertex array.

                    [((IO [VAOKey], IO ()), IO ())]
-> (((IO [VAOKey], IO ()), IO ())
    -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (((([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ()))
 -> ((IO [VAOKey], IO ()), IO ()))
-> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())]
-> [((IO [VAOKey], IO ()), IO ())]
forall a b. (a -> b) -> [a] -> [b]
map ((([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ()))
-> ([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())
forall a b. (a -> b) -> a -> b
$ ([WinId]
inputs, GLuint
pstrUBuf, WinId
pstrUSize)) ((RenderIOState s
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
forall s.
RenderIOState s
-> IntMap
     (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
inputArrayToRenderIO RenderIOState s
state IntMap
  (s -> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())])
-> WinId
-> s
-> [([WinId], GLuint, WinId) -> ((IO [VAOKey], IO ()), IO ())]
forall a. IntMap a -> WinId -> a
! WinId
primN) s
x)) ((((IO [VAOKey], IO ()), IO ())
  -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
 -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> (((IO [VAOKey], IO ()), IO ())
    -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall a b. (a -> b) -> a -> b
$ \ ((IO [VAOKey]
keyIO, IO ()
vaoIO), IO ()
drawIO) -> IO ()
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ())
-> IO ()
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall a b. (a -> b) -> a -> b
$ do
                        let cd :: ContextData
cd = WindowState -> ContextData
windowContextData WindowState
ws
                        [VAOKey]
key <- IO [VAOKey]
keyIO
                        Maybe (IORef GLuint)
mvao <- ContextData -> [VAOKey] -> IO (Maybe (IORef GLuint))
getVAO ContextData
cd [VAOKey]
key
                        case Maybe (IORef GLuint)
mvao of
                            Just IORef GLuint
vao -> do
                                GLuint
vao' <- IORef GLuint -> IO GLuint
forall a. IORef a -> IO a
readIORef IORef GLuint
vao
                                GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glBindVertexArray GLuint
vao'
                            Maybe (IORef GLuint)
Nothing -> do
                                GLuint
vao' <- (Ptr GLuint -> IO GLuint) -> IO GLuint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLuint -> IO GLuint) -> IO GLuint)
-> (Ptr GLuint -> IO GLuint) -> IO GLuint
forall a b. (a -> b) -> a -> b
$ \ Ptr GLuint
ptr -> GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glGenVertexArrays GLint
1 Ptr GLuint
ptr IO () -> IO GLuint -> IO GLuint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLuint -> IO GLuint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLuint
ptr
                                IORef GLuint
vao <- GLuint -> IO (IORef GLuint)
forall a. a -> IO (IORef a)
newIORef GLuint
vao'
                                IO (Weak (IORef GLuint)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak (IORef GLuint)) -> IO ())
-> IO (Weak (IORef GLuint)) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef GLuint -> IO () -> IO (Weak (IORef GLuint))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef GLuint
vao (ContextDoAsync
doAsync ContextDoAsync -> ContextDoAsync
forall a b. (a -> b) -> a -> b
$ GLuint -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLuint
vao' ((Ptr GLuint -> IO ()) -> IO ()) -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glDeleteVertexArrays GLint
1)
                                ContextData -> [VAOKey] -> IORef GLuint -> IO ()
setVAO ContextData
cd [VAOKey]
key IORef GLuint
vao
                                GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glBindVertexArray GLuint
vao'
                                IO ()
vaoIO
                        (GLuint
bName, GLuint
tfName, GLuint
tfqName, GLuint
topology) <- IO (GLuint, GLuint, GLuint, GLuint)
transformFeedback
                        GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBindTransformFeedback GLuint
forall a. (Eq a, Num a) => a
GL_TRANSFORM_FEEDBACK GLuint
tfName
                        GLuint -> GLuint -> GLuint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> GLuint -> m ()
glBindBufferBase GLuint
forall a. (Eq a, Num a) => a
GL_TRANSFORM_FEEDBACK_BUFFER GLuint
0 GLuint
bName
                        GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBeginQuery GLuint
forall a. (Eq a, Num a) => a
GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN GLuint
tfqName
                        -- liftIO $ hPutStrLn stderr $ "doing transform feedback"

                        GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glBeginTransformFeedback GLuint
topology
                        GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glEnable GLuint
forall a. (Eq a, Num a) => a
GL_RASTERIZER_DISCARD
                        IO ()
drawIO
                        GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDisable GLuint
forall a. (Eq a, Num a) => a
GL_RASTERIZER_DISCARD
                        IO ()
forall (m :: * -> *). MonadIO m => m ()
glEndTransformFeedback
                        GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glEndQuery GLuint
forall a. (Eq a, Num a) => a
GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN
                        {-
                        l <- alloca $ \ptr -> do
                            glGetQueryObjectiv tfqName GL_QUERY_RESULT ptr
                            peek ptr
                        liftIO $ hPutStrLn stderr $ "generated primitive count: " ++ show l
                        -}

    let deleter :: IO ()
deleter = do
            GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteProgram GLuint
pName
            Bool -> ContextDoAsync
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WinId
pstrUSize WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
> WinId
0) ContextDoAsync -> ContextDoAsync
forall a b. (a -> b) -> a -> b
$ GLuint -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLuint
pstrUBuf (GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glDeleteBuffers GLint
1)

    ((IORef GLuint, IO ()), s -> Render os ())
-> IO ((IORef GLuint, IO ()), s -> Render os ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((IORef GLuint
pNameRef, IO ()
deleter), s -> Render os ()
forall os. s -> Render os ()
renderer)

-- private

compileOpenGlShader :: GLuint -> String -> IO (Maybe String)
compileOpenGlShader :: GLuint -> String -> IO (Maybe String)
compileOpenGlShader GLuint
name String
source = do
    -- writeFile ("shaders/" ++ show name ++ ".glsl") source -- For debug purposes only.

    String -> (CStringLen -> IO ()) -> IO ()
forall a. String -> (CStringLen -> IO a) -> IO a
withCStringLen String
source ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ (CString
ptr, WinId
len) ->
                                CString -> (Ptr CString -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with CString
ptr ((Ptr CString -> IO ()) -> IO ())
-> (Ptr CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr CString
pptr ->
                                    GLint -> (Ptr GLint -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (WinId -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral WinId
len) ((Ptr GLint -> IO ()) -> IO ()) -> (Ptr GLint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr GLint
plen ->
                                        GLuint -> GLint -> Ptr CString -> Ptr GLint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLint -> Ptr CString -> Ptr GLint -> m ()
glShaderSource GLuint
name GLint
1 Ptr CString
pptr Ptr GLint
plen
    -- putStrLn $ "Compiling shader " ++ show name

    GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glCompileShader GLuint
name
    -- putStrLn $ "Compiled shader " ++ show name

    GLint
compStatus <- (Ptr GLint -> IO GLint) -> IO GLint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLint -> IO GLint) -> IO GLint)
-> (Ptr GLint -> IO GLint) -> IO GLint
forall a b. (a -> b) -> a -> b
$ \ Ptr GLint
ptr -> GLuint -> GLuint -> Ptr GLint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> Ptr GLint -> m ()
glGetShaderiv GLuint
name GLuint
forall a. (Eq a, Num a) => a
GL_COMPILE_STATUS Ptr GLint
ptr IO () -> IO GLint -> IO GLint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLint -> IO GLint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLint
ptr
    if GLint
compStatus GLint -> GLint -> Bool
forall a. Eq a => a -> a -> Bool
/= GLint
forall a. (Eq a, Num a) => a
GL_FALSE
        then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        else do
            GLint
logLen <- (Ptr GLint -> IO GLint) -> IO GLint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLint -> IO GLint) -> IO GLint)
-> (Ptr GLint -> IO GLint) -> IO GLint
forall a b. (a -> b) -> a -> b
$ \ Ptr GLint
ptr -> GLuint -> GLuint -> Ptr GLint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> Ptr GLint -> m ()
glGetShaderiv GLuint
name GLuint
forall a. (Eq a, Num a) => a
GL_INFO_LOG_LENGTH Ptr GLint
ptr IO () -> IO GLint -> IO GLint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLint -> IO GLint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLint
ptr
            let logLen' :: WinId
logLen' = GLint -> WinId
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
logLen
            (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just (IO String -> IO (Maybe String)) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ WinId -> (CString -> IO String) -> IO String
forall a b. Storable a => WinId -> (Ptr a -> IO b) -> IO b
allocaArray WinId
logLen' ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ CString
ptr -> do
                GLuint -> GLint -> Ptr GLint -> CString -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLint -> Ptr GLint -> CString -> m ()
glGetShaderInfoLog GLuint
name GLint
logLen Ptr GLint
forall a. Ptr a
nullPtr CString
ptr
                CString -> IO String
peekCString CString
ptr

-- private

linkProgram :: GLuint -> IO (Maybe String)
linkProgram :: GLuint -> IO (Maybe String)
linkProgram GLuint
name = do
    -- putStrLn $ "Linking program " ++ show name

    GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glLinkProgram GLuint
name
    -- putStrLn $ "Linked program " ++ show name

    GLint
linkStatus <- (Ptr GLint -> IO GLint) -> IO GLint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLint -> IO GLint) -> IO GLint)
-> (Ptr GLint -> IO GLint) -> IO GLint
forall a b. (a -> b) -> a -> b
$ \ Ptr GLint
ptr -> GLuint -> GLuint -> Ptr GLint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> Ptr GLint -> m ()
glGetProgramiv GLuint
name GLuint
forall a. (Eq a, Num a) => a
GL_LINK_STATUS Ptr GLint
ptr IO () -> IO GLint -> IO GLint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLint -> IO GLint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLint
ptr
    if GLint
linkStatus GLint -> GLint -> Bool
forall a. Eq a => a -> a -> Bool
/= GLint
forall a. (Eq a, Num a) => a
GL_FALSE
        then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        else do
            GLint
logLen <- (Ptr GLint -> IO GLint) -> IO GLint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLint -> IO GLint) -> IO GLint)
-> (Ptr GLint -> IO GLint) -> IO GLint
forall a b. (a -> b) -> a -> b
$ \ Ptr GLint
ptr -> GLuint -> GLuint -> Ptr GLint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> Ptr GLint -> m ()
glGetProgramiv GLuint
name GLuint
forall a. (Eq a, Num a) => a
GL_INFO_LOG_LENGTH Ptr GLint
ptr IO () -> IO GLint -> IO GLint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLint -> IO GLint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLint
ptr
            let logLen' :: WinId
logLen' = GLint -> WinId
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
logLen
            (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just (IO String -> IO (Maybe String)) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ WinId -> (CString -> IO String) -> IO String
forall a b. Storable a => WinId -> (Ptr a -> IO b) -> IO b
allocaArray WinId
logLen' ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ CString
ptr -> do
                GLuint -> GLint -> Ptr GLint -> CString -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLint -> Ptr GLint -> CString -> m ()
glGetProgramInfoLog GLuint
name GLint
logLen Ptr GLint
forall a. Ptr a
nullPtr CString
ptr
                CString -> IO String
peekCString CString
ptr

-- private

createUniformBuffer :: Integral a => a -> IO GLuint
createUniformBuffer :: a -> IO GLuint
createUniformBuffer a
0 = GLuint -> IO GLuint
forall (m :: * -> *) a. Monad m => a -> m a
return GLuint
forall a. HasCallStack => a
undefined
createUniformBuffer a
uSize = do
    GLuint
bname <- (Ptr GLuint -> IO GLuint) -> IO GLuint
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr GLuint -> IO GLuint) -> IO GLuint)
-> (Ptr GLuint -> IO GLuint) -> IO GLuint
forall a b. (a -> b) -> a -> b
$ \ Ptr GLuint
ptr -> GLint -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLuint -> m ()
glGenBuffers GLint
1 Ptr GLuint
ptr IO () -> IO GLuint -> IO GLuint
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr GLuint -> IO GLuint
forall a. Storable a => Ptr a -> IO a
peek Ptr GLuint
ptr
    GLuint -> GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBindBuffer GLuint
forall a. (Eq a, Num a) => a
GL_COPY_WRITE_BUFFER GLuint
bname
    GLuint -> GLsizeiptr -> Ptr () -> GLuint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLsizeiptr -> Ptr () -> GLuint -> m ()
glBufferData GLuint
forall a. (Eq a, Num a) => a
GL_COPY_WRITE_BUFFER (a -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
uSize) Ptr ()
forall a. Ptr a
nullPtr GLuint
forall a. (Eq a, Num a) => a
GL_STREAM_DRAW
    GLuint -> IO GLuint
forall (m :: * -> *) a. Monad m => a -> m a
return GLuint
bname

-- private

addPrimitiveStreamUniform :: Word32 -> Int -> Map.IntMap (s -> Binding -> IO ()) -> Map.IntMap (s -> Binding -> IO ())
addPrimitiveStreamUniform :: GLuint
-> WinId
-> IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO ())
addPrimitiveStreamUniform GLuint
_ WinId
0 = IntMap (s -> WinId -> IO ()) -> IntMap (s -> WinId -> IO ())
forall a. a -> a
id
addPrimitiveStreamUniform GLuint
bname WinId
uSize = WinId
-> (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO ())
forall a. WinId -> a -> IntMap a -> IntMap a
Map.insert WinId
0 ((s -> WinId -> IO ())
 -> IntMap (s -> WinId -> IO ()) -> IntMap (s -> WinId -> IO ()))
-> (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO ())
-> IntMap (s -> WinId -> IO ())
forall a b. (a -> b) -> a -> b
$ \s
_ WinId
bind -> GLuint -> GLuint -> GLuint -> GLsizeiptr -> GLsizeiptr -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> GLuint -> GLsizeiptr -> GLsizeiptr -> m ()
glBindBufferRange GLuint
forall a. (Eq a, Num a) => a
GL_UNIFORM_BUFFER (WinId -> GLuint
forall a b. (Integral a, Num b) => a -> b
fromIntegral WinId
bind) GLuint
bname GLsizeiptr
0 (WinId -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral WinId
uSize)

-- private

bind :: Map.IntMap (s -> Binding -> IO x)
    -> [(Int, Int)]
    -> s
    -> (x -> IO Bool) -- Used to assert we may use textures bound as render targets

    -> IO Bool
bind :: IntMap (s -> WinId -> IO x)
-> [(WinId, WinId)] -> s -> (x -> IO Bool) -> IO Bool
bind IntMap (s -> WinId -> IO x)
iom ((WinId
n,WinId
b):[(WinId, WinId)]
xs) s
s x -> IO Bool
a = do
    Bool
ok1 <- IntMap (s -> WinId -> IO x)
-> [(WinId, WinId)] -> s -> (x -> IO Bool) -> IO Bool
forall s x.
IntMap (s -> WinId -> IO x)
-> [(WinId, WinId)] -> s -> (x -> IO Bool) -> IO Bool
bind IntMap (s -> WinId -> IO x)
iom [(WinId, WinId)]
xs s
s x -> IO Bool
a
    Bool
ok2 <- (IntMap (s -> WinId -> IO x)
iom IntMap (s -> WinId -> IO x) -> WinId -> s -> WinId -> IO x
forall a. IntMap a -> WinId -> a
! WinId
n) s
s WinId
b IO x -> (x -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= x -> IO Bool
a
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool
ok1 Bool -> Bool -> Bool
&& Bool
ok2
bind IntMap (s -> WinId -> IO x)
_ [] s
_ x -> IO Bool
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- private

orderedUnion :: Ord a => [a] -> [a] -> [a]
orderedUnion :: [a] -> [a] -> [a]
orderedUnion xxs :: [a]
xxs@(a
x:[a]
xs) yys :: [a]
yys@(a
y:[a]
ys) | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y    = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion [a]
xs [a]
ys
                                   | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y     = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion [a]
xs [a]
yys
                                   | Bool
otherwise = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion [a]
xxs [a]
ys
orderedUnion [a]
xs [] = [a]
xs
orderedUnion [] [a]
ys = [a]
ys

-- private

oldAllocateWhichGiveStrangeResults :: Int -> [[Int]] -> [[Int]]
oldAllocateWhichGiveStrangeResults :: WinId -> [[WinId]] -> [[WinId]]
oldAllocateWhichGiveStrangeResults WinId
mx = IntMap WinId -> [WinId] -> [[WinId]] -> [[WinId]]
allocate' IntMap WinId
forall a. IntMap a
Map.empty [] where
    allocate' :: IntMap WinId -> [WinId] -> [[WinId]] -> [[WinId]]
allocate' IntMap WinId
m [WinId]
ys ((WinId
x:[WinId]
xs):[[WinId]]
xss)
        | Just WinId
a <- WinId -> IntMap WinId -> Maybe WinId
forall a. WinId -> IntMap a -> Maybe a
Map.lookup WinId
x IntMap WinId
m = IntMap WinId -> [WinId] -> [[WinId]] -> [[WinId]]
allocate' IntMap WinId
m (WinId
aWinId -> [WinId] -> [WinId]
forall a. a -> [a] -> [a]
:[WinId]
ys) ([WinId]
xs[WinId] -> [[WinId]] -> [[WinId]]
forall a. a -> [a] -> [a]
:[[WinId]]
xss)
        | WinId
ms <- IntMap WinId -> WinId
forall a. IntMap a -> WinId
Map.size IntMap WinId
m, WinId
ms WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
< WinId
mx = IntMap WinId -> [WinId] -> [[WinId]] -> [[WinId]]
allocate' (WinId -> WinId -> IntMap WinId -> IntMap WinId
forall a. WinId -> a -> IntMap a -> IntMap a
Map.insert WinId
x WinId
ms IntMap WinId
m) (WinId
msWinId -> [WinId] -> [WinId]
forall a. a -> [a] -> [a]
:[WinId]
ys) ([WinId]
xs[WinId] -> [[WinId]] -> [[WinId]]
forall a. a -> [a] -> [a]
:[[WinId]]
xss)
        | Bool
otherwise =
            let (WinId
ek,WinId
ev) = IntMap WinId -> WinId -> [WinId] -> (WinId, WinId)
forall t b.
(Ord t, Num t) =>
IntMap b -> t -> [WinId] -> (WinId, b)
findLastUsed IntMap WinId
m WinId
mx ([WinId]
ys [WinId] -> [WinId] -> [WinId]
forall a. [a] -> [a] -> [a]
++ [WinId]
xs [WinId] -> [WinId] -> [WinId]
forall a. [a] -> [a] -> [a]
++ [[WinId]] -> [WinId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[WinId]]
xss)
            in IntMap WinId -> [WinId] -> [[WinId]] -> [[WinId]]
allocate' (WinId -> WinId -> IntMap WinId -> IntMap WinId
forall a. WinId -> a -> IntMap a -> IntMap a
Map.insert WinId
x WinId
ev (WinId -> IntMap WinId -> IntMap WinId
forall a. WinId -> IntMap a -> IntMap a
Map.delete WinId
ek IntMap WinId
m)) (WinId
evWinId -> [WinId] -> [WinId]
forall a. a -> [a] -> [a]
:[WinId]
ys) ([WinId]
xs[WinId] -> [[WinId]] -> [[WinId]]
forall a. a -> [a] -> [a]
:[[WinId]]
xss)
    allocate' IntMap WinId
m [WinId]
ys ([WinId]
_:[[WinId]]
xss) = [WinId] -> [WinId]
forall a. [a] -> [a]
reverse [WinId]
ys [WinId] -> [[WinId]] -> [[WinId]]
forall a. a -> [a] -> [a]
: IntMap WinId -> [WinId] -> [[WinId]] -> [[WinId]]
allocate' IntMap WinId
m [] [[WinId]]
xss
    allocate' IntMap WinId
_ [WinId]
_ [] = []

    findLastUsed :: IntMap b -> t -> [WinId] -> (WinId, b)
findLastUsed IntMap b
m t
n (WinId
x:[WinId]
xs) | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
1 =
        let (Maybe b
a, IntMap b
m') = (WinId -> b -> Maybe b) -> WinId -> IntMap b -> (Maybe b, IntMap b)
forall a.
(WinId -> a -> Maybe a) -> WinId -> IntMap a -> (Maybe a, IntMap a)
Map.updateLookupWithKey ((b -> Maybe b) -> WinId -> b -> Maybe b
forall a b. a -> b -> a
const ((b -> Maybe b) -> WinId -> b -> Maybe b)
-> (b -> Maybe b) -> WinId -> b -> Maybe b
forall a b. (a -> b) -> a -> b
$ Maybe b -> b -> Maybe b
forall a b. a -> b -> a
const Maybe b
forall a. Maybe a
Nothing) WinId
x IntMap b
m
            n' :: t
n' = if Maybe b -> Bool
forall a. Maybe a -> Bool
isJust Maybe b
a then t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1 else t
n
        in IntMap b -> t -> [WinId] -> (WinId, b)
findLastUsed IntMap b
m' t
n' [WinId]
xs
    findLastUsed IntMap b
m t
_ [WinId]
_ = [(WinId, b)] -> (WinId, b)
forall a. [a] -> a
head ([(WinId, b)] -> (WinId, b)) -> [(WinId, b)] -> (WinId, b)
forall a b. (a -> b) -> a -> b
$ IntMap b -> [(WinId, b)]
forall a. IntMap a -> [(WinId, a)]
Map.toList IntMap b
m

{-
Map the input values into [0, mx[ with no gap. Two different values in the
input are mapped to two different values in the output as long as the `mx`
size of the output set is no reach. The `mx+1` nth value and beyond are
mapped to… I can't figure it!. Let's just raise an error instead.

Note that the fact that the values are stored in a list of lists doesn't
matter, we are just mapping a tree of values to another without caring about
the traversed structure.
-}
-- private

allocateConsecutiveIndexes :: Int -> [[Int]] -> [[Int]]
allocateConsecutiveIndexes :: WinId -> [[WinId]] -> [[WinId]]
allocateConsecutiveIndexes WinId
mx [[WinId]]
values = State (IntMap WinId) [[WinId]] -> IntMap WinId -> [[WinId]]
forall s a. State s a -> s -> a
evalState (([WinId] -> StateT (IntMap WinId) Identity [WinId])
-> [[WinId]] -> State (IntMap WinId) [[WinId]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((WinId -> StateT (IntMap WinId) Identity WinId)
-> [WinId] -> StateT (IntMap WinId) Identity [WinId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM WinId -> StateT (IntMap WinId) Identity WinId
forall (m :: * -> *).
Monad m =>
WinId -> StateT (IntMap WinId) m WinId
allocateIndex) [[WinId]]
values) IntMap WinId
forall a. IntMap a
Map.empty where
    allocateIndex :: WinId -> StateT (IntMap WinId) m WinId
allocateIndex WinId
n = do
        IntMap WinId
mapping <- StateT (IntMap WinId) m (IntMap WinId)
forall (m :: * -> *) s. Monad m => StateT s m s
get
        case WinId -> IntMap WinId -> Maybe WinId
forall a. WinId -> IntMap a -> Maybe a
Map.lookup WinId
n IntMap WinId
mapping of
            Maybe WinId
Nothing -> do
                let m :: WinId
m = IntMap WinId -> WinId
forall a. IntMap a -> WinId
Map.size IntMap WinId
mapping
                if WinId
m WinId -> WinId -> Bool
forall a. Ord a => a -> a -> Bool
< WinId
mx
                    then do
                        IntMap WinId -> StateT (IntMap WinId) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (IntMap WinId -> StateT (IntMap WinId) m ())
-> IntMap WinId -> StateT (IntMap WinId) m ()
forall a b. (a -> b) -> a -> b
$ WinId -> WinId -> IntMap WinId -> IntMap WinId
forall a. WinId -> a -> IntMap a -> IntMap a
Map.insert WinId
n WinId
m IntMap WinId
mapping
                        WinId -> StateT (IntMap WinId) m WinId
forall (m :: * -> *) a. Monad m => a -> m a
return WinId
m
                    else String -> StateT (IntMap WinId) m WinId
forall a. HasCallStack => String -> a
error String
"Not enough indexes available!"
            Just WinId
m -> WinId -> StateT (IntMap WinId) m WinId
forall (m :: * -> *) a. Monad m => a -> m a
return WinId
m

-- public

getFboError :: MonadIO m => m (Maybe String)
getFboError :: m (Maybe String)
getFboError = do
    GLuint
status <- GLuint -> m GLuint
forall (m :: * -> *). MonadIO m => GLuint -> m GLuint
glCheckFramebufferStatus GLuint
forall a. (Eq a, Num a) => a
GL_DRAW_FRAMEBUFFER
    Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> m (Maybe String))
-> Maybe String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ case GLuint
status of
        GLuint
GL_FRAMEBUFFER_COMPLETE -> Maybe String
forall a. Maybe a
Nothing
        GLuint
GL_FRAMEBUFFER_UNSUPPORTED -> String -> Maybe String
forall a. a -> Maybe a
Just String
"The combination of draw images (FBO) used in the render call is unsupported by this graphics driver\n"
        GLuint
_ -> String -> Maybe String
forall a. HasCallStack => String -> a
error String
"GPipe internal FBO error"

-- | A 'whenJust' that accepts a monoidal return value.

-- private

whenJust' :: (Monad m, Monoid b) => Maybe a -> (a -> m b) -> m b
whenJust' :: Maybe a -> (a -> m b) -> m b
whenJust' = ((a -> m b) -> Maybe a -> m b) -> Maybe a -> (a -> m b) -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((a -> m b) -> Maybe a -> m b) -> Maybe a -> (a -> m b) -> m b)
-> ((a -> m b) -> Maybe a -> m b) -> Maybe a -> (a -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ m b -> (a -> m b) -> Maybe a -> m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
forall a. Monoid a => a
mempty)