{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE PatternGuards   #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns    #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Graphics.GPipe.Internal.Compiler where

import           Control.Exception                (throwIO)
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.Either                      (partitionEithers)
import           Data.IORef                       (IORef, mkWeakIORef, newIORef,
                                                   readIORef)
import           Data.IntMap.Polymorphic          ((!))
import qualified Data.IntMap.Polymorphic          as Map
import qualified Data.IntSet                      as Set
import           Data.List                        (zip5)
import           Data.Maybe                       (fromJust, isJust, isNothing)
import qualified Data.Text.Foreign                as T
import           Data.Text.Lazy                   (Text)
import qualified Data.Text.Lazy                   as T
import           Data.Word                        (Word32)
import           Foreign.C.String                 (peekCString, withCString)
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)
import           Graphics.GPipe.Internal.Context
import           Graphics.GPipe.Internal.IDs      (SamplerId, UniformId, WinId)

-- | A compiled shader is just a function that takes an environment and returns
-- a 'Render' action It could have been called 'CompiledDrawcall' or 'Renderer'
-- because it is the same thing.
type CompiledShader os s = s -> Render os ()

{-
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 -> Int
primitiveName :: Int
        -- Key for RenderIOState::rasterizationNameToRenderIO.
    ,   Drawcall s -> Maybe Int
rasterizationName :: Maybe Int
        -- Shader sources.
    ,   Drawcall s -> Text
vertexSource :: Text
    ,   Drawcall s -> Maybe Text
optionalGeometrySource :: Maybe Text
    ,   Drawcall s -> Maybe Text
optionalFragmentSource :: Maybe Text
        -- Inputs.
    ,   Drawcall s -> [Int]
usedInputs :: [Int]
        -- Uniforms and texture units used in each shader.
    ,   Drawcall s -> [UniformId]
usedVUniforms :: [UniformId],   Drawcall s -> [SamplerId]
usedVSamplers :: [SamplerId]
    ,   Drawcall s -> [UniformId]
usedGUniforms :: [UniformId],   Drawcall s -> [SamplerId]
usedGSamplers :: [SamplerId]
    ,   Drawcall s -> [UniformId]
usedFUniforms :: [UniformId],   Drawcall s -> [SamplerId]
usedFSamplers :: [SamplerId]
        -- The size of the uniform buffer for the primitive stream (see USize in PrimitiveStream data).
    ,   Drawcall s -> Int
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
    {   RenderIOState s -> IntMap UniformId (s -> Int -> IO ())
uniformNameToRenderIO :: Map.IntMap UniformId (s -> Binding -> IO ())
        -- ^ 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 SamplerId (s -> Int -> IO Int)
samplerNameToRenderIO :: Map.IntMap SamplerId (s -> Binding -> IO Int)
        -- ^ Texture units bindings. IO returns texturename for validating that it
        -- isnt used as render target
    ,   RenderIOState s -> IntMap Int (s -> IO ())
rasterizationNameToRenderIO :: Map.IntMap Int (s -> IO ())
        -- ^ Final rasterization operations (mostly setting the viewport).
    ,   RenderIOState s -> IntMap Int (s -> GLuint -> IO ())
transformFeedbackToRenderIO :: Map.IntMap Int (s -> GLuint -> IO ())
        -- ^ Final vertex processiong stage.
    ,   RenderIOState s
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
inputArrayToRenderIO :: Map.IntMap Int (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.
            )
        ])
        -- ^ VAO bindings.
    }

-- public
newRenderIOState :: RenderIOState s
newRenderIOState :: RenderIOState s
newRenderIOState = IntMap UniformId (s -> Int -> IO ())
-> IntMap SamplerId (s -> Int -> IO Int)
-> IntMap Int (s -> IO ())
-> IntMap Int (s -> GLuint -> IO ())
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
-> RenderIOState s
forall s.
IntMap UniformId (s -> Int -> IO ())
-> IntMap SamplerId (s -> Int -> IO Int)
-> IntMap Int (s -> IO ())
-> IntMap Int (s -> GLuint -> IO ())
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
-> RenderIOState s
RenderIOState IntMap UniformId (s -> Int -> IO ())
forall k v. IntMap k v
Map.empty IntMap SamplerId (s -> Int -> IO Int)
forall k v. IntMap k v
Map.empty IntMap Int (s -> IO ())
forall k v. IntMap k v
Map.empty IntMap Int (s -> GLuint -> IO ())
forall k v. IntMap k v
Map.empty IntMap
  Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
forall k v. IntMap k v
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 UniformId (s' -> Int -> IO ())
a' IntMap SamplerId (s' -> Int -> IO Int)
b' IntMap Int (s' -> IO ())
c' IntMap Int (s' -> GLuint -> IO ())
d' IntMap
  Int (s' -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
e') (RenderIOState IntMap UniformId (s -> Int -> IO ())
a IntMap SamplerId (s -> Int -> IO Int)
b IntMap Int (s -> IO ())
c IntMap Int (s -> GLuint -> IO ())
d IntMap
  Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
e) =
    let merge :: IntMap k (s -> c) -> IntMap k (s' -> c) -> IntMap k (s -> c)
merge IntMap k (s -> c)
x IntMap k (s' -> c)
x' = IntMap k (s -> c) -> IntMap k (s -> c) -> IntMap k (s -> c)
forall k v. IntMap k v -> IntMap k v -> IntMap k v
Map.union IntMap k (s -> c)
x (IntMap k (s -> c) -> IntMap k (s -> c))
-> IntMap k (s -> c) -> IntMap k (s -> c)
forall a b. (a -> b) -> a -> b
$ ((s' -> c) -> s -> c) -> IntMap k (s' -> c) -> IntMap k (s -> c)
forall a b k. (a -> b) -> IntMap k a -> IntMap k b
Map.map ((s' -> c) -> (s -> s') -> s -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s'
f) IntMap k (s' -> c)
x'
    in  IntMap UniformId (s -> Int -> IO ())
-> IntMap SamplerId (s -> Int -> IO Int)
-> IntMap Int (s -> IO ())
-> IntMap Int (s -> GLuint -> IO ())
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
-> RenderIOState s
forall s.
IntMap UniformId (s -> Int -> IO ())
-> IntMap SamplerId (s -> Int -> IO Int)
-> IntMap Int (s -> IO ())
-> IntMap Int (s -> GLuint -> IO ())
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
-> RenderIOState s
RenderIOState (IntMap UniformId (s -> Int -> IO ())
-> IntMap UniformId (s' -> Int -> IO ())
-> IntMap UniformId (s -> Int -> IO ())
forall k c.
IntMap k (s -> c) -> IntMap k (s' -> c) -> IntMap k (s -> c)
merge IntMap UniformId (s -> Int -> IO ())
a IntMap UniformId (s' -> Int -> IO ())
a') (IntMap SamplerId (s -> Int -> IO Int)
-> IntMap SamplerId (s' -> Int -> IO Int)
-> IntMap SamplerId (s -> Int -> IO Int)
forall k c.
IntMap k (s -> c) -> IntMap k (s' -> c) -> IntMap k (s -> c)
merge IntMap SamplerId (s -> Int -> IO Int)
b IntMap SamplerId (s' -> Int -> IO Int)
b') (IntMap Int (s -> IO ())
-> IntMap Int (s' -> IO ()) -> IntMap Int (s -> IO ())
forall k c.
IntMap k (s -> c) -> IntMap k (s' -> c) -> IntMap k (s -> c)
merge IntMap Int (s -> IO ())
c IntMap Int (s' -> IO ())
c') (IntMap Int (s -> GLuint -> IO ())
-> IntMap Int (s' -> GLuint -> IO ())
-> IntMap Int (s -> GLuint -> IO ())
forall k c.
IntMap k (s -> c) -> IntMap k (s' -> c) -> IntMap k (s -> c)
merge IntMap Int (s -> GLuint -> IO ())
d IntMap Int (s' -> GLuint -> IO ())
d') (IntMap
  Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
-> IntMap
     Int (s' -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
forall k c.
IntMap k (s -> c) -> IntMap k (s' -> c) -> IntMap k (s -> c)
merge IntMap
  Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
e IntMap
  Int (s' -> [([Int], GLuint, Int) -> ((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 (CompiledShader os s) -- The compiled drawcall (OpenGL program shader actually) as a function on an environment.
compileDrawcalls :: [IO (Drawcall s)]
-> RenderIOState s -> ContextT ctx os m (CompiledShader os s)
compileDrawcalls [IO (Drawcall s)]
protoDrawcalls RenderIOState s
state = do

    ([CompileInput s]
drawcalls, [String]
limitErrors) <- IO ([CompileInput s], [String])
-> ContextT ctx os m ([CompileInput s], [String])
forall ctx (m :: * -> *) a os.
(ContextHandler ctx, MonadIO m) =>
IO a -> ContextT ctx os m a
liftNonWinContextIO (IO ([CompileInput s], [String])
 -> ContextT ctx os m ([CompileInput s], [String]))
-> IO ([CompileInput s], [String])
-> ContextT ctx os m ([CompileInput s], [String])
forall a b. (a -> b) -> a -> b
$ [IO (Drawcall s)] -> IO ([CompileInput s], [String])
forall s. [IO (Drawcall s)] -> IO ([CompileInput s], [String])
safeGenerateDrawcalls [IO (Drawcall s)]
protoDrawcalls
    [Either String ((IORef GLuint, IO ()), CompiledShader os s)]
compilationResults <- IO [Either String ((IORef GLuint, IO ()), CompiledShader os s)]
-> ContextT
     ctx
     os
     m
     [Either String ((IORef GLuint, IO ()), CompiledShader os s)]
forall ctx (m :: * -> *) a os.
(ContextHandler ctx, MonadIO m) =>
IO a -> ContextT ctx os m a
liftNonWinContextIO (IO [Either String ((IORef GLuint, IO ()), CompiledShader os s)]
 -> ContextT
      ctx
      os
      m
      [Either String ((IORef GLuint, IO ()), CompiledShader os s)])
-> IO [Either String ((IORef GLuint, IO ()), CompiledShader os s)]
-> ContextT
     ctx
     os
     m
     [Either String ((IORef GLuint, IO ()), CompiledShader os s)]
forall a b. (a -> b) -> a -> b
$ (CompileInput s
 -> IO (Either String ((IORef GLuint, IO ()), CompiledShader os s)))
-> [CompileInput s]
-> IO [Either String ((IORef GLuint, IO ()), CompiledShader os s)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RenderIOState s
-> CompileInput s
-> IO (Either String ((IORef GLuint, IO ()), CompiledShader os s))
forall s os.
RenderIOState s
-> CompileInput s
-> IO (Either String ((IORef GLuint, IO ()), CompiledShader os s))
innerCompile RenderIOState s
state) [CompileInput s]
drawcalls
    let ([String]
compilationErrors, [((IORef GLuint, IO ()), CompiledShader os s)]
compiledDrawcalls) = [Either String ((IORef GLuint, IO ()), CompiledShader os s)]
-> ([String], [((IORef GLuint, IO ()), CompiledShader os s)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either String ((IORef GLuint, IO ()), CompiledShader os s)]
compilationResults
        ([(IORef GLuint, IO ())]
programNameAndDeleters, [CompiledShader os s]
renderers) = [((IORef GLuint, IO ()), CompiledShader os s)]
-> ([(IORef GLuint, IO ())], [CompiledShader os s])
forall a b. [(a, b)] -> ([a], [b])
unzip [((IORef GLuint, IO ()), CompiledShader os s)]
compiledDrawcalls
        compositeRenderer :: CompiledShader os s
compositeRenderer s
x = (CompiledShader os s -> Render os ())
-> [CompiledShader os s] -> Render os ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CompiledShader os s -> CompiledShader os s
forall a b. (a -> b) -> a -> b
$ s
x) [CompiledShader os s]
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.
            CompiledShader os s -> ContextT ctx os m (CompiledShader os s)
forall (m :: * -> *) a. Monad m => a -> m a
return CompiledShader os s
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 (CompiledShader os s) -> ContextT ctx os m (CompiledShader os s)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (CompiledShader os s)
 -> ContextT ctx os m (CompiledShader os s))
-> IO (CompiledShader os s)
-> ContextT ctx os m (CompiledShader os s)
forall a b. (a -> b) -> a -> b
$ GPipeException -> IO (CompiledShader os s)
forall e a. Exception e => e -> IO a
throwIO (GPipeException -> IO (CompiledShader os s))
-> GPipeException -> IO (CompiledShader os s)
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

data CompileInput s = CompileInput
    { CompileInput s -> Drawcall s
drawcall :: Drawcall s  -- A drawcall with:
    , CompileInput s -> [UniformId]
unis     :: [UniformId] -- its uniform buffers used,
    , CompileInput s -> [SamplerId]
samps    :: [SamplerId] -- its textures units used,
    , CompileInput s -> [UniformId]
ubinds   :: [UniformId] -- its allocated uniforms,
    , CompileInput s -> [SamplerId]
sbinds   :: [SamplerId] -- its allocated texture units.
    }

mkCompInput :: (Drawcall s, [UniformId], [SamplerId], [UniformId], [SamplerId]) -> CompileInput s
mkCompInput :: (Drawcall s, [UniformId], [SamplerId], [UniformId], [SamplerId])
-> CompileInput s
mkCompInput (Drawcall s
drawcall, [UniformId]
unis, [SamplerId]
samps, [UniformId]
ubinds, [SamplerId]
sbinds) = CompileInput :: forall s.
Drawcall s
-> [UniformId]
-> [SamplerId]
-> [UniformId]
-> [SamplerId]
-> CompileInput s
CompileInput{[SamplerId]
[UniformId]
Drawcall s
sbinds :: [SamplerId]
ubinds :: [UniformId]
samps :: [SamplerId]
unis :: [UniformId]
drawcall :: Drawcall s
sbinds :: [SamplerId]
ubinds :: [UniformId]
samps :: [SamplerId]
unis :: [UniformId]
drawcall :: Drawcall s
..}

data GpuLimits = GpuLimits
    { GpuLimits -> UniformId
maxUnis      :: UniformId
    , GpuLimits -> SamplerId
maxSamplers  :: SamplerId
    , GpuLimits -> UniformId
maxVUnis     :: UniformId
    , GpuLimits -> SamplerId
maxVSamplers :: SamplerId
    , GpuLimits -> UniformId
maxGUnis     :: UniformId
    , GpuLimits -> SamplerId
maxGSamplers :: SamplerId
    , GpuLimits -> UniformId
maxFUnis     :: UniformId
    , GpuLimits -> SamplerId
maxFSamplers :: SamplerId
    }

getLimits :: IO GpuLimits
getLimits :: IO GpuLimits
getLimits = UniformId
-> SamplerId
-> UniformId
-> SamplerId
-> UniformId
-> SamplerId
-> UniformId
-> SamplerId
-> GpuLimits
GpuLimits
    (UniformId
 -> SamplerId
 -> UniformId
 -> SamplerId
 -> UniformId
 -> SamplerId
 -> UniformId
 -> SamplerId
 -> GpuLimits)
-> IO UniformId
-> IO
     (SamplerId
      -> UniformId
      -> SamplerId
      -> UniformId
      -> SamplerId
      -> UniformId
      -> SamplerId
      -> GpuLimits)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GLuint -> IO UniformId
forall b. Num b => GLuint -> IO b
getLimit GLuint
forall a. (Eq a, Num a) => a
GL_MAX_COMBINED_UNIFORM_BLOCKS
    IO
  (SamplerId
   -> UniformId
   -> SamplerId
   -> UniformId
   -> SamplerId
   -> UniformId
   -> SamplerId
   -> GpuLimits)
-> IO SamplerId
-> IO
     (UniformId
      -> SamplerId
      -> UniformId
      -> SamplerId
      -> UniformId
      -> SamplerId
      -> GpuLimits)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GLuint -> IO SamplerId
forall b. Num b => GLuint -> IO b
getLimit GLuint
forall a. (Eq a, Num a) => a
GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS
    IO
  (UniformId
   -> SamplerId
   -> UniformId
   -> SamplerId
   -> UniformId
   -> SamplerId
   -> GpuLimits)
-> IO UniformId
-> IO
     (SamplerId
      -> UniformId -> SamplerId -> UniformId -> SamplerId -> GpuLimits)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GLuint -> IO UniformId
forall b. Num b => GLuint -> IO b
getLimit GLuint
forall a. (Eq a, Num a) => a
GL_MAX_VERTEX_UNIFORM_BLOCKS
    IO
  (SamplerId
   -> UniformId -> SamplerId -> UniformId -> SamplerId -> GpuLimits)
-> IO SamplerId
-> IO
     (UniformId -> SamplerId -> UniformId -> SamplerId -> GpuLimits)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GLuint -> IO SamplerId
forall b. Num b => GLuint -> IO b
getLimit GLuint
forall a. (Eq a, Num a) => a
GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS
    IO (UniformId -> SamplerId -> UniformId -> SamplerId -> GpuLimits)
-> IO UniformId
-> IO (SamplerId -> UniformId -> SamplerId -> GpuLimits)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GLuint -> IO UniformId
forall b. Num b => GLuint -> IO b
getLimit GLuint
forall a. (Eq a, Num a) => a
GL_MAX_GEOMETRY_UNIFORM_BLOCKS
    IO (SamplerId -> UniformId -> SamplerId -> GpuLimits)
-> IO SamplerId -> IO (UniformId -> SamplerId -> GpuLimits)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GLuint -> IO SamplerId
forall b. Num b => GLuint -> IO b
getLimit GLuint
forall a. (Eq a, Num a) => a
GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS
    IO (UniformId -> SamplerId -> GpuLimits)
-> IO UniformId -> IO (SamplerId -> GpuLimits)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GLuint -> IO UniformId
forall b. Num b => GLuint -> IO b
getLimit GLuint
forall a. (Eq a, Num a) => a
GL_MAX_FRAGMENT_UNIFORM_BLOCKS
    IO (SamplerId -> GpuLimits) -> IO SamplerId -> IO GpuLimits
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GLuint -> IO SamplerId
forall b. Num b => GLuint -> IO b
getLimit GLuint
forall a. (Eq a, Num a) => a
GL_MAX_TEXTURE_IMAGE_UNITS
  where
    getLimit :: GLuint -> IO b
getLimit GLuint
kind = GLint -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLint -> b) -> IO GLint -> IO b
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
kind 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)

{- 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
        ( [CompileInput s]
        , [String] -- The raised errors regarding exceeded limits.
        )
safeGenerateDrawcalls :: [IO (Drawcall s)] -> IO ([CompileInput s], [String])
safeGenerateDrawcalls [IO (Drawcall s)]
protoDrawcalls = do

    -- Retrieve some limits from OpenGL.
    GpuLimits{SamplerId
UniformId
maxFSamplers :: SamplerId
maxFUnis :: UniformId
maxGSamplers :: SamplerId
maxGUnis :: UniformId
maxVSamplers :: SamplerId
maxVUnis :: UniformId
maxSamplers :: SamplerId
maxUnis :: UniformId
maxFSamplers :: GpuLimits -> SamplerId
maxFUnis :: GpuLimits -> UniformId
maxGSamplers :: GpuLimits -> SamplerId
maxGUnis :: GpuLimits -> UniformId
maxVSamplers :: GpuLimits -> SamplerId
maxVUnis :: GpuLimits -> UniformId
maxSamplers :: GpuLimits -> SamplerId
maxUnis :: GpuLimits -> UniformId
..} <- IO GpuLimits
getLimits

    -- 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 :: [[UniformId]]
gUnisPerDrawcall = (Drawcall s -> [UniformId]) -> [Drawcall s] -> [[UniformId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [UniformId]
forall s. Drawcall s -> [UniformId]
usedGUniforms [Drawcall s]
drawcalls
        gSampsPerDrawcall :: [[SamplerId]]
gSampsPerDrawcall = (Drawcall s -> [SamplerId]) -> [Drawcall s] -> [[SamplerId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [SamplerId]
forall s. Drawcall s -> [SamplerId]
usedGSamplers [Drawcall s]
drawcalls
        vUnisPerDrawcall :: [[UniformId]]
vUnisPerDrawcall = (Drawcall s -> [UniformId]) -> [Drawcall s] -> [[UniformId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [UniformId]
forall s. Drawcall s -> [UniformId]
usedVUniforms [Drawcall s]
drawcalls
        vSampsPerDrawcall :: [[SamplerId]]
vSampsPerDrawcall = (Drawcall s -> [SamplerId]) -> [Drawcall s] -> [[SamplerId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [SamplerId]
forall s. Drawcall s -> [SamplerId]
usedVSamplers [Drawcall s]
drawcalls
        fUnisPerDrawcall :: [[UniformId]]
fUnisPerDrawcall = (Drawcall s -> [UniformId]) -> [Drawcall s] -> [[UniformId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [UniformId]
forall s. Drawcall s -> [UniformId]
usedFUniforms [Drawcall s]
drawcalls
        fSampsPerDrawcall :: [[SamplerId]]
fSampsPerDrawcall = (Drawcall s -> [SamplerId]) -> [Drawcall s] -> [[SamplerId]]
forall a b. (a -> b) -> [a] -> [b]
map Drawcall s -> [SamplerId]
forall s. Drawcall s -> [SamplerId]
usedFSamplers [Drawcall s]
drawcalls

        -- Consolidate them for the whole program.
        unisPerDrawcall :: [[UniformId]]
unisPerDrawcall = ([UniformId] -> [UniformId] -> [UniformId])
-> [[UniformId]] -> [[UniformId]] -> [[UniformId]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [UniformId] -> [UniformId] -> [UniformId]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion (([UniformId] -> [UniformId] -> [UniformId])
-> [[UniformId]] -> [[UniformId]] -> [[UniformId]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [UniformId] -> [UniformId] -> [UniformId]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion [[UniformId]]
gUnisPerDrawcall [[UniformId]]
vUnisPerDrawcall) [[UniformId]]
fUnisPerDrawcall
        sampsPerDrawcall :: [[SamplerId]]
sampsPerDrawcall = ([SamplerId] -> [SamplerId] -> [SamplerId])
-> [[SamplerId]] -> [[SamplerId]] -> [[SamplerId]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [SamplerId] -> [SamplerId] -> [SamplerId]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion (([SamplerId] -> [SamplerId] -> [SamplerId])
-> [[SamplerId]] -> [[SamplerId]] -> [[SamplerId]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [SamplerId] -> [SamplerId] -> [SamplerId]
forall a. Ord a => [a] -> [a] -> [a]
orderedUnion [[SamplerId]]
gSampsPerDrawcall [[SamplerId]]
vSampsPerDrawcall) [[SamplerId]]
fSampsPerDrawcall

        -- Produce an error message for each limit exceeded by at least one of the drawcalls.
        limitError :: String -> String -> a -> t (t a) -> [String]
limitError String
kind String
target (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
maxCnt) t (t a)
elts =
            let err :: String
err = String
"Too many " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
kind String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" used in a single " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
target in
            [String
err | (t a -> Bool) -> t (t a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\t a
xs -> t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxCnt) t (t a)
elts]
        limitErrors :: [String]
limitErrors = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String -> String -> UniformId -> [[UniformId]] -> [String]
forall a (t :: * -> *) (t :: * -> *) a.
(Integral a, Foldable t, Foldable t) =>
String -> String -> a -> t (t a) -> [String]
limitError String
"uniform blocks" String
"shader program" UniformId
maxUnis [[UniformId]]
unisPerDrawcall
            , String -> String -> SamplerId -> [[SamplerId]] -> [String]
forall a (t :: * -> *) (t :: * -> *) a.
(Integral a, Foldable t, Foldable t) =>
String -> String -> a -> t (t a) -> [String]
limitError String
"textures" String
"shader program" SamplerId
maxSamplers [[SamplerId]]
sampsPerDrawcall
            , String -> String -> UniformId -> [[UniformId]] -> [String]
forall a (t :: * -> *) (t :: * -> *) a.
(Integral a, Foldable t, Foldable t) =>
String -> String -> a -> t (t a) -> [String]
limitError String
"uniform blocks" String
"vertex shader" UniformId
maxVUnis [[UniformId]]
vUnisPerDrawcall
            , String -> String -> SamplerId -> [[SamplerId]] -> [String]
forall a (t :: * -> *) (t :: * -> *) a.
(Integral a, Foldable t, Foldable t) =>
String -> String -> a -> t (t a) -> [String]
limitError String
"textures" String
"vertex shader" SamplerId
maxVSamplers [[SamplerId]]
vSampsPerDrawcall
            , String -> String -> UniformId -> [[UniformId]] -> [String]
forall a (t :: * -> *) (t :: * -> *) a.
(Integral a, Foldable t, Foldable t) =>
String -> String -> a -> t (t a) -> [String]
limitError String
"uniform blocks" String
"geometry shader" UniformId
maxGUnis [[UniformId]]
gUnisPerDrawcall
            , String -> String -> SamplerId -> [[SamplerId]] -> [String]
forall a (t :: * -> *) (t :: * -> *) a.
(Integral a, Foldable t, Foldable t) =>
String -> String -> a -> t (t a) -> [String]
limitError String
"textures" String
"geometry shader" SamplerId
maxGSamplers [[SamplerId]]
gSampsPerDrawcall
            , String -> String -> UniformId -> [[UniformId]] -> [String]
forall a (t :: * -> *) (t :: * -> *) a.
(Integral a, Foldable t, Foldable t) =>
String -> String -> a -> t (t a) -> [String]
limitError String
"uniform blocks" String
"fragment shader" UniformId
maxFUnis [[UniformId]]
fUnisPerDrawcall
            , String -> String -> SamplerId -> [[SamplerId]] -> [String]
forall a (t :: * -> *) (t :: * -> *) a.
(Integral a, Foldable t, Foldable t) =>
String -> String -> a -> t (t a) -> [String]
limitError String
"textures" String
"fragment shader" SamplerId
maxFSamplers [[SamplerId]]
fSampsPerDrawcall
            ]

        allocatedUniforms :: [[UniformId]]
allocatedUniforms = UniformId -> [[UniformId]] -> [[UniformId]]
forall a. Integral a => a -> [[a]] -> [[a]]
allocateConsecutiveIndexes UniformId
maxUnis [[UniformId]]
unisPerDrawcall
        allocatedSamplers :: [[SamplerId]]
allocatedSamplers = SamplerId -> [[SamplerId]] -> [[SamplerId]]
forall a. Integral a => a -> [[a]] -> [[a]]
allocateConsecutiveIndexes SamplerId
maxSamplers [[SamplerId]]
sampsPerDrawcall

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

-- private
innerCompile :: RenderIOState s -- Interactions between the drawcall and the environment 's'.
    ->  CompileInput s
    ->  IO
        ( Either
            String -- A failure in case the program cannot be compiled or linked.
            ( (IORef GLuint, IO ()) -- The program name and its destructor.
            , CompiledShader os s -- The program's renderer as a function on a render (OpenGL) state. Upper stage called this a 'CompiledShader'.
            )
        )
innerCompile :: RenderIOState s
-> CompileInput s
-> IO (Either String ((IORef GLuint, IO ()), CompiledShader os s))
innerCompile RenderIOState s
state ci :: CompileInput s
ci@CompileInput{Drawcall s
drawcall :: Drawcall s
drawcall :: forall s. CompileInput s -> Drawcall s
drawcall, [UniformId]
unis :: [UniformId]
unis :: forall s. CompileInput s -> [UniformId]
unis, [SamplerId]
samps :: [SamplerId]
samps :: forall s. CompileInput s -> [SamplerId]
samps, [UniformId]
ubinds :: [UniformId]
ubinds :: forall s. CompileInput s -> [UniformId]
ubinds, [SamplerId]
sbinds :: [SamplerId]
sbinds :: forall s. CompileInput s -> [SamplerId]
sbinds} = do
    let vsource :: Text
vsource = Drawcall s -> Text
forall s. Drawcall s -> Text
vertexSource Drawcall s
drawcall
        ogsource :: Maybe Text
ogsource = Drawcall s -> Maybe Text
forall s. Drawcall s -> Maybe Text
optionalGeometrySource Drawcall s
drawcall
        ofsource :: Maybe Text
ofsource = Drawcall s -> Maybe Text
forall s. Drawcall s -> Maybe Text
optionalFragmentSource Drawcall s
drawcall
        inputs :: [Int]
inputs = Drawcall s -> [Int]
forall s. Drawcall s -> [Int]
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 -> Text -> IO (Maybe String)
compileOpenGlShader GLuint
vShader Text
vsource
        -- Compile the optional geometry shader.
        (Maybe GLuint
ogShader, Maybe String
mErrG) <- case Maybe Text
ogsource of
            Maybe Text
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 Text
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 -> Text -> IO (Maybe String)
compileOpenGlShader GLuint
gShader Text
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 Text
ofsource of
            Maybe Text
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 Text
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 -> Text -> IO (Maybe String)
compileOpenGlShader GLuint
fShader Text
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
                ((Int, GLuint) -> IO ()) -> [(Int, GLuint)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Int
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]
++ Int -> String
forall a. Show a => a -> String
show Int
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) ([(Int, GLuint)] -> IO ()) -> [(Int, GLuint)] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> [GLuint] -> [(Int, GLuint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
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 Int
forall s. Drawcall s -> Maybe Int
rasterizationName Drawcall s
drawcall) of
                    (Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
Nothing, Just Int
_) -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    (Just s -> IO (GLuint, GLuint, GLuint, GLuint)
_, Just Int
geoN) -> (RenderIOState s -> IntMap Int (s -> GLuint -> IO ())
forall s. RenderIOState s -> IntMap Int (s -> GLuint -> IO ())
transformFeedbackToRenderIO RenderIOState s
state IntMap Int (s -> GLuint -> IO ()) -> Int -> s -> GLuint -> IO ()
forall k v. Integral k => IntMap k v -> k -> v
! Int
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 -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
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") (Text -> String
T.unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
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") (Text -> String
T.unpack (Text -> String) -> Maybe Text -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
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]
++ Text -> String
T.unpack Text
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]
++ Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
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]
++ Text -> String
T.unpack (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
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 ()), CompiledShader os s)
-> IO (Either String ((IORef GLuint, IO ()), CompiledShader os s))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ((IORef GLuint, IO ()), CompiledShader os s)
 -> IO (Either String ((IORef GLuint, IO ()), CompiledShader os s)))
-> Either String ((IORef GLuint, IO ()), CompiledShader os s)
-> IO (Either String ((IORef GLuint, IO ()), CompiledShader os s))
forall a b. (a -> b) -> a -> b
$ String
-> Either String ((IORef GLuint, IO ()), CompiledShader os s)
forall a b. a -> Either a b
Left String
err
        -- Right: the program wrapped in a Render monad.
        Right GLuint
pName -> ((IORef GLuint, IO ()), CompiledShader os s)
-> Either String ((IORef GLuint, IO ()), CompiledShader os s)
forall a b. b -> Either a b
Right (((IORef GLuint, IO ()), CompiledShader os s)
 -> Either String ((IORef GLuint, IO ()), CompiledShader os s))
-> IO ((IORef GLuint, IO ()), CompiledShader os s)
-> IO (Either String ((IORef GLuint, IO ()), CompiledShader os s))
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 Int
forall s. Drawcall s -> Maybe Int
rasterizationName Drawcall s
drawcall) of
            (Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint))
Nothing, Just Int
rastN) -> RenderIOState s
-> CompileInput s
-> GLuint
-> Int
-> IO ((IORef GLuint, IO ()), CompiledShader os s)
forall s os.
RenderIOState s
-> CompileInput s
-> GLuint
-> Int
-> IO ((IORef GLuint, IO ()), CompiledShader os s)
createRenderer RenderIOState s
state CompileInput s
ci GLuint
pName Int
rastN
            (Just s -> IO (GLuint, GLuint, GLuint, GLuint)
getTransformFeedbackName, Just Int
geoN) -> RenderIOState s
-> CompileInput s
-> GLuint
-> (s -> IO (GLuint, GLuint, GLuint, GLuint))
-> Int
-> IO ((IORef GLuint, IO ()), CompiledShader os s)
forall s os.
RenderIOState s
-> CompileInput s
-> GLuint
-> (s -> IO (GLuint, GLuint, GLuint, GLuint))
-> Int
-> IO ((IORef GLuint, IO ()), CompiledShader os s)
createFeedbackRenderer RenderIOState s
state CompileInput s
ci GLuint
pName s -> IO (GLuint, GLuint, GLuint, GLuint)
getTransformFeedbackName Int
geoN
            (Maybe (s -> IO (GLuint, GLuint, GLuint, GLuint)), Maybe Int)
_ -> String -> IO ((IORef GLuint, IO ()), CompiledShader os s)
forall a. HasCallStack => String -> a
error String
"No rasterization nor feedback!"

-- private
createRenderer :: RenderIOState s -- Interactions between the drawcall and the environment 's'.
    ->  CompileInput s
    ->  GLuint -- pName
    ->  Int
    ->  IO  ( (IORef GLuint, IO ()) -- The program name and its destructor.
            , CompiledShader os s -- The program's renderer as a function on a render (OpenGL) state.
            )
createRenderer :: RenderIOState s
-> CompileInput s
-> GLuint
-> Int
-> IO ((IORef GLuint, IO ()), CompiledShader os s)
createRenderer RenderIOState s
state ci :: CompileInput s
ci@CompileInput{Drawcall s
drawcall :: Drawcall s
drawcall :: forall s. CompileInput s -> Drawcall s
drawcall, [UniformId]
unis :: [UniformId]
unis :: forall s. CompileInput s -> [UniformId]
unis, [UniformId]
ubinds :: [UniformId]
ubinds :: forall s. CompileInput s -> [UniformId]
ubinds, [SamplerId]
samps :: [SamplerId]
samps :: forall s. CompileInput s -> [SamplerId]
samps, [SamplerId]
sbinds :: [SamplerId]
sbinds :: forall s. CompileInput s -> [SamplerId]
sbinds} GLuint
pName Int
rastN = do
    let pstrUSize :: Int
pstrUSize = Drawcall s -> Int
forall s. Drawcall s -> Int
primStrUBufferSize Drawcall s
drawcall

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

    [(UniformId, UniformId)]
-> ((UniformId, UniformId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([UniformId] -> [UniformId] -> [(UniformId, UniformId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UniformId]
unis [UniformId]
ubinds) (((UniformId, UniformId) -> IO ()) -> IO ())
-> ((UniformId, UniformId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(UniformId
name, UniformId
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]
++ UniformId -> String
forall a. Show a => a -> String
show UniformId
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 (UniformId -> GLuint
forall a b. (Integral a, Num b) => a -> b
fromIntegral UniformId
bind)

    GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glUseProgram GLuint
pName -- For setting texture uniforms
    [(SamplerId, SamplerId)]
-> ((SamplerId, SamplerId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([SamplerId] -> [SamplerId] -> [(SamplerId, SamplerId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SamplerId]
samps [SamplerId]
sbinds) (((SamplerId, SamplerId) -> IO ()) -> IO ())
-> ((SamplerId, SamplerId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SamplerId
name, SamplerId
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]
++ SamplerId -> String
forall a. Show a => a -> String
show SamplerId
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 (SamplerId -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral SamplerId
bind)
    IORef GLuint
pNameRef <- GLuint -> IO (IORef GLuint)
forall a. a -> IO (IORef a)
newIORef GLuint
pName

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

    -- Drawing with the program.
    let renderer :: CompiledShader os s
renderer = RenderIOState s
-> CompileInput s
-> IORef GLuint
-> Int
-> IntMap UniformId (s -> Int -> IO ())
-> GLuint
-> Int
-> CompiledShader os s
forall s b os.
RenderIOState s
-> CompileInput s
-> IORef GLuint
-> Int
-> IntMap UniformId (s -> Int -> IO b)
-> GLuint
-> Int
-> CompiledShader os s
createDrawRenderer
            RenderIOState s
state CompileInput s
ci IORef GLuint
pNameRef Int
rastN IntMap UniformId (s -> Int -> IO ())
uNameToRenderIOMap'
            GLuint
pstrUBuf Int
pstrUSize

    let deleter :: IO ()
deleter = do
            GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glDeleteProgram GLuint
pName
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pstrUSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
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 ()), CompiledShader os s)
-> IO ((IORef GLuint, IO ()), CompiledShader os s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((IORef GLuint
pNameRef, IO ()
deleter), CompiledShader os s
forall os. CompiledShader os s
renderer)

createDrawRenderer
    :: RenderIOState s
    -> CompileInput s
    -> IORef GLuint
    -> Int
    -> Map.IntMap UniformId (s -> Binding -> IO b)
    -> GLuint
    -> Int
    -> CompiledShader os s
createDrawRenderer :: RenderIOState s
-> CompileInput s
-> IORef GLuint
-> Int
-> IntMap UniformId (s -> Int -> IO b)
-> GLuint
-> Int
-> CompiledShader os s
createDrawRenderer RenderIOState s
state CompileInput{Drawcall s
drawcall :: Drawcall s
drawcall :: forall s. CompileInput s -> Drawcall s
drawcall, [UniformId]
unis :: [UniformId]
unis :: forall s. CompileInput s -> [UniformId]
unis, [UniformId]
ubinds :: [UniformId]
ubinds :: forall s. CompileInput s -> [UniformId]
ubinds, [SamplerId]
samps :: [SamplerId]
samps :: forall s. CompileInput s -> [SamplerId]
samps, [SamplerId]
sbinds :: [SamplerId]
sbinds :: forall s. CompileInput s -> [SamplerId]
sbinds} IORef GLuint
pNameRef Int
rastN IntMap UniformId (s -> Int -> IO b)
uNameToRenderIOMap' GLuint
pstrUBuf Int
pstrUSize 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
    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 :: Int
primN = Drawcall s -> Int
forall s. Drawcall s -> Int
primitiveName Drawcall s
drawcall
        inputs :: [Int]
inputs = Drawcall s -> [Int]
forall s. Drawcall s -> [Int]
usedInputs Drawcall s
drawcall

    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 WinId (WindowState, IO () -> IO ())
-> Maybe (WindowState, IO () -> IO ())
forall k v. Integral k => k -> IntMap k v -> Maybe v
Map.lookup WinId
windowId (RenderState -> IntMap WinId (WindowState, IO () -> IO ())
perWindowRenderState RenderState
rs) of
                Maybe (WindowState, IO () -> IO ())
Nothing -> () -> ExceptT String (t (StateT RenderState m)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Window deleted
                Just (WindowState
ws, IO () -> IO ()
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
$ (IO () -> IO ()) -> IO (Maybe String) -> IO (Maybe String)
forall x. (IO () -> IO ()) -> IO x -> IO x
asSync IO () -> IO ()
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 UniformId (s -> Int -> IO b)
-> [(UniformId, UniformId)] -> s -> (b -> IO Bool) -> IO Bool
forall a s x.
Integral a =>
IntMap a (s -> Int -> IO x)
-> [(a, a)] -> s -> (x -> IO Bool) -> IO Bool
bind IntMap UniformId (s -> Int -> IO b)
uNameToRenderIOMap' ([UniformId] -> [UniformId] -> [(UniformId, UniformId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UniformId]
unis [UniformId]
ubinds) s
x (IO Bool -> b -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> b -> IO Bool) -> IO Bool -> b -> 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 SamplerId (s -> Int -> IO Int)
-> [(SamplerId, SamplerId)] -> s -> (Int -> IO Bool) -> IO Bool
forall a s x.
Integral a =>
IntMap a (s -> Int -> IO x)
-> [(a, a)] -> s -> (x -> IO Bool) -> IO Bool
bind (RenderIOState s -> IntMap SamplerId (s -> Int -> IO Int)
forall s. RenderIOState s -> IntMap SamplerId (s -> Int -> IO Int)
samplerNameToRenderIO RenderIOState s
state) ([SamplerId] -> [SamplerId] -> [(SamplerId, SamplerId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SamplerId]
samps [SamplerId]
sbinds) s
x (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (Int -> Bool) -> Int -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (Int -> Bool) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IntSet -> Bool
`Set.member` RenderState -> IntSet
renderWriteTextures RenderState
rs))
                        (RenderIOState s -> IntMap Int (s -> IO ())
forall s. RenderIOState s -> IntMap Int (s -> IO ())
rasterizationNameToRenderIO RenderIOState s
state IntMap Int (s -> IO ()) -> Int -> s -> IO ()
forall k v. Integral k => IntMap k v -> k -> v
! Int
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, IO () -> IO ()
doAsync) <- Render Any (WinId, ContextData, IO () -> IO ())
-> ExceptT
     String
     (ReaderT RenderEnv (StateT RenderState IO))
     (WinId, ContextData, IO () -> IO ())
forall os a.
Render os a
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) a
unRender Render Any (WinId, ContextData, IO () -> IO ())
forall os. Render os (WinId, ContextData, IO () -> IO ())
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 (IO () -> IO ()
doAsync (IO () -> IO ()) -> IO () -> IO ()
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 :: Int
numColors = [FBOKey] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([FBOKey] -> Int) -> [FBOKey] -> Int
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
+ Int -> GLuint
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 (Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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_ (((([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ()))
 -> ((IO [VAOKey], IO ()), IO ()))
-> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())]
-> [((IO [VAOKey], IO ()), IO ())]
forall a b. (a -> b) -> [a] -> [b]
map ((([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ()))
-> ([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())
forall a b. (a -> b) -> a -> b
$ ([Int]
inputs, GLuint
pstrUBuf, Int
pstrUSize)) ((RenderIOState s
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
forall s.
RenderIOState s
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
inputArrayToRenderIO RenderIOState s
state IntMap
  Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
-> Int
-> s
-> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())]
forall k v. Integral k => IntMap k v -> k -> v
! Int
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 WinId (WindowState, IO () -> IO ())
-> Maybe (WindowState, IO () -> IO ())
forall k v. Integral k => k -> IntMap k v -> Maybe v
Map.lookup WinId
windowId (RenderState -> IntMap WinId (WindowState, IO () -> IO ())
perWindowRenderState RenderState
rs) of
            Maybe (WindowState, IO () -> IO ())
Nothing -> () -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Window deleted
            Just (WindowState
ws, IO () -> IO ()
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 (IO () -> IO ()
doAsync (IO () -> IO ()) -> IO () -> IO ()
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

-- private
createFeedbackRenderer :: RenderIOState s -- Interactions between the drawcall and the environment 's'.
    ->  CompileInput s
    ->  GLuint -- program name
    ->  (s -> IO (GLuint, GLuint, GLuint, GLuint)) -- transform feedback stuff
    ->  Int
    ->  IO  ( (IORef GLuint, IO ()) -- The program name and its destructor.
            , CompiledShader os s -- The program's renderer as a function on a render (OpenGL) state.
            )
createFeedbackRenderer :: RenderIOState s
-> CompileInput s
-> GLuint
-> (s -> IO (GLuint, GLuint, GLuint, GLuint))
-> Int
-> IO ((IORef GLuint, IO ()), CompiledShader os s)
createFeedbackRenderer RenderIOState s
state CompileInput{Drawcall s
drawcall :: Drawcall s
drawcall :: forall s. CompileInput s -> Drawcall s
drawcall, [UniformId]
unis :: [UniformId]
unis :: forall s. CompileInput s -> [UniformId]
unis, [UniformId]
ubinds :: [UniformId]
ubinds :: forall s. CompileInput s -> [UniformId]
ubinds, [SamplerId]
samps :: [SamplerId]
samps :: forall s. CompileInput s -> [SamplerId]
samps, [SamplerId]
sbinds :: [SamplerId]
sbinds :: forall s. CompileInput s -> [SamplerId]
sbinds} GLuint
pName s -> IO (GLuint, GLuint, GLuint, GLuint)
getTransformFeedbackName Int
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 :: Int
primN = Drawcall s -> Int
forall s. Drawcall s -> Int
primitiveName Drawcall s
drawcall
        inputs :: [Int]
inputs = Drawcall s -> [Int]
forall s. Drawcall s -> [Int]
usedInputs Drawcall s
drawcall
        pstrUSize :: Int
pstrUSize = Drawcall s -> Int
forall s. Drawcall s -> Int
primStrUBufferSize Drawcall s
drawcall

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

    [(UniformId, UniformId)]
-> ((UniformId, UniformId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([UniformId] -> [UniformId] -> [(UniformId, UniformId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UniformId]
unis [UniformId]
ubinds) (((UniformId, UniformId) -> IO ()) -> IO ())
-> ((UniformId, UniformId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(UniformId
name, UniformId
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]
++ UniformId -> String
forall a. Show a => a -> String
show UniformId
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 (UniformId -> GLuint
forall a b. (Integral a, Num b) => a -> b
fromIntegral UniformId
bind)

    GLuint -> IO ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glUseProgram GLuint
pName -- For setting texture uniforms
    [(SamplerId, SamplerId)]
-> ((SamplerId, SamplerId) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([SamplerId] -> [SamplerId] -> [(SamplerId, SamplerId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SamplerId]
samps [SamplerId]
sbinds) (((SamplerId, SamplerId) -> IO ()) -> IO ())
-> ((SamplerId, SamplerId) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SamplerId
name, SamplerId
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]
++ SamplerId -> String
forall a. Show a => a -> String
show SamplerId
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 (SamplerId -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral SamplerId
bind)
    IORef GLuint
pNameRef <- GLuint -> IO (IORef GLuint)
forall a. a -> IO (IORef a)
newIORef GLuint
pName

    let uNameToRenderIOMap :: IntMap UniformId (s -> Int -> IO ())
uNameToRenderIOMap = RenderIOState s -> IntMap UniformId (s -> Int -> IO ())
forall s. RenderIOState s -> IntMap UniformId (s -> Int -> IO ())
uniformNameToRenderIO RenderIOState s
state
        uNameToRenderIOMap' :: IntMap UniformId (s -> Int -> IO ())
uNameToRenderIOMap' = GLuint
-> Int
-> IntMap UniformId (s -> Int -> IO ())
-> IntMap UniformId (s -> Int -> IO ())
forall s.
GLuint
-> Int
-> IntMap UniformId (s -> Int -> IO ())
-> IntMap UniformId (s -> Int -> IO ())
addPrimitiveStreamUniform GLuint
pstrUBuf Int
pstrUSize' IntMap UniformId (s -> Int -> 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 WinId (WindowState, IO () -> IO ())
-> Maybe (WindowState, IO () -> IO ())
forall k v. Integral k => k -> IntMap k v -> Maybe v
Map.lookup WinId
windowId (RenderState -> IntMap WinId (WindowState, IO () -> IO ())
perWindowRenderState RenderState
rs) of
                Maybe (WindowState, IO () -> IO ())
Nothing -> () -> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Window deleted
                Just (WindowState
ws, IO () -> IO ()
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
$ (IO () -> IO ()) -> IO () -> IO ()
forall x. (IO () -> IO ()) -> IO x -> IO x
asSync IO () -> IO ()
doAsync (IO () -> IO ()) -> IO () -> IO ()
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 UniformId (s -> Int -> IO ())
-> [(UniformId, UniformId)] -> s -> (() -> IO Bool) -> IO Bool
forall a s x.
Integral a =>
IntMap a (s -> Int -> IO x)
-> [(a, a)] -> s -> (x -> IO Bool) -> IO Bool
bind IntMap UniformId (s -> Int -> IO ())
uNameToRenderIOMap' ([UniformId] -> [UniformId] -> [(UniformId, UniformId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UniformId]
unis [UniformId]
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 SamplerId (s -> Int -> IO Int)
-> [(SamplerId, SamplerId)] -> s -> (Int -> IO Bool) -> IO Bool
forall a s x.
Integral a =>
IntMap a (s -> Int -> IO x)
-> [(a, a)] -> s -> (x -> IO Bool) -> IO Bool
bind (RenderIOState s -> IntMap SamplerId (s -> Int -> IO Int)
forall s. RenderIOState s -> IntMap SamplerId (s -> Int -> IO Int)
samplerNameToRenderIO RenderIOState s
state) ([SamplerId] -> [SamplerId] -> [(SamplerId, SamplerId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SamplerId]
samps [SamplerId]
sbinds) s
x (Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> (Int -> Bool) -> Int -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (Int -> Bool) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> 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_ (((([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ()))
 -> ((IO [VAOKey], IO ()), IO ()))
-> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())]
-> [((IO [VAOKey], IO ()), IO ())]
forall a b. (a -> b) -> [a] -> [b]
map ((([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ()))
-> ([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())
forall a b. (a -> b) -> a -> b
$ ([Int]
inputs, GLuint
pstrUBuf, Int
pstrUSize)) ((RenderIOState s
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
forall s.
RenderIOState s
-> IntMap
     Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
inputArrayToRenderIO RenderIOState s
state IntMap
  Int (s -> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())])
-> Int
-> s
-> [([Int], GLuint, Int) -> ((IO [VAOKey], IO ()), IO ())]
forall k v. Integral k => IntMap k v -> k -> v
! Int
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 (IO () -> IO ()
doAsync (IO () -> IO ()) -> IO () -> IO ()
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 -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pstrUSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
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 ()), CompiledShader os s)
-> IO ((IORef GLuint, IO ()), CompiledShader os s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((IORef GLuint
pNameRef, IO ()
deleter), CompiledShader os s
forall os. s -> Render os ()
renderer)

-- private
compileOpenGlShader :: GLuint -> Text -> IO (Maybe String)
compileOpenGlShader :: GLuint -> Text -> IO (Maybe String)
compileOpenGlShader GLuint
name Text
source = do
    -- writeFile ("shaders/" ++ show name ++ ".glsl") source -- For debug purposes only.
    Text -> (CStringLen -> IO ()) -> IO ()
forall a. Text -> (CStringLen -> IO a) -> IO a
T.withCStringLen (Text -> Text
T.toStrict Text
source) ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(CString
ptr, Int
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 (Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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' :: Int
logLen' = GLint -> Int
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
$ Int -> (CString -> IO String) -> IO String
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
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' :: Int
logLen' = GLint -> Int
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
$ Int -> (CString -> IO String) -> IO String
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
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 UniformId (s -> Binding -> IO ()) -> Map.IntMap UniformId (s -> Binding -> IO ())
addPrimitiveStreamUniform :: GLuint
-> Int
-> IntMap UniformId (s -> Int -> IO ())
-> IntMap UniformId (s -> Int -> IO ())
addPrimitiveStreamUniform GLuint
_ Int
0 = IntMap UniformId (s -> Int -> IO ())
-> IntMap UniformId (s -> Int -> IO ())
forall a. a -> a
id
addPrimitiveStreamUniform GLuint
bname Int
uSize =
    UniformId
-> (s -> Int -> IO ())
-> IntMap UniformId (s -> Int -> IO ())
-> IntMap UniformId (s -> Int -> IO ())
forall k v. Integral k => k -> v -> IntMap k v -> IntMap k v
Map.insert UniformId
0 ((s -> Int -> IO ())
 -> IntMap UniformId (s -> Int -> IO ())
 -> IntMap UniformId (s -> Int -> IO ()))
-> (s -> Int -> IO ())
-> IntMap UniformId (s -> Int -> IO ())
-> IntMap UniformId (s -> Int -> IO ())
forall a b. (a -> b) -> a -> b
$ \s
_ Int
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 (Int -> GLuint
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bind) GLuint
bname GLsizeiptr
0 (Int -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
uSize)

-- private
bind :: Integral a => Map.IntMap a (s -> Binding -> IO x)
    -> [(a, a)]
    -> s
    -> (x -> IO Bool) -- Used to assert we may use textures bound as render targets
    -> IO Bool
bind :: IntMap a (s -> Int -> IO x)
-> [(a, a)] -> s -> (x -> IO Bool) -> IO Bool
bind IntMap a (s -> Int -> IO x)
iom ((a
n,a
b):[(a, a)]
xs) s
s x -> IO Bool
a = do
    Bool
ok1 <- IntMap a (s -> Int -> IO x)
-> [(a, a)] -> s -> (x -> IO Bool) -> IO Bool
forall a s x.
Integral a =>
IntMap a (s -> Int -> IO x)
-> [(a, a)] -> s -> (x -> IO Bool) -> IO Bool
bind IntMap a (s -> Int -> IO x)
iom [(a, a)]
xs s
s x -> IO Bool
a
    Bool
ok2 <- (IntMap a (s -> Int -> IO x)
iom IntMap a (s -> Int -> IO x) -> a -> s -> Int -> IO x
forall k v. Integral k => IntMap k v -> k -> v
! a
n) s
s (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
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 a (s -> Int -> 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 :: Int -> [[Int]] -> [[Int]]
oldAllocateWhichGiveStrangeResults Int
mx = IntMap Int Int -> [Int] -> [[Int]] -> [[Int]]
allocate' IntMap Int Int
forall k v. IntMap k v
Map.empty [] where
    allocate' :: IntMap Int Int -> [Int] -> [[Int]] -> [[Int]]
allocate' IntMap Int Int
m [Int]
ys ((Int
x:[Int]
xs):[[Int]]
xss)
        | Just Int
a <- Int -> IntMap Int Int -> Maybe Int
forall k v. Integral k => k -> IntMap k v -> Maybe v
Map.lookup Int
x IntMap Int Int
m = IntMap Int Int -> [Int] -> [[Int]] -> [[Int]]
allocate' IntMap Int Int
m (Int
aInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ys) ([Int]
xs[Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
:[[Int]]
xss)
        | Int
ms <- IntMap Int Int -> Int
forall k v. IntMap k v -> Int
Map.size IntMap Int Int
m, Int
ms Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mx = IntMap Int Int -> [Int] -> [[Int]] -> [[Int]]
allocate' (Int -> Int -> IntMap Int Int -> IntMap Int Int
forall k v. Integral k => k -> v -> IntMap k v -> IntMap k v
Map.insert Int
x Int
ms IntMap Int Int
m) (Int
msInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ys) ([Int]
xs[Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
:[[Int]]
xss)
        | Bool
otherwise =
            let (Int
ek,Int
ev) = IntMap Int Int -> Int -> [Int] -> (Int, Int)
forall a t b.
(Ord t, Integral a, Num t) =>
IntMap a b -> t -> [a] -> (a, b)
findLastUsed IntMap Int Int
m Int
mx ([Int]
ys [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
xs [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int]]
xss)
            in IntMap Int Int -> [Int] -> [[Int]] -> [[Int]]
allocate' (Int -> Int -> IntMap Int Int -> IntMap Int Int
forall k v. Integral k => k -> v -> IntMap k v -> IntMap k v
Map.insert Int
x Int
ev (Int -> IntMap Int Int -> IntMap Int Int
forall k v. Integral k => k -> IntMap k v -> IntMap k v
Map.delete Int
ek IntMap Int Int
m)) (Int
evInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ys) ([Int]
xs[Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
:[[Int]]
xss)
    allocate' IntMap Int Int
m [Int]
ys ([Int]
_:[[Int]]
xss) = [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
ys [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: IntMap Int Int -> [Int] -> [[Int]] -> [[Int]]
allocate' IntMap Int Int
m [] [[Int]]
xss
    allocate' IntMap Int Int
_ [Int]
_ [] = []

    findLastUsed :: IntMap a b -> t -> [a] -> (a, b)
findLastUsed IntMap a b
m t
n (a
x:[a]
xs) | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
1 =
        let (Maybe b
a, IntMap a b
m') = (a -> b -> Maybe b) -> a -> IntMap a b -> (Maybe b, IntMap a b)
forall k v.
Integral k =>
(k -> v -> Maybe v) -> k -> IntMap k v -> (Maybe v, IntMap k v)
Map.updateLookupWithKey ((b -> Maybe b) -> a -> b -> Maybe b
forall a b. a -> b -> a
const ((b -> Maybe b) -> a -> b -> Maybe b)
-> (b -> Maybe b) -> a -> 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) a
x IntMap a 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 a b -> t -> [a] -> (a, b)
findLastUsed IntMap a b
m' t
n' [a]
xs
    findLastUsed IntMap a b
m t
_ [a]
_ = [(a, b)] -> (a, b)
forall a. [a] -> a
head ([(a, b)] -> (a, b)) -> [(a, b)] -> (a, b)
forall a b. (a -> b) -> a -> b
$ IntMap a b -> [(a, b)]
forall k v. Integral k => IntMap k v -> [(k, v)]
Map.toList IntMap a 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 :: Integral a => a -> [[a]] -> [[a]]
allocateConsecutiveIndexes :: a -> [[a]] -> [[a]]
allocateConsecutiveIndexes a
mx [[a]]
values = State (IntMap a a) [[a]] -> IntMap a a -> [[a]]
forall s a. State s a -> s -> a
evalState (([a] -> StateT (IntMap a a) Identity [a])
-> [[a]] -> State (IntMap a a) [[a]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((a -> StateT (IntMap a a) Identity a)
-> [a] -> StateT (IntMap a a) Identity [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> StateT (IntMap a a) Identity a
forall (m :: * -> *) k.
(Monad m, Integral k) =>
k -> StateT (IntMap k a) m a
allocateIndex) [[a]]
values) IntMap a a
forall k v. IntMap k v
Map.empty where
    allocateIndex :: k -> StateT (IntMap k a) m a
allocateIndex k
n = do
        IntMap k a
mapping <- StateT (IntMap k a) m (IntMap k a)
forall (m :: * -> *) s. Monad m => StateT s m s
get
        case k -> IntMap k a -> Maybe a
forall k v. Integral k => k -> IntMap k v -> Maybe v
Map.lookup k
n IntMap k a
mapping of
            Maybe a
Nothing -> do
                let m :: a
m = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ IntMap k a -> Int
forall k v. IntMap k v -> Int
Map.size IntMap k a
mapping
                if a
m a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
mx
                    then do
                        IntMap k a -> StateT (IntMap k a) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (IntMap k a -> StateT (IntMap k a) m ())
-> IntMap k a -> StateT (IntMap k a) m ()
forall a b. (a -> b) -> a -> b
$ k -> a -> IntMap k a -> IntMap k a
forall k v. Integral k => k -> v -> IntMap k v -> IntMap k v
Map.insert k
n a
m IntMap k a
mapping
                        a -> StateT (IntMap k a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
m
                    else String -> StateT (IntMap k a) m a
forall a. HasCallStack => String -> a
error String
"Not enough indexes available!"
            Just a
m -> a -> StateT (IntMap k a) m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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)