{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TypeFamilies               #-}

module Graphics.GPipe.Internal.Context
(
    ContextHandler(..),
    ContextT(),
    GPipeException(..),
    runContextT,
    newWindow,
    deleteWindow,
    swapWindowBuffers,
    getFrameBufferSize,
    withContextWindow,
    WindowState(..),
    RenderState(..),
    liftNonWinContextIO,
    liftNonWinContextAsyncIO,
    addContextFinalizer,
    Window(..),
    addVAOBufferFinalizer,
    addFBOTextureFinalizer,
    getVAO, setVAO,
    getFBO, setFBO,
    ContextData,
    VAOKey(..), FBOKey(..), FBOKeys(..),
    Render(..), render,
    registerRenderWriteTexture,
    getLastRenderWin,
    asSync
)
where

import           Control.Concurrent.MVar          (MVar, modifyMVar_,
                                                   newEmptyMVar, newMVar,
                                                   putMVar, readMVar, takeMVar)
import           Control.Exception                (throwIO)
import           Control.Monad                    (void)
import           Control.Monad.Exception          (Exception,
                                                   MonadAsyncException,
                                                   MonadException, bracket)
import qualified Control.Monad.Fail               as MF
import           Control.Monad.IO.Class           (MonadIO (..))
import           Control.Monad.Trans.Class        (MonadTrans (..))
import           Control.Monad.Trans.Except       (ExceptT (..), runExceptT)
import           Control.Monad.Trans.Reader       (ReaderT (..), ask, asks)
import           Control.Monad.Trans.State.Strict (StateT (runStateT),
                                                   evalStateT, get, gets,
                                                   modify, put)
import           Data.IORef                       (IORef, mkWeakIORef,
                                                   readIORef)
import           Data.IntMap                      ((!))
import qualified Data.IntMap.Strict               as IMap
import qualified Data.IntSet                      as Set
import qualified Data.Map.Strict                  as Map
import           Data.Maybe                       (maybeToList)
import           Data.Typeable                    (Typeable)
import           Graphics.GL.Core45
import           Graphics.GL.Types                (GLint, GLuint)
import           Graphics.GPipe.Internal.Format   (WindowBits, WindowFormat,
                                                   windowBits)
import           Linear.V2                        (V2 (..))

-- | Class implementing a window handler that can create openGL contexts, such as GLFW or GLUT
class ContextHandler ctx where
  -- | Implementation specific context handler parameters, eg error handling and event processing policies
  data ContextHandlerParameters ctx
  -- | Implementation specific window type
  type ContextWindow ctx
  -- | Implementation specific window parameters, eg initial size and border decoration
  type WindowParameters ctx
  -- | Create a context handler. Called from the main thread
  contextHandlerCreate :: ContextHandlerParameters ctx -> IO ctx
  -- | Delete the context handler. All contexts created from this handler will be deleted using contextDelete prior to calling this.
  contextHandlerDelete :: ctx -> IO ()
  -- | Create a new context sharing all other contexts created by this ContextHandler. If the parameter is Nothing,
  --   a hidden off-screen context is created, otherwise creates a window with the provided window bits and implementation specific parameters.
  --   Only ever called from the mainthread (i.e. the thread that called contextHandlerCreate).
  createContext :: ctx -> Maybe (WindowBits, WindowParameters ctx) -> IO (ContextWindow ctx)
  -- | Run an OpenGL IO action in this context, that doesn't return any value to the caller. This may be run after contextDelete or contextHandlerDelete has been called.
  --   The thread calling this may not be the same creating the context (for finalizers it is most definetly not).
  --   May also be called on previously deleted windows in the case of finalizers.
  contextDoAsync :: ctx -> Maybe (ContextWindow ctx) -> IO () -> IO ()
  -- | Swap the front and back buffers in the context's default frame buffer.
  --   Only ever called from the mainthread (i.e. the thread that called 'contextHandlerCreate').
  --   Never called on deleted windows.
  contextSwap :: ctx -> ContextWindow ctx -> IO ()
  -- | Get the current size of the context's default framebuffer (which may change if the window is resized).
  --   Only ever called from the mainthread (i.e. the thread that called 'contextHandlerCreate')
  contextFrameBufferSize :: ctx -> ContextWindow ctx -> IO (Int, Int)
  -- | Delete a context and close any associated window.
  --   Only ever called from the mainthread (i.e. the thread that called 'contextHandlerCreate'). Only ever called once per window,
  --   and will always be called for each window before the context is deleted with 'contextHandlerDelete'.
  contextDelete :: ctx -> ContextWindow ctx -> IO ()


-- | The monad transformer that encapsulates a GPipe context (which wraps an OpenGl context).
--
--   A value of type @ContextT ctx os m a@ is an action on a context with these parameters:
--
--   [@ctx@] The context handler.
--
--   [@os@] An abstract type that is used to denote the object space. This is an forall type defined by the 'runContextT' call which will restrict any objects created inside this context
--          to be returned from it or used by another context (the same trick as the 'ST' monad uses).
--
--   [@m@] The monad this monad transformer wraps. Need to have 'IO' in the bottom for this 'ContextT' to be runnable.
--
--   [@a@] The value returned from this monad action.
--
newtype ContextT ctx os m a =
    ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a)
    deriving (a -> ContextT ctx os m b -> ContextT ctx os m a
(a -> b) -> ContextT ctx os m a -> ContextT ctx os m b
(forall a b.
 (a -> b) -> ContextT ctx os m a -> ContextT ctx os m b)
-> (forall a b. a -> ContextT ctx os m b -> ContextT ctx os m a)
-> Functor (ContextT ctx os m)
forall a b. a -> ContextT ctx os m b -> ContextT ctx os m a
forall a b. (a -> b) -> ContextT ctx os m a -> ContextT ctx os m b
forall ctx os (m :: * -> *) a b.
Functor m =>
a -> ContextT ctx os m b -> ContextT ctx os m a
forall ctx os (m :: * -> *) a b.
Functor m =>
(a -> b) -> ContextT ctx os m a -> ContextT ctx os m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ContextT ctx os m b -> ContextT ctx os m a
$c<$ :: forall ctx os (m :: * -> *) a b.
Functor m =>
a -> ContextT ctx os m b -> ContextT ctx os m a
fmap :: (a -> b) -> ContextT ctx os m a -> ContextT ctx os m b
$cfmap :: forall ctx os (m :: * -> *) a b.
Functor m =>
(a -> b) -> ContextT ctx os m a -> ContextT ctx os m b
Functor, Functor (ContextT ctx os m)
a -> ContextT ctx os m a
Functor (ContextT ctx os m)
-> (forall a. a -> ContextT ctx os m a)
-> (forall a b.
    ContextT ctx os m (a -> b)
    -> ContextT ctx os m a -> ContextT ctx os m b)
-> (forall a b c.
    (a -> b -> c)
    -> ContextT ctx os m a
    -> ContextT ctx os m b
    -> ContextT ctx os m c)
-> (forall a b.
    ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b)
-> (forall a b.
    ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a)
-> Applicative (ContextT ctx os m)
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
ContextT ctx os m (a -> b)
-> ContextT ctx os m a -> ContextT ctx os m b
(a -> b -> c)
-> ContextT ctx os m a
-> ContextT ctx os m b
-> ContextT ctx os m c
forall a. a -> ContextT ctx os m a
forall a b.
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
forall a b.
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
forall a b.
ContextT ctx os m (a -> b)
-> ContextT ctx os m a -> ContextT ctx os m b
forall a b c.
(a -> b -> c)
-> ContextT ctx os m a
-> ContextT ctx os m b
-> ContextT ctx os m c
forall ctx os (m :: * -> *). Monad m => Functor (ContextT ctx os m)
forall ctx os (m :: * -> *) a. Monad m => a -> ContextT ctx os m a
forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m (a -> b)
-> ContextT ctx os m a -> ContextT ctx os m b
forall ctx os (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ContextT ctx os m a
-> ContextT ctx os m b
-> ContextT ctx os m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
$c<* :: forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
*> :: ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
$c*> :: forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
liftA2 :: (a -> b -> c)
-> ContextT ctx os m a
-> ContextT ctx os m b
-> ContextT ctx os m c
$cliftA2 :: forall ctx os (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ContextT ctx os m a
-> ContextT ctx os m b
-> ContextT ctx os m c
<*> :: ContextT ctx os m (a -> b)
-> ContextT ctx os m a -> ContextT ctx os m b
$c<*> :: forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m (a -> b)
-> ContextT ctx os m a -> ContextT ctx os m b
pure :: a -> ContextT ctx os m a
$cpure :: forall ctx os (m :: * -> *) a. Monad m => a -> ContextT ctx os m a
$cp1Applicative :: forall ctx os (m :: * -> *). Monad m => Functor (ContextT ctx os m)
Applicative, Applicative (ContextT ctx os m)
a -> ContextT ctx os m a
Applicative (ContextT ctx os m)
-> (forall a b.
    ContextT ctx os m a
    -> (a -> ContextT ctx os m b) -> ContextT ctx os m b)
-> (forall a b.
    ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b)
-> (forall a. a -> ContextT ctx os m a)
-> Monad (ContextT ctx os m)
ContextT ctx os m a
-> (a -> ContextT ctx os m b) -> ContextT ctx os m b
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
forall a. a -> ContextT ctx os m a
forall a b.
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
forall a b.
ContextT ctx os m a
-> (a -> ContextT ctx os m b) -> ContextT ctx os m b
forall ctx os (m :: * -> *).
Monad m =>
Applicative (ContextT ctx os m)
forall ctx os (m :: * -> *) a. Monad m => a -> ContextT ctx os m a
forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m a
-> (a -> ContextT ctx os m b) -> ContextT ctx os m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ContextT ctx os m a
$creturn :: forall ctx os (m :: * -> *) a. Monad m => a -> ContextT ctx os m a
>> :: ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
$c>> :: forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m b
>>= :: ContextT ctx os m a
-> (a -> ContextT ctx os m b) -> ContextT ctx os m b
$c>>= :: forall ctx os (m :: * -> *) a b.
Monad m =>
ContextT ctx os m a
-> (a -> ContextT ctx os m b) -> ContextT ctx os m b
$cp1Monad :: forall ctx os (m :: * -> *).
Monad m =>
Applicative (ContextT ctx os m)
Monad, Monad (ContextT ctx os m)
Monad (ContextT ctx os m)
-> (forall a. IO a -> ContextT ctx os m a)
-> MonadIO (ContextT ctx os m)
IO a -> ContextT ctx os m a
forall a. IO a -> ContextT ctx os m a
forall ctx os (m :: * -> *). MonadIO m => Monad (ContextT ctx os m)
forall ctx os (m :: * -> *) a.
MonadIO m =>
IO a -> ContextT ctx os m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> ContextT ctx os m a
$cliftIO :: forall ctx os (m :: * -> *) a.
MonadIO m =>
IO a -> ContextT ctx os m a
$cp1MonadIO :: forall ctx os (m :: * -> *). MonadIO m => Monad (ContextT ctx os m)
MonadIO, Monad (ContextT ctx os m)
e -> ContextT ctx os m a
Monad (ContextT ctx os m)
-> (forall e a. Exception e => e -> ContextT ctx os m a)
-> (forall e a.
    Exception e =>
    ContextT ctx os m a
    -> (e -> ContextT ctx os m a) -> ContextT ctx os m a)
-> (forall a b.
    ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a)
-> MonadException (ContextT ctx os m)
ContextT ctx os m a
-> (e -> ContextT ctx os m a) -> ContextT ctx os m a
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
forall e a. Exception e => e -> ContextT ctx os m a
forall e a.
Exception e =>
ContextT ctx os m a
-> (e -> ContextT ctx os m a) -> ContextT ctx os m a
forall a b.
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
forall ctx os (m :: * -> *).
MonadException m =>
Monad (ContextT ctx os m)
forall ctx os (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> ContextT ctx os m a
forall ctx os (m :: * -> *) e a.
(MonadException m, Exception e) =>
ContextT ctx os m a
-> (e -> ContextT ctx os m a) -> ContextT ctx os m a
forall ctx os (m :: * -> *) a b.
MonadException m =>
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
forall (m :: * -> *).
Monad m
-> (forall e a. Exception e => e -> m a)
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> (forall a b. m a -> m b -> m a)
-> MonadException m
finally :: ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
$cfinally :: forall ctx os (m :: * -> *) a b.
MonadException m =>
ContextT ctx os m a -> ContextT ctx os m b -> ContextT ctx os m a
catch :: ContextT ctx os m a
-> (e -> ContextT ctx os m a) -> ContextT ctx os m a
$ccatch :: forall ctx os (m :: * -> *) e a.
(MonadException m, Exception e) =>
ContextT ctx os m a
-> (e -> ContextT ctx os m a) -> ContextT ctx os m a
throw :: e -> ContextT ctx os m a
$cthrow :: forall ctx os (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> ContextT ctx os m a
$cp1MonadException :: forall ctx os (m :: * -> *).
MonadException m =>
Monad (ContextT ctx os m)
MonadException, MonadIO (ContextT ctx os m)
MonadException (ContextT ctx os m)
MonadIO (ContextT ctx os m)
-> MonadException (ContextT ctx os m)
-> (forall b.
    ((forall a. ContextT ctx os m a -> ContextT ctx os m a)
     -> ContextT ctx os m b)
    -> ContextT ctx os m b)
-> MonadAsyncException (ContextT ctx os m)
((forall a. ContextT ctx os m a -> ContextT ctx os m a)
 -> ContextT ctx os m b)
-> ContextT ctx os m b
forall b.
((forall a. ContextT ctx os m a -> ContextT ctx os m a)
 -> ContextT ctx os m b)
-> ContextT ctx os m b
forall ctx os (m :: * -> *).
MonadAsyncException m =>
MonadIO (ContextT ctx os m)
forall ctx os (m :: * -> *).
MonadAsyncException m =>
MonadException (ContextT ctx os m)
forall ctx os (m :: * -> *) b.
MonadAsyncException m =>
((forall a. ContextT ctx os m a -> ContextT ctx os m a)
 -> ContextT ctx os m b)
-> ContextT ctx os m b
forall (m :: * -> *).
MonadIO m
-> MonadException m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> MonadAsyncException m
mask :: ((forall a. ContextT ctx os m a -> ContextT ctx os m a)
 -> ContextT ctx os m b)
-> ContextT ctx os m b
$cmask :: forall ctx os (m :: * -> *) b.
MonadAsyncException m =>
((forall a. ContextT ctx os m a -> ContextT ctx os m a)
 -> ContextT ctx os m b)
-> ContextT ctx os m b
$cp2MonadAsyncException :: forall ctx os (m :: * -> *).
MonadAsyncException m =>
MonadException (ContextT ctx os m)
$cp1MonadAsyncException :: forall ctx os (m :: * -> *).
MonadAsyncException m =>
MonadIO (ContextT ctx os m)
MonadAsyncException)

data ContextEnv ctx = ContextEnv {
    ContextEnv ctx -> ctx
context           :: ctx,
    ContextEnv ctx -> SharedContextDatas
sharedContextData :: SharedContextDatas
  }

data ContextState ctx = ContextState {
    ContextState ctx -> Name
nextName       :: Name,
    ContextState ctx -> PerWindowState ctx
perWindowState :: PerWindowState ctx,
    ContextState ctx -> Name
lastUsedWin    :: Name -- -1 is no window. 0 is the hidden window. 1.. are visible windows
  }

-- | A monad in which shaders are run.
newtype Render os a = Render { Render os a
-> ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) a
unRender :: ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) a } deriving (Applicative (Render os)
a -> Render os a
Applicative (Render os)
-> (forall a b. Render os a -> (a -> Render os b) -> Render os b)
-> (forall a b. Render os a -> Render os b -> Render os b)
-> (forall a. a -> Render os a)
-> Monad (Render os)
Render os a -> (a -> Render os b) -> Render os b
Render os a -> Render os b -> Render os b
forall os. Applicative (Render os)
forall a. a -> Render os a
forall os a. a -> Render os a
forall a b. Render os a -> Render os b -> Render os b
forall a b. Render os a -> (a -> Render os b) -> Render os b
forall os a b. Render os a -> Render os b -> Render os b
forall os a b. Render os a -> (a -> Render os b) -> Render os b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Render os a
$creturn :: forall os a. a -> Render os a
>> :: Render os a -> Render os b -> Render os b
$c>> :: forall os a b. Render os a -> Render os b -> Render os b
>>= :: Render os a -> (a -> Render os b) -> Render os b
$c>>= :: forall os a b. Render os a -> (a -> Render os b) -> Render os b
$cp1Monad :: forall os. Applicative (Render os)
Monad, Functor (Render os)
a -> Render os a
Functor (Render os)
-> (forall a. a -> Render os a)
-> (forall a b. Render os (a -> b) -> Render os a -> Render os b)
-> (forall a b c.
    (a -> b -> c) -> Render os a -> Render os b -> Render os c)
-> (forall a b. Render os a -> Render os b -> Render os b)
-> (forall a b. Render os a -> Render os b -> Render os a)
-> Applicative (Render os)
Render os a -> Render os b -> Render os b
Render os a -> Render os b -> Render os a
Render os (a -> b) -> Render os a -> Render os b
(a -> b -> c) -> Render os a -> Render os b -> Render os c
forall os. Functor (Render os)
forall a. a -> Render os a
forall os a. a -> Render os a
forall a b. Render os a -> Render os b -> Render os a
forall a b. Render os a -> Render os b -> Render os b
forall a b. Render os (a -> b) -> Render os a -> Render os b
forall os a b. Render os a -> Render os b -> Render os a
forall os a b. Render os a -> Render os b -> Render os b
forall os a b. Render os (a -> b) -> Render os a -> Render os b
forall a b c.
(a -> b -> c) -> Render os a -> Render os b -> Render os c
forall os a b c.
(a -> b -> c) -> Render os a -> Render os b -> Render os c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Render os a -> Render os b -> Render os a
$c<* :: forall os a b. Render os a -> Render os b -> Render os a
*> :: Render os a -> Render os b -> Render os b
$c*> :: forall os a b. Render os a -> Render os b -> Render os b
liftA2 :: (a -> b -> c) -> Render os a -> Render os b -> Render os c
$cliftA2 :: forall os a b c.
(a -> b -> c) -> Render os a -> Render os b -> Render os c
<*> :: Render os (a -> b) -> Render os a -> Render os b
$c<*> :: forall os a b. Render os (a -> b) -> Render os a -> Render os b
pure :: a -> Render os a
$cpure :: forall os a. a -> Render os a
$cp1Applicative :: forall os. Functor (Render os)
Applicative, a -> Render os b -> Render os a
(a -> b) -> Render os a -> Render os b
(forall a b. (a -> b) -> Render os a -> Render os b)
-> (forall a b. a -> Render os b -> Render os a)
-> Functor (Render os)
forall a b. a -> Render os b -> Render os a
forall a b. (a -> b) -> Render os a -> Render os b
forall os a b. a -> Render os b -> Render os a
forall os a b. (a -> b) -> Render os a -> Render os b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Render os b -> Render os a
$c<$ :: forall os a b. a -> Render os b -> Render os a
fmap :: (a -> b) -> Render os a -> Render os b
$cfmap :: forall os a b. (a -> b) -> Render os a -> Render os b
Functor)

data RenderEnv = RenderEnv {
    RenderEnv -> SharedContextDatas
renderSharedContextData :: SharedContextDatas,
    RenderEnv -> ContextDoAsync
nonWindowDoAsync        :: ContextDoAsync
  }

data RenderState = RenderState {
    RenderState -> PerWindowRenderState
perWindowRenderState :: PerWindowRenderState,
    RenderState -> IntSet
renderWriteTextures  :: Set.IntSet,
    RenderState -> Name
renderLastUsedWin    :: Name
  }

type Name = Int

type ContextDoAsync = IO () -> IO ()

type PerWindowState ctx = IMap.IntMap (WindowState, ContextWindow ctx) -- -1 is no window. 0 is the hidden window. 1.. are visible windows
type PerWindowRenderState = IMap.IntMap (WindowState, ContextDoAsync)
newtype WindowState = WindowState
    { WindowState -> ContextData
windowContextData :: ContextData
    }

-- | Run a 'Render' monad, that may have the effect of windows or textures being drawn to.
--
--   May throw a 'GPipeException' if a combination of draw images (FBO) used by this render call is unsupported by the graphics driver
render :: (ContextHandler ctx, MonadIO m, MonadException m) => Render os () -> ContextT ctx os m ()
render :: Render os () -> ContextT ctx os m ()
render (Render ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
m) = do
  ContextT ctx os m (ContextWindow ctx) -> ContextT ctx os m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ContextT ctx os m (ContextWindow ctx)
forall ctx (m :: * -> *) os.
(ContextHandler ctx, MonadIO m) =>
ContextT ctx os m (ContextWindow ctx)
getLastContextWin -- To create hidden window if needed
  ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
 -> ContextT ctx os m ())
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall a b. (a -> b) -> a -> b
$ do
    ContextEnv ctx
ctx SharedContextDatas
cds <- ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextEnv ctx)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    ContextState ctx
cs <- StateT (ContextState ctx) m (ContextState ctx)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextState ctx)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (ContextState ctx) m (ContextState ctx)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    let wmap' :: PerWindowRenderState
wmap' = ((WindowState, ContextWindow ctx) -> (WindowState, ContextDoAsync))
-> IntMap (WindowState, ContextWindow ctx) -> PerWindowRenderState
forall a b. (a -> b) -> IntMap a -> IntMap b
IMap.map (\(WindowState
ws,ContextWindow ctx
w) -> (WindowState
ws, ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
forall ctx.
ContextHandler ctx =>
ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
contextDoAsync ctx
ctx (ContextWindow ctx -> Maybe (ContextWindow ctx)
forall a. a -> Maybe a
Just ContextWindow ctx
w))) (IntMap (WindowState, ContextWindow ctx) -> PerWindowRenderState)
-> IntMap (WindowState, ContextWindow ctx) -> PerWindowRenderState
forall a b. (a -> b) -> a -> b
$ ContextState ctx -> IntMap (WindowState, ContextWindow ctx)
forall ctx. ContextState ctx -> PerWindowState ctx
perWindowState ContextState ctx
cs
    (Either String ()
eError, RenderState
rs) <- IO (Either String (), RenderState)
-> ReaderT
     (ContextEnv ctx)
     (StateT (ContextState ctx) m)
     (Either String (), RenderState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String (), RenderState)
 -> ReaderT
      (ContextEnv ctx)
      (StateT (ContextState ctx) m)
      (Either String (), RenderState))
-> IO (Either String (), RenderState)
-> ReaderT
     (ContextEnv ctx)
     (StateT (ContextState ctx) m)
     (Either String (), RenderState)
forall a b. (a -> b) -> a -> b
$ StateT RenderState IO (Either String ())
-> RenderState -> IO (Either String (), RenderState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT RenderEnv (StateT RenderState IO) (Either String ())
-> RenderEnv -> StateT RenderState IO (Either String ())
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
-> ReaderT RenderEnv (StateT RenderState IO) (Either String ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) ()
m) (SharedContextDatas -> ContextDoAsync -> RenderEnv
RenderEnv SharedContextDatas
cds (ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
forall ctx.
ContextHandler ctx =>
ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
contextDoAsync ctx
ctx Maybe (ContextWindow ctx)
forall a. Maybe a
Nothing))) (PerWindowRenderState -> IntSet -> Name -> RenderState
RenderState PerWindowRenderState
wmap' IntSet
Set.empty (ContextState ctx -> Name
forall ctx. ContextState ctx -> Name
lastUsedWin ContextState ctx
cs))
    StateT (ContextState ctx) m ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (ContextState ctx) m ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> StateT (ContextState ctx) m ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ ContextState ctx -> StateT (ContextState ctx) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ContextState ctx -> StateT (ContextState ctx) m ())
-> ContextState ctx -> StateT (ContextState ctx) m ()
forall a b. (a -> b) -> a -> b
$ ContextState ctx
cs { lastUsedWin :: Name
lastUsedWin = RenderState -> Name
renderLastUsedWin RenderState
rs}
    case Either String ()
eError of
      Left String
s -> IO () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> IO ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ GPipeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (GPipeException -> IO ()) -> GPipeException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> GPipeException
GPipeException String
s
      Either String ()
_      -> () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

registerRenderWriteTexture :: Int -> Render os ()
registerRenderWriteTexture :: Name -> Render os ()
registerRenderWriteTexture Name
n = 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
$ 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 -> RenderState) -> StateT RenderState IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((RenderState -> RenderState) -> StateT RenderState IO ())
-> (RenderState -> RenderState) -> StateT RenderState IO ()
forall a b. (a -> b) -> a -> b
$ \ RenderState
rs -> RenderState
rs { renderWriteTextures :: IntSet
renderWriteTextures = Name -> IntSet -> IntSet
Set.insert Name
n (IntSet -> IntSet) -> IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$ RenderState -> IntSet
renderWriteTextures RenderState
rs }

instance MonadTrans (ContextT ctx os) where
    lift :: m a -> ContextT ctx os m a
lift = ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
 -> ContextT ctx os m a)
-> (m a
    -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a)
-> m a
-> ContextT ctx os m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (ContextState ctx) m a
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (ContextState ctx) m a
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a)
-> (m a -> StateT (ContextState ctx) m a)
-> m a
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> StateT (ContextState ctx) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadIO m => MF.MonadFail (ContextT ctx os m) where
    fail :: String -> ContextT ctx os m a
fail = IO a -> ContextT ctx os m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ContextT ctx os m a)
-> (String -> IO a) -> String -> ContextT ctx os m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
MF.fail

-- | Run a 'ContextT' monad transformer that encapsulates an object space.
--   You need an implementation of a 'ContextHandler', which is provided by an auxillary package, such as @GPipe-GLFW@.
runContextT :: (MonadIO m, MonadAsyncException m, ContextHandler ctx) => ContextHandlerParameters ctx -> (forall os. ContextT ctx os m a) -> m a
runContextT :: ContextHandlerParameters ctx
-> (forall os. ContextT ctx os m a) -> m a
runContextT ContextHandlerParameters ctx
chp (ContextT m) = do
    SharedContextDatas
cds <- IO SharedContextDatas -> m SharedContextDatas
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SharedContextDatas
newContextDatas
    m ctx -> (ctx -> m ()) -> (ctx -> m a) -> m a
forall (m :: * -> *) a b c.
MonadAsyncException m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
     (IO ctx -> m ctx
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ctx -> m ctx) -> IO ctx -> m ctx
forall a b. (a -> b) -> a -> b
$ ContextHandlerParameters ctx -> IO ctx
forall ctx.
ContextHandler ctx =>
ContextHandlerParameters ctx -> IO ctx
contextHandlerCreate ContextHandlerParameters ctx
chp)
     (\ctx
ctx -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
       [(ContextData, IO ())]
cds' <- SharedContextDatas -> IO [(ContextData, IO ())]
forall a. MVar a -> IO a
readMVar SharedContextDatas
cds
       ((ContextData, IO ()) -> IO ()) -> [(ContextData, IO ())] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ContextData, IO ()) -> IO ()
forall a b. (a, b) -> b
snd [(ContextData, IO ())]
cds' -- Delete all windows not explicitly deleted
       ctx -> IO ()
forall ctx. ContextHandler ctx => ctx -> IO ()
contextHandlerDelete ctx
ctx
     )
     (\ctx
ctx -> StateT (ContextState ctx) m a -> ContextState ctx -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextEnv ctx -> StateT (ContextState ctx) m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
m (ctx -> SharedContextDatas -> ContextEnv ctx
forall ctx. ctx -> SharedContextDatas -> ContextEnv ctx
ContextEnv ctx
ctx SharedContextDatas
cds)) (Name -> PerWindowState ctx -> Name -> ContextState ctx
forall ctx. Name -> PerWindowState ctx -> Name -> ContextState ctx
ContextState Name
1 PerWindowState ctx
forall a. IntMap a
IMap.empty (-Name
1)))

newtype Window os c ds = Window { Window os c ds -> Name
getWinName :: Name }

instance Eq (Window os c ds) where
  (Window Name
a) == :: Window os c ds -> Window os c ds -> Bool
== (Window Name
b) = Name
a Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
b

createHiddenWin :: (ContextHandler ctx, MonadIO m) => ContextT ctx os m (ContextWindow ctx)
createHiddenWin :: ContextT ctx os m (ContextWindow ctx)
createHiddenWin = ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
-> ContextT ctx os m (ContextWindow ctx)
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT
   (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
 -> ContextT ctx os m (ContextWindow ctx))
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
-> ContextT ctx os m (ContextWindow ctx)
forall a b. (a -> b) -> a -> b
$ do
  ContextEnv ctx
ctx SharedContextDatas
cds <- ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextEnv ctx)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  ContextState Name
wid PerWindowState ctx
_ Name
_ <- StateT (ContextState ctx) m (ContextState ctx)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextState ctx)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (ContextState ctx) m (ContextState ctx)
forall (m :: * -> *) s. Monad m => StateT s m s
get -- We need to keep next window id and not start over at 1
  ContextWindow ctx
w <- IO (ContextWindow ctx)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ContextWindow ctx)
 -> ReaderT
      (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx))
-> IO (ContextWindow ctx)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
forall a b. (a -> b) -> a -> b
$ ctx
-> Maybe (WindowBits, WindowParameters ctx)
-> IO (ContextWindow ctx)
forall ctx.
ContextHandler ctx =>
ctx
-> Maybe (WindowBits, WindowParameters ctx)
-> IO (ContextWindow ctx)
createContext ctx
ctx Maybe (WindowBits, WindowParameters ctx)
forall a. Maybe a
Nothing
  ContextData
cd <- IO ContextData
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) ContextData
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ContextData
 -> ReaderT
      (ContextEnv ctx) (StateT (ContextState ctx) m) ContextData)
-> IO ContextData
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) ContextData
forall a b. (a -> b) -> a -> b
$ IO () -> SharedContextDatas -> IO ContextData
addContextData (ctx -> ContextWindow ctx -> IO ()
forall ctx. ContextHandler ctx => ctx -> ContextWindow ctx -> IO ()
contextDelete ctx
ctx ContextWindow ctx
w) SharedContextDatas
cds
  let ws :: WindowState
ws = ContextData -> WindowState
WindowState ContextData
cd
  StateT (ContextState ctx) m ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (ContextState ctx) m ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> StateT (ContextState ctx) m ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ ContextState ctx -> StateT (ContextState ctx) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ContextState ctx -> StateT (ContextState ctx) m ())
-> ContextState ctx -> StateT (ContextState ctx) m ()
forall a b. (a -> b) -> a -> b
$ Name -> PerWindowState ctx -> Name -> ContextState ctx
forall ctx. Name -> PerWindowState ctx -> Name -> ContextState ctx
ContextState Name
wid (Name -> (WindowState, ContextWindow ctx) -> PerWindowState ctx
forall a. Name -> a -> IntMap a
IMap.singleton Name
0 (WindowState
ws,ContextWindow ctx
w)) Name
0
  IO () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> IO ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
forall ctx.
ContextHandler ctx =>
ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
contextDoAsync ctx
ctx (ContextWindow ctx -> Maybe (ContextWindow ctx)
forall a. a -> Maybe a
Just ContextWindow ctx
w) IO ()
initGlState
  ContextWindow ctx
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return ContextWindow ctx
w

-- | Creates a window
newWindow :: (ContextHandler ctx, MonadIO m) => WindowFormat c ds -> WindowParameters ctx -> ContextT ctx os m (Window os c ds)
newWindow :: WindowFormat c ds
-> WindowParameters ctx -> ContextT ctx os m (Window os c ds)
newWindow WindowFormat c ds
wf WindowParameters ctx
wp = ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (Window os c ds)
-> ContextT ctx os m (Window os c ds)
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT
   (ContextEnv ctx) (StateT (ContextState ctx) m) (Window os c ds)
 -> ContextT ctx os m (Window os c ds))
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (Window os c ds)
-> ContextT ctx os m (Window os c ds)
forall a b. (a -> b) -> a -> b
$ do
  ContextEnv ctx
ctx SharedContextDatas
cds <-  ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextEnv ctx)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  ContextState Name
wid PerWindowState ctx
wmap Name
_ <- StateT (ContextState ctx) m (ContextState ctx)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextState ctx)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (ContextState ctx) m (ContextState ctx)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  ContextWindow ctx
w <- IO (ContextWindow ctx)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ContextWindow ctx)
 -> ReaderT
      (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx))
-> IO (ContextWindow ctx)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
forall a b. (a -> b) -> a -> b
$ ctx
-> Maybe (WindowBits, WindowParameters ctx)
-> IO (ContextWindow ctx)
forall ctx.
ContextHandler ctx =>
ctx
-> Maybe (WindowBits, WindowParameters ctx)
-> IO (ContextWindow ctx)
createContext ctx
ctx ((WindowBits, WindowParameters ctx)
-> Maybe (WindowBits, WindowParameters ctx)
forall a. a -> Maybe a
Just (WindowFormat c ds -> WindowBits
forall c ds. WindowFormat c ds -> WindowBits
windowBits WindowFormat c ds
wf, WindowParameters ctx
wp))
  ContextData
cd <- IO ContextData
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) ContextData
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ContextData
 -> ReaderT
      (ContextEnv ctx) (StateT (ContextState ctx) m) ContextData)
-> IO ContextData
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) ContextData
forall a b. (a -> b) -> a -> b
$ IO () -> SharedContextDatas -> IO ContextData
addContextData (ctx -> ContextWindow ctx -> IO ()
forall ctx. ContextHandler ctx => ctx -> ContextWindow ctx -> IO ()
contextDelete ctx
ctx ContextWindow ctx
w) SharedContextDatas
cds
  let wid' :: Name
wid' = Name
widName -> Name -> Name
forall a. Num a => a -> a -> a
+Name
1
  let ws :: WindowState
ws = ContextData -> WindowState
WindowState ContextData
cd
  StateT (ContextState ctx) m ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (ContextState ctx) m ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> StateT (ContextState ctx) m ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ ContextState ctx -> StateT (ContextState ctx) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ContextState ctx -> StateT (ContextState ctx) m ())
-> ContextState ctx -> StateT (ContextState ctx) m ()
forall a b. (a -> b) -> a -> b
$ Name -> PerWindowState ctx -> Name -> ContextState ctx
forall ctx. Name -> PerWindowState ctx -> Name -> ContextState ctx
ContextState Name
wid' (Name
-> (WindowState, ContextWindow ctx)
-> PerWindowState ctx
-> PerWindowState ctx
forall a. Name -> a -> IntMap a -> IntMap a
IMap.insert Name
wid (WindowState
ws,ContextWindow ctx
w) PerWindowState ctx
wmap) Name
wid
  IO () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> IO ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
forall ctx.
ContextHandler ctx =>
ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
contextDoAsync ctx
ctx (ContextWindow ctx -> Maybe (ContextWindow ctx)
forall a. a -> Maybe a
Just ContextWindow ctx
w) IO ()
initGlState
  Window os c ds
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (Window os c ds)
forall (m :: * -> *) a. Monad m => a -> m a
return (Window os c ds
 -> ReaderT
      (ContextEnv ctx) (StateT (ContextState ctx) m) (Window os c ds))
-> Window os c ds
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (Window os c ds)
forall a b. (a -> b) -> a -> b
$ Name -> Window os c ds
forall os c ds. Name -> Window os c ds
Window Name
wid

-- | Deletes a window. Any rendering to this window will become a noop.
deleteWindow :: (ContextHandler ctx, MonadIO m) => Window os c ds -> ContextT ctx os m ()
deleteWindow :: Window os c ds -> ContextT ctx os m ()
deleteWindow (Window Name
wid) = ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
 -> ContextT ctx os m ())
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall a b. (a -> b) -> a -> b
$ do
  ContextState Name
nid PerWindowState ctx
wmap Name
n <- StateT (ContextState ctx) m (ContextState ctx)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextState ctx)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (ContextState ctx) m (ContextState ctx)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case Name
-> PerWindowState ctx -> Maybe (WindowState, ContextWindow ctx)
forall a. Name -> IntMap a -> Maybe a
IMap.lookup Name
wid PerWindowState ctx
wmap of
    Maybe (WindowState, ContextWindow ctx)
Nothing -> () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (WindowState
ws, ContextWindow ctx
w) -> do
      ContextEnv ctx
ctx SharedContextDatas
cds <-  ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextEnv ctx)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      let wmap' :: PerWindowState ctx
wmap' = Name -> PerWindowState ctx -> PerWindowState ctx
forall a. Name -> IntMap a -> IntMap a
IMap.delete Name
wid PerWindowState ctx
wmap
      Name
n' <- if PerWindowState ctx -> Bool
forall a. IntMap a -> Bool
IMap.null PerWindowState ctx
wmap'
              then do
                ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT
   (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ let ContextT ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
m = ContextT ctx Any m (ContextWindow ctx)
forall ctx (m :: * -> *) os.
(ContextHandler ctx, MonadIO m) =>
ContextT ctx os m (ContextWindow ctx)
createHiddenWin in ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
m -- Create a hidden window before we delete last window
                Name -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
0 -- The hidden window is now Current
              else if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
wid then Name -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
                               else Name -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) Name
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, (WindowState, ContextWindow ctx)) -> Name
forall a b. (a, b) -> a
fst ([(Name, (WindowState, ContextWindow ctx))]
-> (Name, (WindowState, ContextWindow ctx))
forall a. [a] -> a
head (PerWindowState ctx -> [(Name, (WindowState, ContextWindow ctx))]
forall a. IntMap a -> [(Name, a)]
IMap.toList PerWindowState ctx
wmap'))) -- always at least one elem
      IO () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> IO ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ do SharedContextDatas -> ContextData -> IO ()
removeContextData SharedContextDatas
cds (WindowState -> ContextData
windowContextData WindowState
ws)
                  ctx -> ContextWindow ctx -> IO ()
forall ctx. ContextHandler ctx => ctx -> ContextWindow ctx -> IO ()
contextDelete ctx
ctx ContextWindow ctx
w
      StateT (ContextState ctx) m ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (ContextState ctx) m ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> StateT (ContextState ctx) m ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ ContextState ctx -> StateT (ContextState ctx) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ContextState ctx -> StateT (ContextState ctx) m ())
-> ContextState ctx -> StateT (ContextState ctx) m ()
forall a b. (a -> b) -> a -> b
$ Name -> PerWindowState ctx -> Name -> ContextState ctx
forall ctx. Name -> PerWindowState ctx -> Name -> ContextState ctx
ContextState Name
nid PerWindowState ctx
wmap' Name
n'

initGlState :: IO ()
initGlState :: IO ()
initGlState = do
  GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glEnable GLenum
forall a. (Eq a, Num a) => a
GL_FRAMEBUFFER_SRGB
  GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glEnable GLenum
forall a. (Eq a, Num a) => a
GL_SCISSOR_TEST
  GLenum -> GLint -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> GLint -> m ()
glPixelStorei GLenum
forall a. (Eq a, Num a) => a
GL_PACK_ALIGNMENT GLint
1
  GLenum -> GLint -> IO ()
forall (m :: * -> *). MonadIO m => GLenum -> GLint -> m ()
glPixelStorei GLenum
forall a. (Eq a, Num a) => a
GL_UNPACK_ALIGNMENT GLint
1

asSync :: (IO () -> IO ()) -> IO x -> IO x
asSync :: ContextDoAsync -> IO x -> IO x
asSync ContextDoAsync
f IO x
m = do MVar x
mutVar <- IO (MVar x)
forall a. IO (MVar a)
newEmptyMVar
                ContextDoAsync
f (IO x
m IO x -> (x -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar x -> x -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar x
mutVar)
                MVar x -> IO x
forall a. MVar a -> IO a
takeMVar MVar x
mutVar

getLastContextWin :: (ContextHandler ctx, MonadIO m) => ContextT ctx os m (ContextWindow ctx)
getLastContextWin :: ContextT ctx os m (ContextWindow ctx)
getLastContextWin = ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
-> ContextT ctx os m (ContextWindow ctx)
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT
   (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
 -> ContextT ctx os m (ContextWindow ctx))
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
-> ContextT ctx os m (ContextWindow ctx)
forall a b. (a -> b) -> a -> b
$ do
  ContextState ctx
cs <- StateT (ContextState ctx) m (ContextState ctx)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextState ctx)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT (ContextState ctx) m (ContextState ctx)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  let wid :: Name
wid = ContextState ctx -> Name
forall ctx. ContextState ctx -> Name
lastUsedWin ContextState ctx
cs
  if Name
wid Name -> Name -> Bool
forall a. Ord a => a -> a -> Bool
>= Name
0
    then ContextWindow ctx
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return ((WindowState, ContextWindow ctx) -> ContextWindow ctx
forall a b. (a, b) -> b
snd ((WindowState, ContextWindow ctx) -> ContextWindow ctx)
-> (WindowState, ContextWindow ctx) -> ContextWindow ctx
forall a b. (a -> b) -> a -> b
$ ContextState ctx -> PerWindowState ctx
forall ctx. ContextState ctx -> PerWindowState ctx
perWindowState ContextState ctx
cs PerWindowState ctx -> Name -> (WindowState, ContextWindow ctx)
forall a. IntMap a -> Name -> a
! Name
wid) -- always exists, since delete context will change lastUsedWin for us
    else let ContextT ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
m = ContextT ctx Any m (ContextWindow ctx)
forall ctx (m :: * -> *) os.
(ContextHandler ctx, MonadIO m) =>
ContextT ctx os m (ContextWindow ctx)
createHiddenWin in ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextWindow ctx)
m

liftNonWinContextIO :: (ContextHandler ctx, MonadIO m) => IO a -> ContextT ctx os m a
liftNonWinContextIO :: IO a -> ContextT ctx os m a
liftNonWinContextIO IO a
m = do
  ContextEnv ctx
ctx SharedContextDatas
_ <- ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextEnv ctx)
-> ContextT ctx os m (ContextEnv ctx)
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextEnv ctx)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  ContextWindow ctx
w <- ContextT ctx os m (ContextWindow ctx)
forall ctx (m :: * -> *) os.
(ContextHandler ctx, MonadIO m) =>
ContextT ctx os m (ContextWindow ctx)
getLastContextWin
  ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
 -> ContextT ctx os m a)
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
forall a b. (a -> b) -> a -> b
$ IO a -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a)
-> IO a -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
forall a b. (a -> b) -> a -> b
$ ContextDoAsync -> IO a -> IO a
forall x. ContextDoAsync -> IO x -> IO x
asSync (ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
forall ctx.
ContextHandler ctx =>
ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
contextDoAsync ctx
ctx (ContextWindow ctx -> Maybe (ContextWindow ctx)
forall a. a -> Maybe a
Just ContextWindow ctx
w)) IO a
m

liftNonWinContextAsyncIO :: (ContextHandler ctx, MonadIO m) => IO () -> ContextT ctx os m ()
liftNonWinContextAsyncIO :: IO () -> ContextT ctx os m ()
liftNonWinContextAsyncIO IO ()
m = do
  ContextEnv ctx
ctx SharedContextDatas
_ <- ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextEnv ctx)
-> ContextT ctx os m (ContextEnv ctx)
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextEnv ctx)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  ContextWindow ctx
w <- ContextT ctx os m (ContextWindow ctx)
forall ctx (m :: * -> *) os.
(ContextHandler ctx, MonadIO m) =>
ContextT ctx os m (ContextWindow ctx)
getLastContextWin
  ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
 -> ContextT ctx os m ())
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> IO ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
forall ctx.
ContextHandler ctx =>
ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
contextDoAsync ctx
ctx (ContextWindow ctx -> Maybe (ContextWindow ctx)
forall a. a -> Maybe a
Just ContextWindow ctx
w) IO ()
m


addContextFinalizer :: (ContextHandler ctx, MonadIO m) => IORef a -> IO () -> ContextT ctx os m ()
addContextFinalizer :: IORef a -> IO () -> ContextT ctx os m ()
addContextFinalizer IORef a
k IO ()
m = ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
 -> ContextT ctx os m ())
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall a b. (a -> b) -> a -> b
$ do
  ContextEnv ctx
ctx SharedContextDatas
_ <- ReaderT
  (ContextEnv ctx) (StateT (ContextState ctx) m) (ContextEnv ctx)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> IO ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ IO (Weak (IORef a)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak (IORef a)) -> IO ()) -> IO (Weak (IORef a)) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef a -> IO () -> IO (Weak (IORef a))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef a
k (IO () -> IO (Weak (IORef a))) -> IO () -> IO (Weak (IORef a))
forall a b. (a -> b) -> a -> b
$ ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
forall ctx.
ContextHandler ctx =>
ctx -> Maybe (ContextWindow ctx) -> ContextDoAsync
contextDoAsync ctx
ctx Maybe (ContextWindow ctx)
forall a. Maybe a
Nothing IO ()
m


getLastRenderWin :: Render os (Name, ContextData, ContextDoAsync)
getLastRenderWin = ExceptT
  String
  (ReaderT RenderEnv (StateT RenderState IO))
  (Name, ContextData, ContextDoAsync)
-> Render os (Name, ContextData, ContextDoAsync)
forall os a.
ExceptT String (ReaderT RenderEnv (StateT RenderState IO)) a
-> Render os a
Render (ExceptT
   String
   (ReaderT RenderEnv (StateT RenderState IO))
   (Name, ContextData, ContextDoAsync)
 -> Render os (Name, ContextData, ContextDoAsync))
-> ExceptT
     String
     (ReaderT RenderEnv (StateT RenderState IO))
     (Name, ContextData, ContextDoAsync)
-> Render os (Name, ContextData, ContextDoAsync)
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
  let cwid :: Name
cwid = RenderState -> Name
renderLastUsedWin RenderState
rs -- There is always a window available since render calls getLastContextWin
  let (WindowState
ws, ContextDoAsync
doAsync) = RenderState -> PerWindowRenderState
perWindowRenderState RenderState
rs PerWindowRenderState -> Name -> (WindowState, ContextDoAsync)
forall a. IntMap a -> Name -> a
! Name
cwid
      cd :: ContextData
cd = WindowState -> ContextData
windowContextData WindowState
ws
  (Name, ContextData, ContextDoAsync)
-> ExceptT
     String
     (ReaderT RenderEnv (StateT RenderState IO))
     (Name, ContextData, ContextDoAsync)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
cwid, ContextData
cd, ContextDoAsync
doAsync)

-- | Run this action after a 'render' call to swap out the context windows back buffer with the front buffer, effectively showing the result.
--   This call may block if vsync is enabled in the system and/or too many frames are outstanding.
--   After this call, the context window content is undefined and should be cleared at earliest convenience using 'clearContextColor' and friends.
swapWindowBuffers :: (ContextHandler ctx, MonadIO m) => Window os c ds -> ContextT ctx os m ()
swapWindowBuffers :: Window os c ds -> ContextT ctx os m ()
swapWindowBuffers (Window Name
wid) = ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
 -> ContextT ctx os m ())
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall a b. (a -> b) -> a -> b
$ do
  IntMap (WindowState, ContextWindow ctx)
wmap <- StateT
  (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
-> ReaderT
     (ContextEnv ctx)
     (StateT (ContextState ctx) m)
     (IntMap (WindowState, ContextWindow ctx))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT
   (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
 -> ReaderT
      (ContextEnv ctx)
      (StateT (ContextState ctx) m)
      (IntMap (WindowState, ContextWindow ctx)))
-> StateT
     (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
-> ReaderT
     (ContextEnv ctx)
     (StateT (ContextState ctx) m)
     (IntMap (WindowState, ContextWindow ctx))
forall a b. (a -> b) -> a -> b
$ (ContextState ctx -> IntMap (WindowState, ContextWindow ctx))
-> StateT
     (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ContextState ctx -> IntMap (WindowState, ContextWindow ctx)
forall ctx. ContextState ctx -> PerWindowState ctx
perWindowState
  case Name
-> IntMap (WindowState, ContextWindow ctx)
-> Maybe (WindowState, ContextWindow ctx)
forall a. Name -> IntMap a -> Maybe a
IMap.lookup Name
wid IntMap (WindowState, ContextWindow ctx)
wmap of
    Maybe (WindowState, ContextWindow ctx)
Nothing -> () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (WindowState
_, ContextWindow ctx
w) -> do
      ctx
ctx <- (ContextEnv ctx -> ctx)
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ctx
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ContextEnv ctx -> ctx
forall ctx. ContextEnv ctx -> ctx
context
      IO () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> IO ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ ctx -> ContextWindow ctx -> IO ()
forall ctx. ContextHandler ctx => ctx -> ContextWindow ctx -> IO ()
contextSwap ctx
ctx ContextWindow ctx
w


-- | Return the current size of the context frame buffer. This is needed to set viewport size and to get the aspect ratio to calculate projection matrices.
getFrameBufferSize :: (ContextHandler ctx, MonadIO m) => Window os c ds -> ContextT ctx os m (V2 Int)
getFrameBufferSize :: Window os c ds -> ContextT ctx os m (V2 Name)
getFrameBufferSize (Window Name
wid) = ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) (V2 Name)
-> ContextT ctx os m (V2 Name)
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) (V2 Name)
 -> ContextT ctx os m (V2 Name))
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) (V2 Name)
-> ContextT ctx os m (V2 Name)
forall a b. (a -> b) -> a -> b
$ do
  IntMap (WindowState, ContextWindow ctx)
wmap <- StateT
  (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
-> ReaderT
     (ContextEnv ctx)
     (StateT (ContextState ctx) m)
     (IntMap (WindowState, ContextWindow ctx))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT
   (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
 -> ReaderT
      (ContextEnv ctx)
      (StateT (ContextState ctx) m)
      (IntMap (WindowState, ContextWindow ctx)))
-> StateT
     (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
-> ReaderT
     (ContextEnv ctx)
     (StateT (ContextState ctx) m)
     (IntMap (WindowState, ContextWindow ctx))
forall a b. (a -> b) -> a -> b
$ (ContextState ctx -> IntMap (WindowState, ContextWindow ctx))
-> StateT
     (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ContextState ctx -> IntMap (WindowState, ContextWindow ctx)
forall ctx. ContextState ctx -> PerWindowState ctx
perWindowState
  case Name
-> IntMap (WindowState, ContextWindow ctx)
-> Maybe (WindowState, ContextWindow ctx)
forall a. Name -> IntMap a -> Maybe a
IMap.lookup Name
wid IntMap (WindowState, ContextWindow ctx)
wmap of
    Maybe (WindowState, ContextWindow ctx)
Nothing -> V2 Name
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) (V2 Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (V2 Name
 -> ReaderT
      (ContextEnv ctx) (StateT (ContextState ctx) m) (V2 Name))
-> V2 Name
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) (V2 Name)
forall a b. (a -> b) -> a -> b
$ Name -> Name -> V2 Name
forall a. a -> a -> V2 a
V2 Name
0 Name
0
    Just (WindowState
_, ContextWindow ctx
w) -> do
      ctx
ctx <- (ContextEnv ctx -> ctx)
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ctx
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ContextEnv ctx -> ctx
forall ctx. ContextEnv ctx -> ctx
context
      (Name
x,Name
y) <- IO (Name, Name)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (Name, Name)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Name, Name)
 -> ReaderT
      (ContextEnv ctx) (StateT (ContextState ctx) m) (Name, Name))
-> IO (Name, Name)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) (Name, Name)
forall a b. (a -> b) -> a -> b
$ ctx -> ContextWindow ctx -> IO (Name, Name)
forall ctx.
ContextHandler ctx =>
ctx -> ContextWindow ctx -> IO (Name, Name)
contextFrameBufferSize ctx
ctx ContextWindow ctx
w
      V2 Name
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) (V2 Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (V2 Name
 -> ReaderT
      (ContextEnv ctx) (StateT (ContextState ctx) m) (V2 Name))
-> V2 Name
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) (V2 Name)
forall a b. (a -> b) -> a -> b
$ Name -> Name -> V2 Name
forall a. a -> a -> V2 a
V2 Name
x Name
y

-- | Use the context window handle, which type is specific to the window system used. This handle shouldn't be returned from this function
withContextWindow :: MonadIO m => Window os c ds -> (Maybe (ContextWindow ctx) -> IO a) -> ContextT ctx os m a
withContextWindow :: Window os c ds
-> (Maybe (ContextWindow ctx) -> IO a) -> ContextT ctx os m a
withContextWindow (Window Name
wid) Maybe (ContextWindow ctx) -> IO a
m = ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
 -> ContextT ctx os m a)
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
forall a b. (a -> b) -> a -> b
$ do
  IntMap (WindowState, ContextWindow ctx)
wmap <- StateT
  (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
-> ReaderT
     (ContextEnv ctx)
     (StateT (ContextState ctx) m)
     (IntMap (WindowState, ContextWindow ctx))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT
   (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
 -> ReaderT
      (ContextEnv ctx)
      (StateT (ContextState ctx) m)
      (IntMap (WindowState, ContextWindow ctx)))
-> StateT
     (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
-> ReaderT
     (ContextEnv ctx)
     (StateT (ContextState ctx) m)
     (IntMap (WindowState, ContextWindow ctx))
forall a b. (a -> b) -> a -> b
$ (ContextState ctx -> IntMap (WindowState, ContextWindow ctx))
-> StateT
     (ContextState ctx) m (IntMap (WindowState, ContextWindow ctx))
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ContextState ctx -> IntMap (WindowState, ContextWindow ctx)
forall ctx. ContextState ctx -> PerWindowState ctx
perWindowState
  IO a -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a)
-> IO a -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
forall a b. (a -> b) -> a -> b
$ Maybe (ContextWindow ctx) -> IO a
m ((WindowState, ContextWindow ctx) -> ContextWindow ctx
forall a b. (a, b) -> b
snd ((WindowState, ContextWindow ctx) -> ContextWindow ctx)
-> Maybe (WindowState, ContextWindow ctx)
-> Maybe (ContextWindow ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name
-> IntMap (WindowState, ContextWindow ctx)
-> Maybe (WindowState, ContextWindow ctx)
forall a. Name -> IntMap a -> Maybe a
IMap.lookup Name
wid IntMap (WindowState, ContextWindow ctx)
wmap)

-- | This kind of exception may be thrown from GPipe when a GPU hardware limit is reached (for instance, too many textures are drawn to from the same 'FragmentStream')
newtype GPipeException = GPipeException String
    deriving (Name -> GPipeException -> ShowS
[GPipeException] -> ShowS
GPipeException -> String
(Name -> GPipeException -> ShowS)
-> (GPipeException -> String)
-> ([GPipeException] -> ShowS)
-> Show GPipeException
forall a.
(Name -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GPipeException] -> ShowS
$cshowList :: [GPipeException] -> ShowS
show :: GPipeException -> String
$cshow :: GPipeException -> String
showsPrec :: Name -> GPipeException -> ShowS
$cshowsPrec :: Name -> GPipeException -> ShowS
Show, Typeable)

instance Exception GPipeException

{-
-- TODO Add async rules
{-# RULES
"liftContextIO >>= liftContextIO >>= x"    forall m1 m2 x.  liftContextIO m1 >>= (\_ -> liftContextIO m2 >>= x) = liftContextIO (m1 >> m2) >>= x
"liftContextIO >>= liftContextIO"          forall m1 m2.    liftContextIO m1 >>= (\_ -> liftContextIO m2) = liftContextIO (m1 >> m2)
  #-}
-}
--------------------------

-- | The reason we need this is that we need to bind a finalizer to a buffer or texture that removes all references VAOs or FBOs from all
--   known ContextData at a future point, where more Contexts may have been created.
type SharedContextDatas = MVar [(ContextData, IO ())] -- IO to delete windows
type ContextData = MVar (VAOCache, FBOCache)
data VAOKey = VAOKey { VAOKey -> GLenum
vaoBname :: !GLuint, VAOKey -> Name
vaoCombBufferOffset :: !Int, VAOKey -> GLint
vaoComponents :: !GLint, VAOKey -> Bool
vaoNorm :: !Bool, VAOKey -> Name
vaoDiv :: !Int } deriving (VAOKey -> VAOKey -> Bool
(VAOKey -> VAOKey -> Bool)
-> (VAOKey -> VAOKey -> Bool) -> Eq VAOKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VAOKey -> VAOKey -> Bool
$c/= :: VAOKey -> VAOKey -> Bool
== :: VAOKey -> VAOKey -> Bool
$c== :: VAOKey -> VAOKey -> Bool
Eq, Eq VAOKey
Eq VAOKey
-> (VAOKey -> VAOKey -> Ordering)
-> (VAOKey -> VAOKey -> Bool)
-> (VAOKey -> VAOKey -> Bool)
-> (VAOKey -> VAOKey -> Bool)
-> (VAOKey -> VAOKey -> Bool)
-> (VAOKey -> VAOKey -> VAOKey)
-> (VAOKey -> VAOKey -> VAOKey)
-> Ord VAOKey
VAOKey -> VAOKey -> Bool
VAOKey -> VAOKey -> Ordering
VAOKey -> VAOKey -> VAOKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: VAOKey -> VAOKey -> VAOKey
$cmin :: VAOKey -> VAOKey -> VAOKey
max :: VAOKey -> VAOKey -> VAOKey
$cmax :: VAOKey -> VAOKey -> VAOKey
>= :: VAOKey -> VAOKey -> Bool
$c>= :: VAOKey -> VAOKey -> Bool
> :: VAOKey -> VAOKey -> Bool
$c> :: VAOKey -> VAOKey -> Bool
<= :: VAOKey -> VAOKey -> Bool
$c<= :: VAOKey -> VAOKey -> Bool
< :: VAOKey -> VAOKey -> Bool
$c< :: VAOKey -> VAOKey -> Bool
compare :: VAOKey -> VAOKey -> Ordering
$ccompare :: VAOKey -> VAOKey -> Ordering
$cp1Ord :: Eq VAOKey
Ord)
data FBOKey = FBOKey { FBOKey -> GLenum
fboTname :: !GLuint, FBOKey -> Name
fboTlayerOrNegIfRendBuff :: !Int, FBOKey -> Name
fboTlevel :: !Int } deriving (FBOKey -> FBOKey -> Bool
(FBOKey -> FBOKey -> Bool)
-> (FBOKey -> FBOKey -> Bool) -> Eq FBOKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FBOKey -> FBOKey -> Bool
$c/= :: FBOKey -> FBOKey -> Bool
== :: FBOKey -> FBOKey -> Bool
$c== :: FBOKey -> FBOKey -> Bool
Eq, Eq FBOKey
Eq FBOKey
-> (FBOKey -> FBOKey -> Ordering)
-> (FBOKey -> FBOKey -> Bool)
-> (FBOKey -> FBOKey -> Bool)
-> (FBOKey -> FBOKey -> Bool)
-> (FBOKey -> FBOKey -> Bool)
-> (FBOKey -> FBOKey -> FBOKey)
-> (FBOKey -> FBOKey -> FBOKey)
-> Ord FBOKey
FBOKey -> FBOKey -> Bool
FBOKey -> FBOKey -> Ordering
FBOKey -> FBOKey -> FBOKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FBOKey -> FBOKey -> FBOKey
$cmin :: FBOKey -> FBOKey -> FBOKey
max :: FBOKey -> FBOKey -> FBOKey
$cmax :: FBOKey -> FBOKey -> FBOKey
>= :: FBOKey -> FBOKey -> Bool
$c>= :: FBOKey -> FBOKey -> Bool
> :: FBOKey -> FBOKey -> Bool
$c> :: FBOKey -> FBOKey -> Bool
<= :: FBOKey -> FBOKey -> Bool
$c<= :: FBOKey -> FBOKey -> Bool
< :: FBOKey -> FBOKey -> Bool
$c< :: FBOKey -> FBOKey -> Bool
compare :: FBOKey -> FBOKey -> Ordering
$ccompare :: FBOKey -> FBOKey -> Ordering
$cp1Ord :: Eq FBOKey
Ord)
data FBOKeys = FBOKeys { FBOKeys -> [FBOKey]
fboColors :: [FBOKey], FBOKeys -> Maybe FBOKey
fboDepth :: Maybe FBOKey, FBOKeys -> Maybe FBOKey
fboStencil :: Maybe FBOKey } deriving (FBOKeys -> FBOKeys -> Bool
(FBOKeys -> FBOKeys -> Bool)
-> (FBOKeys -> FBOKeys -> Bool) -> Eq FBOKeys
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FBOKeys -> FBOKeys -> Bool
$c/= :: FBOKeys -> FBOKeys -> Bool
== :: FBOKeys -> FBOKeys -> Bool
$c== :: FBOKeys -> FBOKeys -> Bool
Eq, Eq FBOKeys
Eq FBOKeys
-> (FBOKeys -> FBOKeys -> Ordering)
-> (FBOKeys -> FBOKeys -> Bool)
-> (FBOKeys -> FBOKeys -> Bool)
-> (FBOKeys -> FBOKeys -> Bool)
-> (FBOKeys -> FBOKeys -> Bool)
-> (FBOKeys -> FBOKeys -> FBOKeys)
-> (FBOKeys -> FBOKeys -> FBOKeys)
-> Ord FBOKeys
FBOKeys -> FBOKeys -> Bool
FBOKeys -> FBOKeys -> Ordering
FBOKeys -> FBOKeys -> FBOKeys
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FBOKeys -> FBOKeys -> FBOKeys
$cmin :: FBOKeys -> FBOKeys -> FBOKeys
max :: FBOKeys -> FBOKeys -> FBOKeys
$cmax :: FBOKeys -> FBOKeys -> FBOKeys
>= :: FBOKeys -> FBOKeys -> Bool
$c>= :: FBOKeys -> FBOKeys -> Bool
> :: FBOKeys -> FBOKeys -> Bool
$c> :: FBOKeys -> FBOKeys -> Bool
<= :: FBOKeys -> FBOKeys -> Bool
$c<= :: FBOKeys -> FBOKeys -> Bool
< :: FBOKeys -> FBOKeys -> Bool
$c< :: FBOKeys -> FBOKeys -> Bool
compare :: FBOKeys -> FBOKeys -> Ordering
$ccompare :: FBOKeys -> FBOKeys -> Ordering
$cp1Ord :: Eq FBOKeys
Ord)
type VAOCache = Map.Map [VAOKey] (IORef GLuint)
type FBOCache = Map.Map FBOKeys (IORef GLuint)

getFBOKeys :: FBOKeys -> [FBOKey]
getFBOKeys :: FBOKeys -> [FBOKey]
getFBOKeys (FBOKeys [FBOKey]
xs Maybe FBOKey
d Maybe FBOKey
s) = [FBOKey]
xs [FBOKey] -> [FBOKey] -> [FBOKey]
forall a. [a] -> [a] -> [a]
++ Maybe FBOKey -> [FBOKey]
forall a. Maybe a -> [a]
maybeToList Maybe FBOKey
d [FBOKey] -> [FBOKey] -> [FBOKey]
forall a. [a] -> [a] -> [a]
++ Maybe FBOKey -> [FBOKey]
forall a. Maybe a -> [a]
maybeToList Maybe FBOKey
s

newContextDatas :: IO SharedContextDatas
newContextDatas :: IO SharedContextDatas
newContextDatas = [(ContextData, IO ())] -> IO SharedContextDatas
forall a. a -> IO (MVar a)
newMVar []

addContextData :: IO () -> SharedContextDatas -> IO ContextData
addContextData :: IO () -> SharedContextDatas -> IO ContextData
addContextData IO ()
io SharedContextDatas
r = do ContextData
cd <- (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> IO ContextData
forall a. a -> IO (MVar a)
newMVar (Map [VAOKey] (IORef GLenum)
forall k a. Map k a
Map.empty, Map FBOKeys (IORef GLenum)
forall k a. Map k a
Map.empty)
                         SharedContextDatas
-> ([(ContextData, IO ())] -> IO [(ContextData, IO ())]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ SharedContextDatas
r (([(ContextData, IO ())] -> IO [(ContextData, IO ())]) -> IO ())
-> ([(ContextData, IO ())] -> IO [(ContextData, IO ())]) -> IO ()
forall a b. (a -> b) -> a -> b
$ [(ContextData, IO ())] -> IO [(ContextData, IO ())]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ContextData, IO ())] -> IO [(ContextData, IO ())])
-> ([(ContextData, IO ())] -> [(ContextData, IO ())])
-> [(ContextData, IO ())]
-> IO [(ContextData, IO ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ContextData
cd,IO ()
io)(ContextData, IO ())
-> [(ContextData, IO ())] -> [(ContextData, IO ())]
forall a. a -> [a] -> [a]
:)
                         ContextData -> IO ContextData
forall (m :: * -> *) a. Monad m => a -> m a
return ContextData
cd

removeContextData :: SharedContextDatas -> ContextData -> IO ()
removeContextData :: SharedContextDatas -> ContextData -> IO ()
removeContextData SharedContextDatas
r ContextData
cd = SharedContextDatas
-> ([(ContextData, IO ())] -> IO [(ContextData, IO ())]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ SharedContextDatas
r (([(ContextData, IO ())] -> IO [(ContextData, IO ())]) -> IO ())
-> ([(ContextData, IO ())] -> IO [(ContextData, IO ())]) -> IO ()
forall a b. (a -> b) -> a -> b
$ [(ContextData, IO ())] -> IO [(ContextData, IO ())]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ContextData, IO ())] -> IO [(ContextData, IO ())])
-> ([(ContextData, IO ())] -> [(ContextData, IO ())])
-> [(ContextData, IO ())]
-> IO [(ContextData, IO ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextData -> [(ContextData, IO ())] -> [(ContextData, IO ())]
forall t b. Eq t => t -> [(t, b)] -> [(t, b)]
remove ContextData
cd
  where remove :: t -> [(t, b)] -> [(t, b)]
remove t
x ((t
k,b
v):[(t, b)]
xs) | t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
k = [(t, b)]
xs
        remove t
x ((t, b)
kv:[(t, b)]
xs)             = (t, b)
kv (t, b) -> [(t, b)] -> [(t, b)]
forall a. a -> [a] -> [a]
: t -> [(t, b)] -> [(t, b)]
remove t
x [(t, b)]
xs
        remove t
_ []                  = []

addCacheFinalizer :: MonadIO m => (GLuint -> (VAOCache, FBOCache) -> (VAOCache, FBOCache)) -> IORef GLuint -> ContextT ctx os m ()
addCacheFinalizer :: (GLenum
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IORef GLenum -> ContextT ctx os m ()
addCacheFinalizer GLenum
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
f IORef GLenum
r =  ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall ctx os (m :: * -> *) a.
ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) a
-> ContextT ctx os m a
ContextT (ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
 -> ContextT ctx os m ())
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
-> ContextT ctx os m ()
forall a b. (a -> b) -> a -> b
$ do SharedContextDatas
cds <- (ContextEnv ctx -> SharedContextDatas)
-> ReaderT
     (ContextEnv ctx) (StateT (ContextState ctx) m) SharedContextDatas
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ContextEnv ctx -> SharedContextDatas
forall ctx. ContextEnv ctx -> SharedContextDatas
sharedContextData
                                       IO () -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
 -> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ())
-> IO ()
-> ReaderT (ContextEnv ctx) (StateT (ContextState ctx) m) ()
forall a b. (a -> b) -> a -> b
$ do GLenum
n <- IORef GLenum -> IO GLenum
forall a. IORef a -> IO a
readIORef IORef GLenum
r
                                                   IO (Weak (IORef GLenum)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak (IORef GLenum)) -> IO ())
-> IO (Weak (IORef GLenum)) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef GLenum -> IO () -> IO (Weak (IORef GLenum))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef GLenum
r (IO () -> IO (Weak (IORef GLenum)))
-> IO () -> IO (Weak (IORef GLenum))
forall a b. (a -> b) -> a -> b
$ do [(ContextData, IO ())]
cs' <- SharedContextDatas -> IO [(ContextData, IO ())]
forall a. MVar a -> IO a
readMVar SharedContextDatas
cds
                                                                             ((ContextData, IO ()) -> IO ()) -> [(ContextData, IO ())] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(ContextData
cd,IO ()
_) -> ContextData
-> ((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
    -> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ContextData
cd ((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
 -> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> ((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
    -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLenum
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
f GLenum
n)) [(ContextData, IO ())]
cs'

-- | Removes a VAO entry from all SharedContextDatas when one of the buffers are deleted. This will in turn make the VAO finalizer to be run.
addVAOBufferFinalizer :: MonadIO m => IORef GLuint -> ContextT ctx os m ()
addVAOBufferFinalizer :: IORef GLenum -> ContextT ctx os m ()
addVAOBufferFinalizer = (GLenum
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IORef GLenum -> ContextT ctx os m ()
forall (m :: * -> *) ctx os.
MonadIO m =>
(GLenum
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IORef GLenum -> ContextT ctx os m ()
addCacheFinalizer GLenum
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
forall (t :: * -> *) a b.
Foldable t =>
GLenum -> (Map (t VAOKey) a, b) -> (Map (t VAOKey) a, b)
deleteVAOBuf
    where deleteVAOBuf :: GLenum -> (Map (t VAOKey) a, b) -> (Map (t VAOKey) a, b)
deleteVAOBuf GLenum
n (Map (t VAOKey) a
vao, b
fbo) = ((t VAOKey -> a -> Bool) -> Map (t VAOKey) a -> Map (t VAOKey) a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\t VAOKey
k a
_ -> (VAOKey -> Bool) -> t VAOKey -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
/=GLenum
n) (GLenum -> Bool) -> (VAOKey -> GLenum) -> VAOKey -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VAOKey -> GLenum
vaoBname) t VAOKey
k) Map (t VAOKey) a
vao, b
fbo)


-- | Removes a FBO entry from all SharedContextDatas when one of the textures are deleted. This will in turn make the FBO finalizer to be run.
addFBOTextureFinalizer :: MonadIO m => Bool -> IORef GLuint -> ContextT ctx os m ()
addFBOTextureFinalizer :: Bool -> IORef GLenum -> ContextT ctx os m ()
addFBOTextureFinalizer Bool
isRB = (GLenum
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IORef GLenum -> ContextT ctx os m ()
forall (m :: * -> *) ctx os.
MonadIO m =>
(GLenum
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
 -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IORef GLenum -> ContextT ctx os m ()
addCacheFinalizer GLenum
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
deleteVBOBuf
    where deleteVBOBuf :: GLenum
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
deleteVBOBuf GLenum
n (Map [VAOKey] (IORef GLenum)
vao, Map FBOKeys (IORef GLenum)
fbo) = (Map [VAOKey] (IORef GLenum)
vao, (FBOKeys -> IORef GLenum -> Bool)
-> Map FBOKeys (IORef GLenum) -> Map FBOKeys (IORef GLenum)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                                          (\ FBOKeys
k IORef GLenum
_ ->
                                             (FBOKey -> Bool) -> [FBOKey] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
                                               (\ FBOKey
fk ->
                                                  FBOKey -> GLenum
fboTname FBOKey
fk GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
/= GLenum
n Bool -> Bool -> Bool
|| Bool
isRB Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= (FBOKey -> Name
fboTlayerOrNegIfRendBuff FBOKey
fk Name -> Name -> Bool
forall a. Ord a => a -> a -> Bool
< Name
0))
                                               ([FBOKey] -> Bool) -> [FBOKey] -> Bool
forall a b. (a -> b) -> a -> b
$ FBOKeys -> [FBOKey]
getFBOKeys FBOKeys
k)
                                          Map FBOKeys (IORef GLenum)
fbo)


getVAO :: ContextData -> [VAOKey] -> IO (Maybe (IORef GLuint))
getVAO :: ContextData -> [VAOKey] -> IO (Maybe (IORef GLenum))
getVAO ContextData
cd [VAOKey]
k = do (Map [VAOKey] (IORef GLenum)
vaos, Map FBOKeys (IORef GLenum)
_) <- ContextData
-> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
forall a. MVar a -> IO a
readMVar ContextData
cd
                 Maybe (IORef GLenum) -> IO (Maybe (IORef GLenum))
forall (m :: * -> *) a. Monad m => a -> m a
return ([VAOKey] -> Map [VAOKey] (IORef GLenum) -> Maybe (IORef GLenum)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [VAOKey]
k Map [VAOKey] (IORef GLenum)
vaos)

setVAO :: ContextData -> [VAOKey] -> IORef GLuint -> IO ()
setVAO :: ContextData -> [VAOKey] -> IORef GLenum -> IO ()
setVAO ContextData
cd [VAOKey]
k IORef GLenum
v = ContextData
-> ((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
    -> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ContextData
cd (((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
  -> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
 -> IO ())
-> ((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
    -> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \ (Map [VAOKey] (IORef GLenum)
vaos, Map FBOKeys (IORef GLenum)
fbos) -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
forall (m :: * -> *) a. Monad m => a -> m a
return ([VAOKey]
-> IORef GLenum
-> Map [VAOKey] (IORef GLenum)
-> Map [VAOKey] (IORef GLenum)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [VAOKey]
k IORef GLenum
v Map [VAOKey] (IORef GLenum)
vaos, Map FBOKeys (IORef GLenum)
fbos)

getFBO :: ContextData -> FBOKeys -> IO (Maybe (IORef GLuint))
getFBO :: ContextData -> FBOKeys -> IO (Maybe (IORef GLenum))
getFBO ContextData
cd FBOKeys
k = do (Map [VAOKey] (IORef GLenum)
_, Map FBOKeys (IORef GLenum)
fbos) <- ContextData
-> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
forall a. MVar a -> IO a
readMVar ContextData
cd
                 Maybe (IORef GLenum) -> IO (Maybe (IORef GLenum))
forall (m :: * -> *) a. Monad m => a -> m a
return (FBOKeys -> Map FBOKeys (IORef GLenum) -> Maybe (IORef GLenum)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FBOKeys
k Map FBOKeys (IORef GLenum)
fbos)

setFBO :: ContextData -> FBOKeys -> IORef GLuint -> IO ()
setFBO :: ContextData -> FBOKeys -> IORef GLenum -> IO ()
setFBO ContextData
cd FBOKeys
k IORef GLenum
v = ContextData
-> ((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
    -> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ContextData
cd (((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
  -> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
 -> IO ())
-> ((Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
    -> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(Map [VAOKey] (IORef GLenum)
vaos, Map FBOKeys (IORef GLenum)
fbos) -> (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
-> IO (Map [VAOKey] (IORef GLenum), Map FBOKeys (IORef GLenum))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map [VAOKey] (IORef GLenum)
vaos, FBOKeys
-> IORef GLenum
-> Map FBOKeys (IORef GLenum)
-> Map FBOKeys (IORef GLenum)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FBOKeys
k IORef GLenum
v Map FBOKeys (IORef GLenum)
fbos)